hs12
changeset 15 9482d3366306
parent 14 6f1e07f90b46
equal deleted inserted replaced
14:6f1e07f90b46 15:9482d3366306
    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