1 #! /usr/bin/perl

     2 # $Id$

     3 # $URL$

     4 #

     5 

     6 use strict;

     7 use warnings;

     8 

     9 use Fatal qw(:void select);

    10 use File::Temp qw(tempfile);

    11 use if $ENV{DEBUG} => "Smart::Comments";

    12 use File::Basename;

    13 use FindBin qw($Bin);

    14 

    15 sub print_message(*@);

    16 sub read_message();

    17 sub pass_mime($);

    18 sub read_header(*);

    19 sub process(*;@);

    20 

    21 my $ME = basename $0;

    22 my $CONFDIR = -f "$Bin/.build" ? $Bin : "/etc/$ME";

    23 

    24 $SIG{__WARN__} = sub { print STDERR "### ", @_ };

    25 

    26 MAIN: {

    27 

    28     # create an r/o tmp file containing the message  for sequential

    29     # processing and optional failback in face of some processing error

    30     my $message = read_message();

    31 

    32     # during processing everything is printed into some tmp file

    33     # - this way we can abort processing at any time and just send

    34     # the above temporary file down the river

    35     my $tmpout = tempfile();

    36     my $stdout = select $tmpout;

    37 

    38     # now we start processing but at the beginning - of course

    39     seek($message, 0, 0);

    40     process($message, boundary => undef);

    41 

    42     # everything is done, probably some rest is still unprocessed (some

    43     # epilogue, but this shouldn't be a problem at all

    44     {

    45         local $/ = \10240;

    46         if ($tmpout) {

    47             seek($tmpout, 0, 0);

    48             select $stdout;

    49             print while <$tmpout>;

    50         }

    51         print while <$message>;

    52     }

    53 

    54     exit 0;

    55 }

    56 

    57 sub print_message(*@) {

    58     my ($m, %arg) = @_;

    59 

    60     while (<$m>) {

    61         print;

    62         last if $arg{to} and /^--\Q$arg{to}\E/;

    63     }

    64 }

    65 my $vips;

    66 

    67 sub process(*;@) {

    68     my ($m,      %arg)    = @_;

    69     my ($header, %header) = read_header($m);

    70     my ($type, $boundary);

    71 

    72     if (!$vips) {

    73 

    74         open(my $fh, "<$CONFDIR/vips.conf")

    75             or die "can't read $CONFDIR/vips.conf!\n";

    76         $vips

    77             = qr{@{[join "|", map { chomp; "(?:".quotemeta($_).")" } grep !/(?:^\s*#|^\s*$)/, <$fh>]}};

    78 

    79         foreach my $h (qw(from to cc bcc return-path envelope-to)) {

    80             if ($header{$h}) {

    81                 if ($header{$h} =~ /$vips/i) {

    82                     print $header;

    83                     local $/ = \10240;

    84                     print while <$m>;

    85                     return;

    86                 }

    87             }

    88         }

    89     }

    90 

    91     if ($header{"content-type"}) {

    92         ($type) = ($header{"content-type"} =~ /^([^;]*)/);

    93         (undef, $boundary)

    94             = ($header{"content-type"} =~ /boundary=(['"])(.*?)\1/);

    95         ### h{content-type}:  $header{"content-type"}

    96         ### type:         $type

    97         ### bound:            $boundary

    98     }

    99     $boundary ||= $arg{boundary};

   100     if (not $type or pass_mime($type)) {

   101 

   102         #warn "passing: " . ($type ? $type : "no mime type") . "\n";

   103         print $header;

   104         print_message($m, to => $boundary);

   105         return;

   106     }

   107     if ($type =~ m{^multipart/}) {

   108 

   109         #warn "forward to next multipart boundary: $boundary\n";

   110         print $header;

   111         print_message($m, to => $boundary);

   112         while (not eof($m)) {

   113             process($m, boundary => $boundary);

   114         }

   115         return;

   116     }

   117 

   118     #warn "removed: $type\n";

   119 

   120     my ($eol) = ($header =~ /(\s*)$/);

   121     $header =~ s/\s*$//;

   122     $header =~ s/^/-- /gm;

   123 

   124     print "Content-Type: text/plain$eol"

   125         . "Content-Disposition: inline$eol"

   126         . $eol

   127         . "Content removed ("

   128         . localtime() . ")$eol"

   129         . $header

   130         . $eol;

   131 

   132     while (<$m>) {

   133         if (/^--\Q$boundary\E/) {

   134             print;

   135             last;

   136         }

   137     }

   138 }

   139 

   140 {

   141     my $re;

   142 

   143     sub pass_mime($) {

   144         my ($type) = @_;

   145 

   146         if (!$re) {

   147             open(my $fh, "<$CONFDIR/mimes.conf")

   148                 or die "can't read $CONFDIR/mimes.conf!\n";

   149             $re

   150                 = qr{@{[join "|", map { chomp; "(?:".quotemeta($_).")" } grep !/(?:^\s*#|^\s*$)/, <$fh>]}};

   151         }

   152         return $type =~ /$re/i;

   153     }

   154 }

   155 

   156 sub read_message() {

   157     my $tmp = tempfile();

   158 

   159     local $/ = \102400;

   160     print {$tmp} $_ while <>;

   161     chmod 0400, $tmp or die "Can't fchmod on tmpfile: $!\n";

   162 

   163     return $tmp;

   164 }

   165 

   166 # in:   current message file handle

   167 # out:  ($orignal_header, %parsed_header)

   168 sub read_header(*) {

   169     my ($msg) = @_;

   170     my $h = "";

   171 

   172     while (<$msg>) {

   173         $h .= $_;

   174         last if /^\s*$/m;

   175     }

   176 

   177     $_ = $h;    # unmodified header (excl. $from)

   178 

   179     ### $_

   180 

   181     s/\r?\n\s+(?=\S)/ /gm;    # continuation lines

   182     s/^(\S+):/\L$1:/gm;       # header fields to lower case

   183 

   184     return ($h,

   185             map { ($a = $_) =~ s/\s*$//; $a }

   186                 ":unix_from:" => split(/^(\S+):\s*/m, $_));

   187 }

   188 __END__

   189 # vim:ts=4 et: