]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/MIME.pm
get_bug_status can now accept a schema to pull from DB
[debbugs.git] / Debbugs / MIME.pm
1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
5 #
6 # [Other people have contributed to this file; their copyrights should
7 # go here too.]
8 # Copyright 2006 by Don Armstrong <don@donarmstrong.com>.
9
10
11 package Debbugs::MIME;
12
13 =encoding utf8
14
15 =head1 NAME
16
17 Debbugs::MIME -- Mime handling routines for debbugs
18
19 =head1 SYNOPSIS
20
21  use Debbugs::MIME qw(parse decode_rfc1522);
22
23 =head1 DESCRIPTION
24
25
26 =head1 BUGS
27
28 None known.
29
30 =cut
31
32 use warnings;
33 use strict;
34
35 use Exporter qw(import);
36 use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
37
38 BEGIN {
39     $VERSION = 1.00;
40     $DEBUG = 0 unless defined $DEBUG;
41
42     @EXPORT = ();
43
44     %EXPORT_TAGS = (mime => [qw(parse create_mime_message getmailbody),
45                              qw(parse_to_mime_entity),
46                             ],
47                     rfc1522 => [qw(decode_rfc1522 encode_rfc1522)],
48                    );
49     @EXPORT_OK=();
50     Exporter::export_ok_tags(keys %EXPORT_TAGS);
51     $EXPORT_TAGS{all} = [@EXPORT_OK];
52 }
53
54 use File::Path qw(remove_tree);
55 use File::Temp qw(tempdir);
56 use MIME::Parser;
57
58 use POSIX qw(strftime);
59 use List::AllUtils qw(apply);
60
61 # for convert_to_utf8
62 use Debbugs::UTF8 qw(convert_to_utf8);
63
64 # for decode_rfc1522 and encode_rfc1522
65 use Encode qw(decode encode encode_utf8 decode_utf8 is_utf8);
66 use MIME::Words qw();
67
68 sub getmailbody
69 {
70     my $entity = shift;
71     my $type = $entity->effective_type;
72     if ($type eq 'text/plain' or
73             ($type =~ m#text/?# and $type ne 'text/html') or
74             $type eq 'application/pgp') {
75         return $entity;
76     } elsif ($type eq 'multipart/alternative') {
77         # RFC 2046 says we should use the last part we recognize.
78         for my $part (reverse $entity->parts) {
79             my $ret = getmailbody($part);
80             return $ret if $ret;
81         }
82     } else {
83         # For other multipart types, we just pretend they're
84         # multipart/mixed and run through in order.
85         for my $part ($entity->parts) {
86             my $ret = getmailbody($part);
87             return $ret if $ret;
88         }
89     }
90     return undef;
91 }
92
93 =item parse_to_mime_entity
94
95      $entity = parse_to_mime_entity($record);
96
97 Returns a MIME::Entity from a record (from Debbugs::Log), a filehandle, or a
98 scalar mail message. Will die upon failure.
99
100 Intermediate parsing results will be output under a temporary directory which
101 should be cleaned up upon process exit.
102
103 =cut
104
105 sub parse_to_mime_entity {
106     my ($record) = @_;
107     my $parser = MIME::Parser->new();
108     my $entity;
109     # this will be cleaned up once we exit
110     my $tempdir = File::Temp->newdir();
111     $parser->output_dir($tempdir->dirname());
112     if (ref($record) eq 'HASH') {
113         if ($record->{inner_file}) {
114             $entity = $parser->parse($record->{fh}) or
115                 die "Unable to parse entity";
116         } else {
117             $entity = $parser->parse_data($record->{text}) or
118                 die "Unable to parse entity";
119         }
120     } elsif (ref($record)) {
121         $entity = $parser->parse($record) or
122             die "Unable to parse entity";
123     } else {
124         $entity = $parser->parse_data($record) or
125             die "Unable to parse entity";
126     }
127     return $entity;
128 }
129
130 sub parse
131 {
132     # header and decoded body respectively
133     my (@headerlines, @bodylines);
134
135     my $parser = MIME::Parser->new();
136     my $tempdir = tempdir(CLEANUP => 1);
137     $parser->output_under($tempdir);
138     my $entity = eval { $parser->parse_data($_[0]) };
139
140     if ($entity and $entity->head->tags) {
141         @headerlines = @{$entity->head->header};
142         chomp @headerlines;
143
144         my $entity_body = getmailbody($entity);
145         my $entity_body_handle;
146         my $charset;
147         if (defined $entity_body) {
148             $entity_body_handle = $entity_body->bodyhandle();
149             $charset = $entity_body->head()->mime_attr('content-type.charset');
150         }
151         @bodylines = $entity_body_handle ? $entity_body_handle->as_lines() : ();
152         @bodylines = map {convert_to_utf8($_,$charset)} @bodylines;
153         chomp @bodylines;
154     } else {
155         # Legacy pre-MIME code, kept around in case MIME::Parser fails.
156         my @msg = split /\n/, $_[0];
157         my $i;
158
159         # assume us-ascii unless charset is set; probably bad, but we
160         # really shouldn't get to this point anyway
161         my $charset = 'us-ascii';
162         for ($i = 0; $i <= $#msg; ++$i) {
163             $_ = $msg[$i];
164             last unless length;
165             while ($msg[$i + 1] =~ /^\s/) {
166                 ++$i;
167                 $_ .= "\n" . $msg[$i];
168             }
169             if (/charset=\"([^\"]+)\"/) {
170                 $charset = $1;
171             }
172             push @headerlines, $_;
173         }
174         @bodylines = map {convert_to_utf8($_,$charset)} @msg[$i .. $#msg];
175     }
176
177     remove_tree($tempdir,{verbose => 0, safe => 1});
178
179     # Remove blank lines.
180     shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
181
182     # Strip off RFC2440-style PGP clearsigning.
183     if (@bodylines and $bodylines[0] =~ /^-----BEGIN PGP SIGNED/) {
184         shift @bodylines while @bodylines and
185             length $bodylines[0] and
186                 # we currently don't strip \r; handle this for the
187                 # time being, though eventually it should be stripped
188                 # too, I think. [See #565981]
189                 $bodylines[0] ne "\r";
190         shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
191         for my $findsig (0 .. $#bodylines) {
192             if ($bodylines[$findsig] =~ /^-----BEGIN PGP SIGNATURE/) {
193                 $#bodylines = $findsig - 1;
194                 last;
195             }
196         }
197         map { s/^- // } @bodylines;
198     }
199
200     return { header => [@headerlines], body => [@bodylines]};
201 }
202
203 =head2 create_mime_message
204
205      create_mime_message([To=>'don@debian.org'],$body,[$attach1, $attach2],$include_date);
206
207 Creates a MIME encoded message with headers given by the first
208 argument, and a message given by the second.
209
210 Optional attachments can be specified in the third arrayref argument.
211
212 Whether to include the date in the header is the final argument; it
213 defaults to true, setting the Date header if one is not already
214 present.
215
216 Headers are passed directly to MIME::Entity::build, the message is the
217 first attachment.
218
219 Each of the elements of the attachment arrayref is attached as an
220 rfc822 message if it is a scalar or an arrayref; otherwise if it is a
221 hashref, the contents are passed as an argument to
222 MIME::Entity::attach
223
224 =cut
225
226 sub create_mime_message{
227      my ($headers,$body,$attachments,$include_date) = @_;
228      $attachments = [] if not defined $attachments;
229      $include_date = 1 if not defined $include_date;
230
231      die "The first argument to create_mime_message must be an arrayref" unless ref($headers) eq 'ARRAY';
232      die "The third argument to create_mime_message must be an arrayref" unless ref($attachments) eq 'ARRAY';
233
234      if ($include_date) {
235          my %headers = apply {defined $_ ? lc($_) : ''} @{$headers};
236          if (not exists $headers{date}) {
237              push @{$headers},
238                  ('Date',
239                   strftime("%a, %d %b %Y %H:%M:%S +0000",gmtime)
240                  );
241          }
242      }
243
244      # Build the message
245      # MIME::Entity is stupid, and doesn't rfc1522 encode its headers, so we do it for it.
246      my $msg = MIME::Entity->build('Content-Type' => 'text/plain; charset=utf-8',
247                                    'Encoding'     => 'quoted-printable',
248                                    (map{encode_rfc1522(encode_utf8(defined $_ ? $_:''))} @{$headers}),
249                                    Data    => encode_utf8($body),
250                                   );
251
252      # Attach the attachments
253      for my $attachment (@{$attachments}) {
254           if (ref($attachment) eq 'HASH') {
255                $msg->attach(%{$attachment});
256           }
257           else {
258                # This is *craptacular*, but because various MTAs
259                # (sendmail and exim4, at least) appear to eat From
260                # lines in message/rfc822 attachments, we need eat
261                # the entire From line ourselves so the MTA doesn't
262                # leave \n detrius around.
263                if (ref($attachment) eq 'ARRAY' and $attachment->[1] =~ /^From /) {
264                     # make a copy so that we don't screw up anything
265                     # that is expecting this arrayref to stay constant
266                     $attachment = [@{$attachment}];
267                     # remove the from line
268                     splice @$attachment, 1, 1;
269                }
270                elsif (not ref($attachment)) {
271                     # It's a scalar; remove the from line
272                     $attachment =~ s/^(Received:[^\n]+\n)(From [^\n]+\n)/$1/s;
273                }
274                $msg->attach(Type => 'message/rfc822',
275                             Data => $attachment,
276                             Encoding => '7bit',
277                            );
278           }
279      }
280      return $msg->as_string;
281 }
282
283
284
285
286 =head2 decode_rfc1522
287
288     decode_rfc1522('=?iso-8859-1?Q?D=F6n_Armstr=F3ng?= <don@donarmstrong.com>')
289
290 Turn RFC-1522 names into the UTF-8 equivalent.
291
292 =cut
293
294 sub decode_rfc1522 {
295     my ($string) = @_;
296
297     # this is craptacular, but leading space is hacked off by unmime.
298     # Save it.
299     my $leading_space = '';
300     $leading_space = $1 if $string =~ s/^(\ +)//;
301     # we must do this to switch off the utf8 flag before calling decode_mimewords
302     $string = encode_utf8($string);
303     my @mime_words = MIME::Words::decode_mimewords($string);
304     my $tmp = $leading_space .
305         join('',
306              (map {
307                  if (@{$_} > 1) {
308                      convert_to_utf8(${$_}[0],${$_}[1]);
309                  } else {
310                      decode_utf8(${$_}[0]);
311                  }
312              } @mime_words)
313             );
314     return $tmp;
315 }
316
317 =head2 encode_rfc1522
318
319      encode_rfc1522('Dön Armströng <don@donarmstrong.com>')
320
321 Encodes headers according to the RFC1522 standard by calling
322 MIME::Words::encode_mimeword on distinct words as appropriate.
323
324 =cut
325
326 # We cannot use MIME::Words::encode_mimewords because that function
327 # does not handle spaces properly at all.
328
329 sub encode_rfc1522 {
330      my ($rawstr) = @_;
331
332      # handle being passed undef properly
333      return undef if not defined $rawstr;
334
335      # convert to octets if we are given a string in perl's internal
336      # encoding
337      $rawstr= encode_utf8($rawstr) if is_utf8($rawstr);
338      # We process words in reverse so we can preserve spacing between
339      # encoded words. This regex splits on word|nonword boundaries and
340      # nonword|nonword boundaries. We also consider parenthesis and "
341      # to be nonwords to avoid escaping them in comments in violation
342      # of RFC1522
343      my @words = reverse split /(?:(?<=[\s\n\)\(\"])|(?=[\s\n\)\(\"]))/m, $rawstr;
344
345      my $previous_word_encoded = 0;
346      my $string = '';
347      for my $word (@words) {
348           if ($word !~ m#[\x00-\x1F\x7F-\xFF]#o and $word ne ' ') {
349                $string = $word.$string;
350                $previous_word_encoded=0;
351           }
352           elsif ($word =~ /^[\s\n]$/) {
353                $string = $word.$string;
354                $previous_word_encoded = 0 if $word eq "\n";
355           }
356           else {
357                my $encoded = MIME::Words::encode_mimeword($word, 'q', 'UTF-8');
358                # RFC 1522 mandates that segments be at most 76 characters
359                # long. If that's the case, we split the word up into 10
360                # character pieces and encode it. We must use the Encode
361                # magic here to avoid breaking on bit boundaries here.
362                if (length $encoded > 75) {
363                     # Turn utf8 into the internal perl representation
364                     # so . is a character, not a byte.
365                     my $tempstr = is_utf8($word)?$word:decode_utf8($word,Encode::FB_DEFAULT);
366                     my @encoded;
367                     # Strip it into 10 character long segments, and encode
368                     # the segments
369                     # XXX It's possible that these segments are > 76 characters
370                     while ($tempstr =~ s/(.{1,10})$//) {
371                          # turn the character back into the utf8 representation.
372                          my $tempword = encode_utf8($1);
373                          # It may actually be better to eventually use
374                          # the base64 encoding here, but I'm not sure
375                          # if that's as widely supported as quoted
376                          # printable.
377                          unshift @encoded, MIME::Words::encode_mimeword($tempword,'q','UTF-8');
378                     }
379                     $encoded = join(" ",@encoded);
380                     # If the previous word was encoded, we must
381                     # include a trailing _ that gets encoded as a
382                     # space.
383                     $encoded =~ s/\?\=$/_\?\=/ if $previous_word_encoded;
384                     $string = $encoded.$string;
385                }
386                else {
387                     # If the previous word was encoded, we must
388                     # include a trailing _ that gets encoded as a
389                     # space.
390                     $encoded =~ s/\?\=$/_\?\=/ if $previous_word_encoded;
391                     $string = $encoded.$string;
392                }
393                $previous_word_encoded = 1;
394           }
395      }
396      return $string;
397 }
398
399 1;