27 |
27 |
28 $SIG{__WARN__} = sub { print STDERR "### ", @_ }; |
28 $SIG{__WARN__} = sub { print STDERR "### ", @_ }; |
29 |
29 |
30 MAIN: { |
30 MAIN: { |
31 |
31 |
32 open ( my $fh, "< $confdir/mimes.conf") |
32 open(my $fh, "< $confdir/mimes.conf") |
33 or warn "can't read config!\n"; |
33 or warn "can't read config!\n"; |
34 my @mimes = map { chomp; $_ } grep !/(?:^\s*#|^\s*$)/, <$fh>; |
34 my @mimes = map { chomp; $_ } grep !/(?:^\s*#|^\s*$)/, <$fh>; |
35 |
35 |
36 # create an r/o tmp file containing the message for sequential |
36 # create an r/o tmp file containing the message for sequential |
37 # processing and optional failback in face of some processing error |
37 # processing and optional failback in face of some processing error |
38 my $message = read_message(); |
38 my $message = read_message(); |
39 |
39 |
40 # during processing everything is printed into some tmp file |
40 # during processing everything is printed into some tmp file |
70 last if $arg{to} and /^--\Q$arg{to}\E/; |
70 last if $arg{to} and /^--\Q$arg{to}\E/; |
71 } |
71 } |
72 } |
72 } |
73 |
73 |
74 sub process($*;@) { |
74 sub process($*;@) { |
75 my ($mimes, $m, %arg) = @_; |
75 my ($mimes, $m, %arg) = @_; |
76 my ($header, %header) = read_header($m); |
76 my ($header, %header) = read_header($m); |
77 my ($type, $boundary); |
77 my ($type, $boundary); |
78 |
78 |
79 if ($header{"content-type"}) { |
79 if ($header{"content-type"}) { |
80 ($type) = ($header{"content-type"} =~ /^([^;]*)/); |
80 ($type) = ($header{"content-type"} =~ /^([^;]*)/); |
86 } |
86 } |
87 |
87 |
88 $boundary ||= $arg{boundary}; |
88 $boundary ||= $arg{boundary}; |
89 |
89 |
90 if (not $type or pass_mime($type, $mimes)) { |
90 if (not $type or pass_mime($type, $mimes)) { |
|
91 |
91 #warn "passing: " . ($type ? $type : "no mime type") . "\n"; |
92 #warn "passing: " . ($type ? $type : "no mime type") . "\n"; |
92 print $header; |
93 print $header; |
93 print_message($m, to => $boundary); |
94 print_message($m, to => $boundary); |
94 return; |
95 return; |
95 } |
96 } |
96 |
97 |
97 if ($type =~ m{^multipart/}) { |
98 if ($type =~ m{^multipart/}) { |
|
99 |
98 #warn "forward to next multipart boundary: $boundary\n"; |
100 #warn "forward to next multipart boundary: $boundary\n"; |
99 print $header; |
101 print $header; |
100 print_message($m, to => $boundary); |
102 print_message($m, to => $boundary); |
101 |
103 |
102 while (not eof($m)) { |
104 while (not eof($m)) { |
103 process($mimes, $m, boundary => $boundary); |
105 process($mimes, $m, boundary => $boundary); |
104 } |
106 } |
105 |
107 |
106 return; |
108 return; |
107 } |
109 } |
108 |
110 |
109 #warn "removed: $type\n"; |
111 #warn "removed: $type\n"; |
110 |
112 |
111 my ($eol) = ($header =~ /(\s*)$/); |
113 my ($eol) = ($header =~ /(\s*)$/); |
112 $header =~ s/\s*$//; |
114 $header =~ s/\s*$//; |
113 $header =~ s/^/-- /gm; |
115 $header =~ s/^/-- /gm; |
114 |
116 |
115 print "Content-Type: text/plain" . $eol x 2 |
117 print "Content-Type: text/plain" |
116 . "Content removed (" . localtime() . ")$eol" |
118 . $eol x 2 |
117 . $header |
119 . "Content removed (" |
118 . $eol; |
120 . localtime() . ")$eol" |
|
121 . $header |
|
122 . $eol; |
119 |
123 |
120 while (<$m>) { |
124 while (<$m>) { |
121 if (/^--\Q$boundary\E/) { |
125 if (/^--\Q$boundary\E/) { |
122 print; |
126 print; |
123 last; |
127 last; |
124 } |
128 } |
125 } |
129 } |
126 |
130 |
127 } |
131 } |
128 |
132 |
129 sub pass_mime($$) { |
133 sub pass_mime($$) { |
130 my ($type, $mimes) = @_; |
134 my ($type, $mimes) = @_; |
131 local $_ = $type; |
135 local $_ = $type; |
132 my $re = join "|", map { $a = $_; $a =~ s/([^\da-z])/\\$1/gi; $a } @$mimes; |
136 my $re = join "|", |
133 return m{$re}; |
137 map { $a = $_; $a =~ s/([^\da-z])/\\$1/gi; $a } @$mimes; |
|
138 return m{$re}; |
134 } |
139 } |
135 |
140 |
136 sub read_message() { |
141 sub read_message() { |
137 my $tmp = tempfile(); |
142 my $tmp = tempfile(); |
138 |
143 |