Debbugs/MIME.pm

   1 package Debbugs::MIME;
   2
   3 use strict;
   4
   5 use File::Path;
   6 use MIME::Parser;
   7 use Exporter ();
   8 use vars qw($VERSION @ISA @EXPORT_OK);
   9
  10 BEGIN {
  11     $VERSION = 1.00;
  12
  13     @ISA = qw(Exporter);
  14     @EXPORT_OK = qw(parse);
  15 }
  16
  17 sub getmailbody ($);
  18 sub getmailbody ($)
  19 {
  20     my $entity = shift;
  21     my $type = $entity->effective_type;
  22     if ($type eq 'text/plain' or
  23             ($type =~ m#text/# and $type ne 'text/html') or
  24             $type eq 'application/pgp') {
  25         return $entity->bodyhandle;
  26     } elsif ($type eq 'multipart/alternative') {
  27         # RFC 2046 says we should use the last part we recognize.
  28         for my $part (reverse $entity->parts) {
  29             my $ret = getmailbody($part);
  30             return $ret if $ret;
  31         }
  32     } else {
  33         # For other multipart types, we just pretend they're
  34         # multipart/mixed and run through in order.
  35         for my $part ($entity->parts) {
  36             my $ret = getmailbody($part);
  37             return $ret if $ret;
  38         }
  39     }
  40     return undef;
  41 }
  42
  43 sub parse ($)
  44 {
  45     # header and decoded body respectively
  46     my (@headerlines, @bodylines);
  47
  48     my $parser = new MIME::Parser;
  49     mkdir "mime.tmp.$$", 0777;
  50     $parser->output_under("mime.tmp.$$");
  51     my $entity = eval { $parser->parse_data($_[0]) };
  52
  53     if ($entity and $entity->head->tags) {
  54         @headerlines = @{$entity->head->header};
  55         chomp @headerlines;
  56
  57         my $entity_body = getmailbody($entity);
  58         @bodylines = $entity_body ? $entity_body->as_lines() : ();
  59         chomp @bodylines;
  60     } else {
  61         # Legacy pre-MIME code, kept around in case MIME::Parser fails.
  62         my @msg = split /\n/, $_[0];
  63         my $i;
  64
  65         for ($i = 0; $i <= $#msg; ++$i) {
  66             $_ = $msg[$i];
  67             last unless length;
  68             while ($msg[$i + 1] =~ /^\s/) {
  69                 ++$i;
  70                 $_ .= "\n" . $msg[$i];
  71             }
  72             push @headerlines, $_;
  73         }
  74
  75         @bodylines = @msg[$i .. $#msg];
  76     }
  77
  78     rmtree "mime.tmp.$$", 0, 1;
  79
  80     # Remove blank lines.
  81     shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
  82
  83     # Strip off RFC2440-style PGP clearsigning.
  84     if (@bodylines and $bodylines[0] =~ /^-----BEGIN PGP SIGNED/) {
  85         shift @bodylines while @bodylines and length $bodylines[0];
  86         shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
  87         for my $findsig (0 .. $#bodylines) {
  88             if ($bodylines[$findsig] =~ /^-----BEGIN PGP SIGNATURE/) {
  89                 $#bodylines = $findsig - 1;
  90                 last;
  91             }
  92         }
  93         map { s/^- // } @bodylines;
  94     }
  95
  96     return { header => [@headerlines], body => [@bodylines]};
  97 }
  98
  99 1;