1 #! /usr/bin/perl |
1 #! /usr/bin/perl |
|
2 # $Id$ |
|
3 # $URL$ |
|
4 # |
|
5 # ** Just proof of concept ** to see if we really need to decode all the |
|
6 # mime parts. |
|
7 # |
2 |
8 |
3 use strict; |
9 use strict; |
4 use warnings; |
10 use warnings; |
5 |
11 |
6 use Fatal qw(:void select); |
12 use Fatal qw(:void select); |
7 use File::Temp qw(tempfile); |
13 use File::Temp qw(tempfile); |
8 use if $ENV{DEBUG} => "Smart::Comments"; |
14 use if $ENV{DEBUG} => "Smart::Comments"; |
9 |
15 |
10 sub print_message(*$); |
16 sub print_message(*@); |
11 sub read_message(); |
17 sub read_message(); |
12 sub pass_mime($); |
18 sub pass_mime($); |
13 sub forward_to_boundary($*); |
19 sub forward_to_boundary($*); |
14 sub read_header(*$); |
20 sub read_header(*); |
15 sub process(*$$); |
21 |
|
22 # |
|
23 sub process(*;@); |
|
24 |
|
25 $SIG{__WARN__} = sub { print STDERR "### ", @_ }; |
16 |
26 |
17 MAIN: { |
27 MAIN: { |
|
28 |
|
29 # create an r/o tmp file containing the message for sequential |
|
30 # processing and optional failback in face of some processing error |
18 my $message = read_message(); |
31 my $message = read_message(); |
19 my $tmpout = tempfile(); |
|
20 my $stdout = select $tmpout; # print ab jetzt ins tmpout |
|
21 |
32 |
|
33 # during processing everything is printed into some tmp file |
|
34 # - this way we can abort processing at any time and just send |
|
35 # the above temporary file down the river |
|
36 my $tmpout = tempfile(); |
|
37 my $stdout = select $tmpout; |
|
38 |
|
39 # now we start processing but at the beginning - of course |
22 seek($message, 0, 0); |
40 seek($message, 0, 0); |
23 process($message, undef, undef); |
41 process($message, boundary => undef); |
24 |
42 |
25 # spit out everthing |
43 # everything is done, probably some rest is still unprocessed (some |
26 select $stdout; |
44 # epilogue, but this shouldn't be a problem at all |
27 seek($tmpout, 0, 0); |
|
28 |
|
29 # now output the stuff collected in tmpout |
|
30 # and the rest of the message |
|
31 { |
45 { |
32 local $/ = \10240; |
46 local $/ = \10240; |
33 print while <$tmpout>; |
47 if ($tmpout) { |
|
48 seek($tmpout, 0, 0); |
|
49 select $stdout; |
|
50 print while <$tmpout>; |
|
51 } |
34 print while <$message>; |
52 print while <$message>; |
35 } |
53 } |
36 |
54 |
37 exit 0; |
55 exit 0; |
38 } |
56 } |
39 |
57 |
40 sub print_message(*$) { |
58 sub print_message(*@) { |
41 my ($m, $b) = @_; |
59 my ($m, %arg) = @_; |
42 |
|
43 if (not defined $b) { |
|
44 return print while <$m>; |
|
45 } |
|
46 |
60 |
47 while (<$m>) { |
61 while (<$m>) { |
48 print; |
62 print; |
49 last if /^--$b--\s*/; |
63 last if $arg{to} and /$arg{to}/; |
50 } |
64 } |
51 } |
65 } |
52 |
66 |
53 sub process(*$$) { |
67 sub process(*;@) { |
54 my ($m, $boundary, $mime_version) = @_; |
68 my ($m, %arg) = @_; |
55 my ($header, %header) = read_header($m, $boundary); |
69 my ($header, %header) = read_header($m); |
56 my $mime_type; |
70 my ($type, $boundary); |
57 |
71 |
58 $mime_version ||= $header{"mime-version"}; |
72 if ($header{"content-type"}) { |
59 |
73 ($type) = ($header{"content-type"} =~ /^([^;]*)/); |
60 ### $header |
74 (undef, $boundary) |
61 |
75 = ($header{"content-type"} =~ /boundary=(['"])(.*?)\1/); |
62 if ( $mime_version |
76 ### h{content-type}: $header{"content-type"} |
63 and $header{"content-type"}) |
77 ### type: $type |
64 { |
78 ### bound: $boundary |
65 ($mime_type, undef, $boundary) = ( |
|
66 $header{"content-type"} =~ /^(.*?); # mime type |
|
67 (?:.*(?:boundary=(['"])(.*?)\2))? # eventuell noch mehr |
|
68 /x |
|
69 ); |
|
70 } |
79 } |
71 |
80 |
72 if (not $mime_type or pass_mime($mime_type)) { |
81 $boundary ||= $arg{boundary}; |
73 warn "passing: " . ($mime_type ? $mime_type : "no mime_type") . "\n"; |
82 |
|
83 if (not $type or pass_mime($type)) { |
|
84 warn "passing: " . ($type ? $type : "no mime type") . "\n"; |
74 print $header; |
85 print $header; |
75 print_message($m, $boundary); |
86 print_message($m, to => $boundary ? "^--$boundary" : undef); |
76 return; |
87 return; |
77 } |
88 } |
78 else { |
89 |
79 warn "not just passing: $mime_type\n"; |
90 if ($type =~ m{^multipart/}) { |
|
91 warn "forward to next multipart boundary: $boundary\n"; |
|
92 print $header; |
|
93 print_message($m, to => "^--$boundary"); |
|
94 |
|
95 while (not eof($m)) { |
|
96 process($m, boundary => $boundary); |
|
97 } |
|
98 |
|
99 return; |
80 } |
100 } |
81 |
101 |
82 process($m, $boundary, $mime_version); |
102 warn "removed: $type\n"; |
|
103 |
|
104 my ($eol) = ($header =~ /(\s*)$/); |
|
105 $header =~ s/\s*$//; |
|
106 $header =~ s/^/-- /gm; |
|
107 |
|
108 print "Content-Type: text/plain" . $eol x 2 |
|
109 . "Content removed (" . localtime() . ")$eol" |
|
110 . $header |
|
111 . $eol; |
|
112 |
|
113 while (<$m>) { |
|
114 if (/^--$boundary/) { |
|
115 print; |
|
116 last; |
|
117 } |
|
118 } |
83 |
119 |
84 } |
120 } |
85 |
121 |
86 sub pass_mime($) { |
122 sub pass_mime($) { |
87 return $_[0] =~ m{/signed}; |
123 local $_ = shift; |
|
124 return m{(?:^text/)|(?:/signed)}; |
88 } |
125 } |
89 |
126 |
90 sub read_message() { |
127 sub read_message() { |
91 my $tmp = tempfile(); |
128 my $tmp = tempfile(); |
92 |
129 |
97 return $tmp; |
134 return $tmp; |
98 } |
135 } |
99 |
136 |
100 # in: current message file handle |
137 # in: current message file handle |
101 # out: ($orignal_header, %parsed_header) |
138 # out: ($orignal_header, %parsed_header) |
102 sub read_header(*$) { |
139 sub read_header(*) { |
103 my ($msg, $start) = @_; |
140 my ($msg) = @_; |
104 my $h = ""; |
141 my $h = ""; |
105 |
|
106 if (defined $start) { |
|
107 while (<$msg>) { |
|
108 $h .= $_; |
|
109 last if /^--$start\s*$/; |
|
110 } |
|
111 } |
|
112 |
142 |
113 while (<$msg>) { |
143 while (<$msg>) { |
114 $h .= $_; |
144 $h .= $_; |
115 last if /^\s*$/; |
145 last if /^\s*$/m; |
116 } |
146 } |
117 |
147 |
118 $_ = $h; # unmodified header (excl. $from) |
148 $_ = $h; # unmodified header (excl. $from) |
119 |
149 |
|
150 ### $_ |
|
151 |
120 s/\r?\n\s+(?=\S)/ /gm; # continuation lines |
152 s/\r?\n\s+(?=\S)/ /gm; # continuation lines |
121 s/^(\S+):/\L$1:/gm; # header fields to lower case |
153 s/^(\S+):/\L$1:/gm; # header fields to lower case |
122 |
154 |
123 return ($h, ":unix_from:" => split(/^(\S+):\s*/m, $_)); |
155 return ($h, |
|
156 map { ($a = $_) =~ s/\s*$//; $a } |
|
157 ":unix_from:" => split(/^(\S+):\s*/m, $_)); |
124 } |
158 } |
125 __END__ |
159 __END__ |