1 #! /usr/bin/perl |
1 #! /usr/bin/perl |
2 use strict; |
2 use strict; |
3 use warnings; |
3 use warnings; |
4 |
4 |
|
5 use Fatal qw(:void select); |
5 use File::Temp qw(tempfile); |
6 use File::Temp qw(tempfile); |
6 use Smart::Comments; |
7 use Smart::Comments; |
7 |
8 |
|
9 sub read_message(); |
|
10 sub parse(*); |
8 sub pass_mime($); |
11 sub pass_mime($); |
9 sub forward_to_boundary($*); |
12 sub forward_to_boundary($*); |
10 sub read_header(*); |
13 sub read_header(*); |
|
14 sub process(*); |
11 |
15 |
12 MAIN: { |
16 MAIN: { |
13 my $message = tempfile(); |
17 my $message = read_message(); |
14 my $out = tempfile(); |
18 my $tmpout = tempfile(); |
|
19 my $stdout = select $tmpout; |
15 |
20 |
16 select $out or die "Can't select: $!\n"; |
21 seek($message, 0, 0); |
|
22 process($message); |
17 |
23 |
18 # read the message into our tmp file |
24 # spit out everthing |
|
25 select $stdout; |
|
26 seek($tmpout, 0, 0); |
|
27 |
|
28 { # the tmpout may contain only parts of the message |
|
29 # to avoid unnessesary copy actioins |
|
30 local $/ = \10240; |
|
31 print while <$tmpout>; |
|
32 print while <$message>; |
|
33 } |
|
34 } |
|
35 |
|
36 sub process(*) { |
|
37 my $m = shift; |
|
38 my ($header, %header) = read_header($m); |
|
39 |
|
40 if ( !$header{"mime-version"} |
|
41 or !$header{"content-type"}) |
19 { |
42 { |
20 local $/ = \102400; |
43 print $header; |
21 print {$message} <>; |
44 return; |
22 chmod 0400, $message or die "Can't fchmod on tmpfile: $!\n"; |
|
23 } |
45 } |
24 |
46 |
25 seek($message, 0, 0); |
47 if (my $boundary = pass_mime($header{"content-type"})) { |
26 my %header = read_header $message; |
48 warn "passing ", ($header{"content-type"} =~ /^(.*?);/)[0], "\n"; |
|
49 print $header; |
|
50 while (<$m>) { print; last if /^--\Q$boundary\E--\s*/ } |
|
51 } |
27 |
52 |
28 |
53 |
29 BODY: { |
54 #my $boundary; |
30 last BODY; |
55 #$boundary = $2 |
31 |
56 # if ($header{"content-type"} =~ m{boundary=(['"])(.*?)\1}); |
32 if (!$header{"mime-version"}) { |
|
33 warn "no mime-version in header\n"; |
|
34 last BODY; |
|
35 } |
|
36 |
|
37 if (!$header{"content-type"}) { |
|
38 warn "no content-type in header\n"; |
|
39 last BODY; |
|
40 } |
|
41 |
|
42 if (pass_mime($header{"content-type"})) { |
|
43 warn "passing message ($header{'content-type'})\n"; |
|
44 last BODY; |
|
45 } |
|
46 |
|
47 # looks more complicated |
|
48 |
|
49 my (undef, $boundary) |
|
50 = ($header{"content-type"} =~ /boundary=(["'])(.*?)\1/); |
|
51 |
|
52 if (!$boundary) { |
|
53 warn "no boundary in content-type\n"; |
|
54 last BODY; |
|
55 } |
|
56 |
|
57 ### boundary: $boundary |
|
58 |
|
59 $_ = forward_to_boundary($boundary, $message); |
|
60 |
|
61 } |
|
62 print <$message>; # the rest |
|
63 |
|
64 # nun das TMP-File auch ausgeben |
|
65 select STDOUT; |
|
66 seek($out, 0, 0); |
|
67 print while <$out>; |
|
68 |
57 |
69 } |
58 } |
70 |
59 |
71 sub forward_to_boundary($*) { |
60 sub forward_to_boundary($*) { |
72 my ($b, $fh) = @_; |
61 my ($b, $fh) = @_; |
73 while (<$fh>) { |
62 while (<$fh>) { |
74 print; |
63 print; |
75 return if /^--$b/; |
64 return if /^--$b/; |
76 } |
65 } |
77 } |
66 } |
78 |
67 |
79 sub pass_mime($) { |
68 sub pass_mime($) { |
80 return $_[0] =~ m{^text/plain}; |
69 return $_[0] =~ m{/signed}; |
81 } |
70 } |
82 |
71 |
|
72 sub read_message() { |
|
73 my $tmp = tempfile(); |
|
74 |
|
75 local $/ = \102400; |
|
76 print {$tmp} $_ while <>; |
|
77 chmod 0400, $tmp or die "Can't fchmod on tmpfile: $!\n"; |
|
78 |
|
79 return $tmp; |
|
80 } |
|
81 |
|
82 # in: current message file handle |
|
83 # out: ($orignal_header, %parsed_header) |
83 sub read_header(*) { |
84 sub read_header(*) { |
84 my $msg = shift; |
85 my $msg = shift; |
|
86 my ($from, $h); |
85 |
87 |
86 local $/ = ""; |
|
87 local $_ = <$msg>; |
88 local $_ = <$msg>; |
|
89 $from = /^from\s/i ? $_ : ""; |
88 |
90 |
89 print; |
91 while (<$msg>) { $h .= $_; last if /^\s*$/ } |
|
92 $_ = $h; |
90 |
93 |
91 s/\r?\n\s+/ /gm; # FIXME: decode quoted printable |
94 s/\r?\n\s+(?=\S)/ /gm; # continuation lines |
92 s/^(\S+):/\L$1:/gm; # header fields to lower case |
95 s/^(\S+):/\L$1:/gm; # header fields to lower case |
93 |
96 |
94 return (":UNIX_FROM:" => split(/^(\S+):\s*/m, $_) ); |
97 return ("$from$h", ":unix_from:" => split(/^(\S+):\s*/m, "$from$_")); |
95 |
|
96 } |
98 } |
97 __END__ |
99 __END__ |
98 |
100 |
99 my $parser = new MIME::Parser; |
101 my $parser = new MIME::Parser; |
100 |
102 |