equal
deleted
inserted
replaced
10 use warnings; |
10 use warnings; |
11 |
11 |
12 use Fatal qw(:void select); |
12 use Fatal qw(:void select); |
13 use File::Temp qw(tempfile); |
13 use File::Temp qw(tempfile); |
14 use if $ENV{DEBUG} => "Smart::Comments"; |
14 use if $ENV{DEBUG} => "Smart::Comments"; |
|
15 use FindBin qw($Bin); |
15 |
16 |
16 sub print_message(*@); |
17 sub print_message(*@); |
17 sub read_message(); |
18 sub read_message(); |
18 sub pass_mime($); |
19 sub pass_mime($$); |
19 sub forward_to_boundary($*); |
20 sub forward_to_boundary($*); |
20 sub read_header(*); |
21 sub read_header(*); |
21 |
22 |
22 # |
23 # |
23 sub process(*;@); |
24 sub process($*;@); |
|
25 my $confdir = -f "$Bin/.build" ? $Bin : "/etc/$0"; |
|
26 my @mimes; |
24 |
27 |
25 $SIG{__WARN__} = sub { print STDERR "### ", @_ }; |
28 $SIG{__WARN__} = sub { print STDERR "### ", @_ }; |
26 |
29 |
27 MAIN: { |
30 MAIN: { |
28 |
31 |
|
32 open ( my $fh, "< $confdir/mimes.conf") |
|
33 or warn "can't read config!\n"; |
|
34 my @mimes = map { chomp; $_ } grep !/(?:^\s*#|^\s*$)/, <$fh>; |
|
35 |
29 # create an r/o tmp file containing the message for sequential |
36 # create an r/o tmp file containing the message for sequential |
30 # processing and optional failback in face of some processing error |
37 # processing and optional failback in face of some processing error |
31 my $message = read_message(); |
38 my $message = read_message(); |
32 |
39 |
33 # during processing everything is printed into some tmp file |
40 # during processing everything is printed into some tmp file |
36 my $tmpout = tempfile(); |
43 my $tmpout = tempfile(); |
37 my $stdout = select $tmpout; |
44 my $stdout = select $tmpout; |
38 |
45 |
39 # now we start processing but at the beginning - of course |
46 # now we start processing but at the beginning - of course |
40 seek($message, 0, 0); |
47 seek($message, 0, 0); |
41 process($message, boundary => undef); |
48 process(\@mimes, $message, boundary => undef); |
42 |
49 |
43 # everything is done, probably some rest is still unprocessed (some |
50 # everything is done, probably some rest is still unprocessed (some |
44 # epilogue, but this shouldn't be a problem at all |
51 # epilogue, but this shouldn't be a problem at all |
45 { |
52 { |
46 local $/ = \10240; |
53 local $/ = \10240; |
62 print; |
69 print; |
63 last if $arg{to} and /^--\Q$arg{to}\E/; |
70 last if $arg{to} and /^--\Q$arg{to}\E/; |
64 } |
71 } |
65 } |
72 } |
66 |
73 |
67 sub process(*;@) { |
74 sub process($*;@) { |
68 my ($m, %arg) = @_; |
75 my ($mimes, $m, %arg) = @_; |
69 my ($header, %header) = read_header($m); |
76 my ($header, %header) = read_header($m); |
70 my ($type, $boundary); |
77 my ($type, $boundary); |
71 |
78 |
72 if ($header{"content-type"}) { |
79 if ($header{"content-type"}) { |
73 ($type) = ($header{"content-type"} =~ /^([^;]*)/); |
80 ($type) = ($header{"content-type"} =~ /^([^;]*)/); |
78 ### bound: $boundary |
85 ### bound: $boundary |
79 } |
86 } |
80 |
87 |
81 $boundary ||= $arg{boundary}; |
88 $boundary ||= $arg{boundary}; |
82 |
89 |
83 if (not $type or pass_mime($type)) { |
90 if (not $type or pass_mime($type, $mimes)) { |
84 warn "passing: " . ($type ? $type : "no mime type") . "\n"; |
91 warn "passing: " . ($type ? $type : "no mime type") . "\n"; |
85 print $header; |
92 print $header; |
86 print_message($m, to => $boundary); |
93 print_message($m, to => $boundary); |
87 return; |
94 return; |
88 } |
95 } |
91 warn "forward to next multipart boundary: $boundary\n"; |
98 warn "forward to next multipart boundary: $boundary\n"; |
92 print $header; |
99 print $header; |
93 print_message($m, to => $boundary); |
100 print_message($m, to => $boundary); |
94 |
101 |
95 while (not eof($m)) { |
102 while (not eof($m)) { |
96 process($m, boundary => $boundary); |
103 process($mimes, $m, boundary => $boundary); |
97 } |
104 } |
98 |
105 |
99 return; |
106 return; |
100 } |
107 } |
101 |
108 |
117 } |
124 } |
118 } |
125 } |
119 |
126 |
120 } |
127 } |
121 |
128 |
122 sub pass_mime($) { |
129 sub pass_mime($$) { |
123 local $_ = shift; |
130 my ($type, $mimes) = @_; |
124 return m{(?:^text/)|(?:/signed)}; |
131 local $_ = $type; |
|
132 my $re = join "|", map { $a = $_; $a =~ s/([^\da-z])/\\$1/gi; $a } @$mimes; |
|
133 return m{$re}; |
125 } |
134 } |
126 |
135 |
127 sub read_message() { |
136 sub read_message() { |
128 my $tmp = tempfile(); |
137 my $tmp = tempfile(); |
129 |
138 |
155 return ($h, |
164 return ($h, |
156 map { ($a = $_) =~ s/\s*$//; $a } |
165 map { ($a = $_) =~ s/\s*$//; $a } |
157 ":unix_from:" => split(/^(\S+):\s*/m, $_)); |
166 ":unix_from:" => split(/^(\S+):\s*/m, $_)); |
158 } |
167 } |
159 __END__ |
168 __END__ |
|
169 # vim:ts=4 |