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 #

     8 

     9 use strict;

    10 use warnings;

    11 

    12 use Fatal qw(:void select);

    13 use File::Temp qw(tempfile);

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

    15 use FindBin qw($Bin);

    16 

    17 sub print_message(*@);

    18 sub read_message();

    19 sub pass_mime($$);

    20 sub forward_to_boundary($*);

    21 sub read_header(*);

    22 

    23 #

    24 sub process($*;@);

    25 my $confdir = -f "$Bin/.build" ? $Bin : "/etc/$0";

    26 my @mimes;

    27 

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

    29 

    30 MAIN: {

    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 	

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

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

    38     my $message = read_message();

    39 

    40     # during processing everything is printed into some tmp file

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

    42     # the above temporary file down the river

    43     my $tmpout = tempfile();

    44     my $stdout = select $tmpout;

    45 

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

    47     seek($message, 0, 0);

    48     process(\@mimes, $message, boundary => undef);

    49 

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

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

    52     {

    53         local $/ = \10240;

    54         if ($tmpout) {

    55             seek($tmpout, 0, 0);

    56             select $stdout;

    57             print while <$tmpout>;

    58         }

    59         print while <$message>;

    60     }

    61 

    62     exit 0;

    63 }

    64 

    65 sub print_message(*@) {

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

    67 

    68     while (<$m>) {

    69         print;

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

    71     }

    72 }

    73 

    74 sub process($*;@) {

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

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

    77     my ($type, $boundary);

    78 

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

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

    81         (undef, $boundary)

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

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

    84         ### type:	      $type

    85         ### bound:            $boundary

    86     }

    87 

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

    89 

    90     if (not $type or pass_mime($type, $mimes)) {

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

    92         print $header;

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

    94         return;

    95     }

    96 

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

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

    99         print $header;

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

   101 

   102         while (not eof($m)) {

   103             process($mimes, $m, boundary => $boundary);

   104         }

   105 

   106 	return;

   107     }

   108 

   109     warn "removed: $type\n";

   110 

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

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

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

   114 

   115     print "Content-Type: text/plain" . $eol x 2

   116 	. "Content removed (" . localtime() . ")$eol"

   117 	. $header

   118 	. $eol;

   119 

   120     while (<$m>) {

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

   122 	    print;

   123 	    last;

   124 	}

   125     }

   126 

   127 }

   128 

   129 sub pass_mime($$) {

   130 	my ($type, $mimes) = @_;

   131     local $_ = $type;

   132 	my $re = join "|", map { $a = $_; $a =~ s/([^\da-z])/\\$1/gi; $a } @$mimes;

   133 	return m{$re};

   134 }

   135 

   136 sub read_message() {

   137     my $tmp = tempfile();

   138 

   139     local $/ = \102400;

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

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

   142 

   143     return $tmp;

   144 }

   145 

   146 # in:	current message file handle

   147 # out:	($orignal_header, %parsed_header)

   148 sub read_header(*) {

   149     my ($msg) = @_;

   150     my $h = "";

   151 

   152     while (<$msg>) {

   153         $h .= $_;

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

   155     }

   156 

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

   158 

   159     ### $_

   160 

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

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

   163 

   164     return ($h,

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

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

   167 }

   168 __END__

   169 # vim:ts=4