← Back to branch summary

~ubuntu-branches/ubuntu/natty/quilt/natty

« back to all changes in this revision

Viewing changes to quilt/scripts/edmail.in

  • Committer: Bazaar Package Importer
  • Author(s): Martin Quinson
  • Date: 2006-11-23 16:17:11 UTC
  • mfrom: (2.1.6 feisty)
  • Revision ID: james.westby@ubuntu.com-20061123161711-b17ess0ls8t959ca
Tags: 0.45-6
http://bugs.debian.org/397285
http://bugs.debian.org/395482
http://bugs.debian.org/393985
http://bugs.debian.org/386548
http://bugs.debian.org/395447
http://bugs.debian.org/396093
* [debian/patches/override_mail_sender_in_testsuite]
  Fix the patch to catch all occurences of 'quilt mail' since each of them
  will cause a FTBFS on misconfigured hosts (thanks to Goswin Brederlow).
  (Closes: #397285, #395482, #393985) I hope, at least.
  
* [debian/patches/doc_improvement]
  Fix some more typos in the manpages
  (Closes: #386548, #395447)

* [debian/control]
   Add procmail to suggest list to help users locating the 'formail' tool.
   (Closes: #396093)

Show diffs side-by-side

added added

removed removed

Lines of Context:
quilt/scripts/edmail.in
 
1
#! @PERL@ -w
 
2
 
 
3
# RFCs important for this script:
 
4
#
 
5
# RFC 2822 - Internet Message Format
 
6
# RFC 2047 - MIME (Multipurpose Internet Mail Extensions) Part Three:
 
7
#            Message Header Extensions for Non-ASCII Text
 
8
 
 
9
use Getopt::Long;
 
10
use strict;
 
11
 
 
12
# This ugly trick lets the script work even if gettext support is missing.
 
13
# We did so because Locale::gettext doesn't ship with the standard perl
 
14
# distribution.
 
15
BEGIN {
 
16
    if (eval { require Locale::gettext }) {
 
17
        import Locale::gettext;
 
18
        require POSIX;
 
19
        import POSIX, qw(setlocale);
 
20
    } else {
 
21
        eval '
 
22
            use constant LC_MESSAGES => 0;
 
23
            sub setlocale($$) { }
 
24
            sub bindtextdomain($$) { }
 
25
            sub textdomain($) { }
 
26
            sub gettext($) { shift }
 
27
        '
 
28
    }
 
29
}
 
30
 
 
31
setlocale(LC_MESSAGES, "");
 
32
bindtextdomain("quilt", "@LOCALEDIR@");
 
33
textdomain("quilt");
 
34
 
 
35
sub _($) {
 
36
    return gettext(shift);
 
37
}
 
38
 
 
39
my (%append_name, %append_value, $remove_empty_headers, %remove_header,
 
40
    %extract_recipients_from, %replace_name, %replace_value, $charset);
 
41
GetOptions('add-recipient:s%' =>
 
42
    sub {
 
43
        $append_name{lc $_[1]} = $_[1];
 
44
        $append_value{lc $_[1]} .= ",\n " . $_[2];
 
45
    },
 
46
    'remove-header:s' => sub { $remove_header{lc $_[1]}++ },
 
47
    'remove-empty-headers' => \$remove_empty_headers,
 
48
    'replace-header:s%' =>
 
49
    sub {
 
50
        $replace_name{lc $_[1]} = $_[1];
 
51
        $replace_value{lc $_[1]} = $_[2];
 
52
    },
 
53
    'extract-recipients:s' => sub { $extract_recipients_from{lc $_[1]} = 1 },
 
54
    'charset:s' => \$charset)
 
55
    or exit 1;
 
56
my %recipient_headers = map {lc $_ => 1} (@ARGV, keys %append_name);
 
57
 
 
58
sub encode_header($) {
 
59
    my ($word) = @_;
 
60
    $word =~ s{[^\t\41-\76\100-\176]}{sprintf "=%02X", ord($&)}ge;
 
61
    return "=?$charset?q?$word?=";
 
62
}
 
63
 
 
64
my $special = '()<>\[\]:;@\\,"';  # special characters
 
65
my $special_dot = "$special.";  # special characters + dot
 
66
 
 
67
# Check for a valid display name
 
68
sub check_display_name($) {
 
69
    my ($display) = @_;
 
70
 
 
71
    if ($display =~ /^"((?:[^"\\]|\\[^\n\r])*)"/) {
 
72
        my $quoted = $1;
 
73
        if ($quoted =~ /[^\t\40-\176]/) {
 
74
            $display = $quoted;
 
75
            $display =~ s/\\//;
 
76
            return encode_header($display);
 
77
        }
 
78
    } else {
 
79
        local $_ = $display;
 
80
        # The value is not (properly) quoted. Check for invalid characters.
 
81
        while (/\(/ or /\)/) {
 
82
            die sprintf(
 
83
_("Display name `%s' contains unpaired parentheses\n"), $display)
 
84
                unless s/\(([^()]*)\)/$1/;
 
85
        }
 
86
        if ($display =~ /[^\t\40-\176]/ || $display =~ /[$special_dot]/) {
 
87
            if ($display =~ /[^\1-\10\13\14\16-\37\40\41\43-\133\135-\177]/) {
 
88
                return encode_header($display);
 
89
            } elsif ($display =~ /[$special_dot]/) {
 
90
                return "\"$display\"";
 
91
            }
 
92
        }
 
93
    }
 
94
    return $display;
 
95
}
 
96
 
 
97
# Check for a valid delivery address
 
98
sub check_delivery_address($) {
 
99
    my ($deliver) = @_;
 
100
 
 
101
    die sprintf(_("Delivery address `%s' is invalid\n"), $deliver)
 
102
        if $deliver =~ /[ \t]/ or
 
103
           $deliver =~ /[^ \t\40-\176]/ or
 
104
           $deliver !~ /^[^$special]+@(\[?)[^$special_dot]+(?:\.[^$special_dot]+)*(\]?)$/ or
 
105
           (!$1) != (!$2);
 
106
    return $deliver;
 
107
}
 
108
 
 
109
sub check_recipient($) {
 
110
    my ($recipient) = @_;
 
111
 
 
112
    if ($recipient =~ /^(.*?)\s*<(.+)>$/) {
 
113
        my $deliver = check_delivery_address($2);
 
114
        return ( check_display_name($1) . " <" . $deliver . ">", $deliver );
 
115
    } elsif ($recipient =~ /^(\S*)\s*\((.*)\)$/) {
 
116
        my $deliver = check_delivery_address($1);
 
117
        return ( $deliver . " (" . check_display_name($2) . ")", $deliver );
 
118
    } else {
 
119
        my $deliver = check_delivery_address($recipient);
 
120
        return ( $deliver, $deliver );
 
121
    }
 
122
}
 
123
 
 
124
my %recipients;
 
125
sub process_header($) {
 
126
    local ($_) = @_;
 
127
    my ($name, $value);
 
128
 
 
129
    return unless defined $_;
 
130
    unless (($name, $value) = /^([\41-\176]+):\s*(.*)\s*/s) {
 
131
        print;
 
132
        return
 
133
    }
 
134
    if (%extract_recipients_from) {
 
135
        if (exists $extract_recipients_from{lc $name}) {
 
136
            #print "(($value))";
 
137
            $value =~ s/^\s*//;  $value =~ s/\s*$//;
 
138
            foreach my $recipient (split /\s*,\s*/s, $value) {
 
139
                    next if $recipient =~ /^\s*$/;
 
140
                    #print "<<$recipient>>";
 
141
                    my $deliver;
 
142
                    ($recipient, $deliver) = check_recipient($recipient);
 
143
                    print "$deliver\n";
 
144
            }
 
145
        }
 
146
        return;
 
147
    }
 
148
    return if exists $remove_header{lc $name};
 
149
    if (exists $replace_name{lc $name}) {
 
150
            if (exists $replace_value{lc $name}) {
 
151
                print "$replace_name{lc $name}: $replace_value{lc $name}\n"; 
 
152
                delete $replace_value{lc $name};
 
153
            }
 
154
            return;
 
155
    }
 
156
    if (exists $recipient_headers{lc $1}) {
 
157
        if (exists $append_name{lc $name}) {
 
158
            $value .= $append_value{lc $name};
 
159
            delete $append_name{lc $name};
 
160
        }
 
161
        my @recipients;
 
162
        # This is a recipients field. Split out all the recipients and
 
163
        # check the addresses. Suppress duplicate recipients.
 
164
        $value =~ s/^\s*//;  $value =~ s/\s*$//;
 
165
        foreach my $recipient (split /\s*,\s*/, $value) {
 
166
            next if $recipient =~ /^\s*$/;
 
167
            my $deliver;
 
168
            ($recipient, $deliver) = check_recipient($recipient);
 
169
            unless (exists $recipients{$deliver}) {
 
170
                push @recipients, $recipient;
 
171
                $recipients{$deliver} = $deliver;
 
172
            }
 
173
        }
 
174
        print "$name: ", join(",\n ", @recipients), "\n"
 
175
            if @recipients || !$remove_empty_headers;
 
176
    } else {
 
177
            print if $value ne "" || !$remove_empty_headers;
 
178
    }
 
179
}
 
180
 
 
181
my $header;
 
182
while (<STDIN>) {
 
183
    last if (/^$/);
 
184
    if (/^\S/) {
 
185
        process_header $header;
 
186
        undef $header;
 
187
    }
 
188
    $header .= $_;
 
189
}
 
190
process_header $header;
 
191
foreach my $name (keys %append_name) {
 
192
    process_header $append_name{$name} . ': ' . $append_value{$name};
 
193
}
 
194
unless (%extract_recipients_from) {
 
195
    # Copy the message body to standard output
 
196
    # FIXME check for 7-bit clean, else assume $charset
 
197
    # FIXME if UTF-8, check for invalid characters!
 
198
    # FIXME must make sure that all messages are written in
 
199
    #       either 7-bit or $charset => mbox !!!
 
200
 
 
201
    # Content-Transfer-Encoding: 7bit
 
202
    # Content-Transfer-Encoding: 8bit
 
203
    # Content-Type: text/plain; charset=ISO-8859-15
 
204
    # Content-Type: text/plain; charset=UTF-8
 
205
    undef $/;
 
206
    print "\n", <STDIN>;
 
207
}