Note: Newer version of MIME::Parser delete the From line (the one without the colon). Hopefully this is changed soon. Depending on your version of MIME-Tools you need to fix this. If MIME-Tools don't get fixed, I'll add the code here.
1 | #!/usr/bin/perl -w
2 | #
3 | # This is a mail filter. Takes multipart from STDIN, deletes
4 | # superfluous MIME-parts and reduces multipart/alternative to
5 | # singlepart, finally writes cleaned MIME mail to STDOUT.
6 | #
7 | # By Boris 'pi' Piwinger <3.14@piology.org>. Please let me know if you
8 | # improve it or fix bugs.
9 | #
10 | # Based on tinnef.pl (there is not much left, though;-) by Gerd Knorr
11 | # <gknorr@berlinonline.de>.
12 | #
13 | # This code is public domain. It comes with absolutely no warranty.
14 | # If it eats your mails for lunch, that's your problem. If you don't
15 | # like this, don't use it.
16 | #
17 | # Best with Procmail, e.g.:
18 | #
19 | # # Clean MIME mails
20 | # :0
21 | # * ^Content-Type:.*multipart/
22 | # {
23 | # :0c:
24 | # tmp/fixmail
25 | # :0fhbw
26 | # | fixmail.pl
27 | # }
28 |
29 | # Create parser, we are being daring here (huge mails might cause problems)
30 | use MIME::Parser;
31 | my$done="";
32 | my$parser=MIME::Parser->new;
33 | $parser->output_to_core(1);
34 | my$top=$parser->read(\*STDIN) or die "Couldn't parse MIME stream.\n";
35 | $top=&analyze($top);
36 | $top->head->add('X-pi-MIME-Parts-removed',$done) if $done;
37 | $top->sync_headers(Length=>'COMPUTE');
38 | $top->print(\*STDOUT);
39 | exit 0;
40 |
41 | sub analyze {
42 | my($body,$i)=(@_,0);
43 | my($parts)=$body->{ME_Parts};
44 | if ($body->mime_type eq "multipart/alternative") {
45 | # Reduce multipart/alternative
46 | $i=-1;
47 | $i++ until ($$parts[$i]->mime_type eq "text/plain" || $i==$#{$parts});
48 | if ($$parts[$i]->mime_type eq "text/plain") {
49 | @$parts=@$parts[$i];
50 | $done.=" multipart/alternative";
51 | }
52 | } else {
53 | # Kill superfluous junk:
54 | # - text/x-vcard
55 | # - application/pgp-signature
56 | # - application/x-pkcs7-signature and application/pkcs7-signature
57 | # Recursion on multipart
58 | while ($i<=$#{$parts}) {
59 | if ($$parts[$i]->mime_type =~ /(text\/x-vcard|application\/(?:(?:pgp|(?:x-)?pkcs7)-signature|ms-tnef))/) {
60 | $done.=" $1";
61 | splice(@$parts,$i,1);
62 | } elsif ($$parts[$i]->mime_type =~ /^multipart\//) {
63 | $$parts[$i]=&analyze($$parts[$i]);
64 | $i++;
65 | } else {$i++}
66 | }
67 | }
68 | $body->{ME_Parts}=$parts;
69 | if ($body->mime_type =~ /^multipart\/related/ && $body->head->mime_attr("content-type.type") eq "multipart/alternative")
70 | {$body->head->mime_attr("content-type.type" => "text/plain")}
71 | $body->make_singlepart if $body->parts==1;
72 | return $body;
73 | }
