diff -r 9482d3366306 -r 0e1c0994309a mimecut.pl
--- a/mimecut.pl	Fri Sep 07 15:25:39 2007 +0000
+++ b/mimecut.pl	Fri Sep 07 15:30:08 2007 +0000
@@ -1,434 +1,169 @@
 #! /usr/bin/perl
 # $Id$
+# $URL$
+#
+# ** Just proof of concept ** to see if we really need to decode all the
+# mime parts.
+#
 
 use strict;
 use warnings;
-use MIME::Parser;
-use MIME::Entity;
-use MIME::Head;
-use Getopt::Long;
-use File::Basename;
+
+use Fatal qw(:void select);
+use File::Temp qw(tempfile);
+use if $ENV{DEBUG} => "Smart::Comments";
 use FindBin qw($Bin);
-use if $ENV{DEBUG} => "Smart::Comments", $ENV{DEBUG};
-
-BEGIN {
-    delete @ENV{ "LANG", grep /^LC_/, keys %ENV };
-}
-
-my $ME      = basename $0;
-my $MEPID   = $$;
-my $CONFDIR = -f "$Bin/.build" ? $Bin : "/etc/$0";
-my $LOGDIR  = '.';
-my $HELP    = <<EOF;
-Usage:
-    $ME [options] < mail
-    $ME [actions]
-
-Options:
-    -d, --debug
-        Output detailed information how the mail and its parts is parsed using
-        STDERR for output.
-
-    -l, --logfile
-        Writes the debug information to mimcut.log file instead of printing to
-        STDERR.
-
-    -t, --text
-        With this mode only plain/text mimes will pass the cut.
 
-    -f, --fake
-        Do not output anything to STDOUT. (This enables debugging but can't be
-        used with log and/or strain mode!)
-
-    -s, --strain
-        Will output the mail instantly and unchanged to STDOUT.
-
-Actions:
-    -m, --mimes
-        List each mime which is to be kept from mimes.conf.
-
-    -v, --vips
-        List allowed senders/RCPT's/CC's/BCC's who will get unchanged mail.
-
-    -p, --pod
-        In detail information about the way this script works.
+sub print_message(*@);
+sub read_message();
+sub pass_mime($$);
+sub forward_to_boundary($*);
+sub read_header(*);
 
-    -h, --help
-        Show this help screen and exit.
-EOF
-
-my $opt_debug;
-my $opt_log;
-my $opt_text;
-my $opt_fake;
-my $opt_strain;
-my $opt_mimes;
-my $opt_vips;
-my $opt_help;
-my $opt_pod;
-
-my $conf_mimes = "$CONFDIR/mimes.conf";
-my $conf_vips  = "$CONFDIR/vips.conf";
-my @vips;
+#
+sub process($*;@);
+my $confdir = -f "$Bin/.build" ? $Bin : "/etc/$0";
 my @mimes;
 
-my $logfile;
-
-sub read_conf($);
-sub new_parser();
-sub get_mail_header($);
-sub new_mail(%);
-sub new_mail_send($);
-sub check_vip($%);
-sub check_multipart($$$$);
-sub check_part($$$$$);
-sub replace_part($$$);
+$SIG{__WARN__} = sub { print STDERR "### ", @_ };
 
 MAIN: {
-    Getopt::Long::Configure("bundling");
-    GetOptions("d|debug"  => \$opt_debug,
-               "l|log"    => \$opt_log,
-               "t|text"   => \$opt_text,
-               "s|strain" => \$opt_strain,
-               "f|fake"   => \$opt_fake,
-               "m|mimes"  => \$opt_mimes,
-               "v|vips"   => \$opt_vips,
-               "h|help"   => \$opt_help,
-               "p|pod"    => \$opt_pod,
-    ) or die "$ME: try\n  $ME --help\n";
 
-    if ($opt_help) {
-        print $HELP and exit 0;
-    }
-    if ($opt_pod) {
-        system("pod2usage -v 3 $0") and exit 0;
-    }
+	open ( my $fh, "< $confdir/mimes.conf")
+		or warn "can't read config!\n";
+	my @mimes = map { chomp; $_ } grep !/(?:^\s*#|^\s*$)/, <$fh>;
+	
+    # create an r/o tmp file containing the message  for sequential
+    # processing and optional failback in face of some processing error
+    my $message = read_message();
+
+    # during processing everything is printed into some tmp file
+    # - this way we can abort processing at any time and just send
+    # the above temporary file down the river
+    my $tmpout = tempfile();
+    my $stdout = select $tmpout;
 
-    if ($opt_fake) { $opt_debug = 1 }
-    if ($opt_log) {
-        die "$ME: can't fake in log mode!\n"  if $opt_fake;
-        die "$ME: can't debug in log mode!\n" if $opt_debug;
-        open(STDERR, ">> $LOGDIR/$ME.log")
-            or die "$ME: can't open logfile!\n";
-        $opt_debug = 1;
-    }
-    elsif (!$opt_debug) { open(STDERR, ">/dev/null") }
+    # now we start processing but at the beginning - of course
+    seek($message, 0, 0);
+    process(\@mimes, $message, boundary => undef);
 
-    if ($opt_strain) {
-        if ($opt_fake) {
-            warn "$ME: can't fake in strain mode!\n";
-            exit 0;
+    # everything is done, probably some rest is still unprocessed (some
+    # epilogue, but this shouldn't be a problem at all
+    {
+        local $/ = \10240;
+        if ($tmpout) {
+            seek($tmpout, 0, 0);
+            select $stdout;
+            print while <$tmpout>;
         }
-        if ($opt_text) {
-            warn "$ME: can't use text-only in strain mode!\n";
-            exit 0;
-        }
-    }
-
-    @mimes = read_conf($conf_mimes) unless $opt_text;
-    @vips = read_conf($conf_vips);
-
-    if ($opt_mimes) {
-        local $" = ", ";
-        print "mimes: @mimes\n";
-        exit 0;
-    }
-    if ($opt_vips) {
-        local $" = ", ";
-        print "vips: @vips\n";
-        exit 0;
+        print while <$message>;
     }
 
-    die "$ME: no mail on stdin!\n$!" if (-z *STDIN);
-
-    ###
-
-    my $parser = new MIME::Parser;
-    $parser->output_to_core(1);    # FIXME: was ist bei sehr großen Mails?
-
-    my $mail   = $parser->parse(\*STDIN);
-    my %header = get_mail_header($mail);
-
-    warn "\n$ME\[$MEPID\]: @{[scalar localtime]}\n"
-        . "<<$header{from}\n"
-        . ">>$header{to}\n";
-
-    if ($opt_strain) {
-        warn "   STRAIN MODE\n";
-        new_mail_send($mail);
-        exit 0;
-    }
+    exit 0;
+}
 
-    {
-        #### checking vips: \@vips
-        my $result;
-        if (@vips and $result = check_vip(\@vips, %header)) {
-            warn "   $result\n";
-            new_mail_send($mail);
-            exit 0;
-        }
-    }
-
-    if ($header{mtype} =~ /multipart/) {
-
-        my $hl1 = '-' x 32;
-        my $hl2 = '-' x 8;
-        my $hl3 = '-' x 36;
-        my $hl  = '-' x 78;
+sub print_message(*@) {
+    my ($m, %arg) = @_;
 
-        warn ",$hl1.$hl2.$hl3.\n";
-        warn sprintf "| %-30s | %-6s | %-34s |\n", "part [subparts]",
-            "status", "filename";
-        warn "+$hl1+$hl2+$hl3+\n";
-
-        my $mail_new = new_mail(%header);
-        $mail_new = check_multipart(\@mimes, $mail, $mail_new, 0);
-
-        warn "`$hl1'$hl2'$hl3'\n";
-        new_mail_send($mail_new);
-        exit 0;
-
-    }
-    else {
-
-        warn "** SINGLEPART\n";
-        new_mail_send($mail);
-        exit 0;
+    while (<$m>) {
+        print;
+        last if $arg{to} and /^--\Q$arg{to}\E/;
     }
 }
 
-###
-
-sub read_conf($) {
-    my $conf = shift @_;
-
-    die "$ME: can't find $conf!\n" if (!-e $conf);
-
-    my $fh;
-    open($fh, "< $conf") or die "$ME: can't read $conf!\n";
-
-    return map { chomp; $_ } grep !/(?:^\s*#|^\s*$)/, <$fh>;
-}
-
-sub get_mail_header($) {
-    my $mail = shift;
-
-    my %data;
-
-    $data{mtype}    = $mail->mime_type;
-    $data{preamble} = $mail->preamble || '';
-    $data{epilogue} = $mail->epilogue || '';
-    $data{date}     = $mail->head->get('Date') || '';
-    $data{subject}  = $mail->head->get('Subject') || '';
-    $data{from}     = $mail->head->get('From') || '';
-    $data{to}       = $mail->head->get('To') || '';
-    $data{cc}       = $mail->head->get('CC') || '';
-    $data{bcc}      = $mail->head->get('BCC') || '';
-
-    map { chomp } values %data;
-
-    return (%data);
-}
+sub process($*;@) {
+    my ($mimes, $m, %arg)    = @_;
+    my ($header, %header) = read_header($m);
+    my ($type, $boundary);
 
-sub new_mail(%) {
-    my %data = @_;
-    return
-        MIME::Entity->build(Type    => $data{mtype},
-                            Date    => $data{date},
-                            From    => $data{from},
-                            To      => $data{to},
-                            CC      => $data{cc},
-                            BCC     => $data{bcc},
-                            Subject => $data{subject},
-        );
-}
-
-sub new_mail_send($) {
-    my $mail = shift @_;
-    if (!$opt_fake) {
-        print "From $ME " . scalar localtime() . "\n";
-        $mail->print;
-    }
-}
-
-sub check_multipart($$$$) {
-    my ($mimes, $old, $new, $level) = @_;
-    my $parts_count = $old->parts;
-
-    warn sprintf "| %-30s | %-6s | %-34s |\n",
-        " " x $level . $old->mime_type . " [$parts_count]", "", "";
-
-    my @parts = $old->parts;
-    foreach my $part (@parts) {
-        my $mtype = $part->mime_type;
-
-		if ($mtype =~ /multipart/) {
-				$new = check_multipart($mimes, $part, $new, $level + 1);
-		}
-		else {
-				check_part($mimes, $part, $mtype, $new, $level);
-		}
+    if ($header{"content-type"}) {
+        ($type) = ($header{"content-type"} =~ /^([^;]*)/);
+        (undef, $boundary)
+            = ($header{"content-type"} =~ /boundary=(['"])(.*?)\1/);
+        ### h{content-type}:  $header{"content-type"}
+        ### type:	      $type
+        ### bound:            $boundary
     }
 
-    return $new;
-}
+    $boundary ||= $arg{boundary};
 
-sub check_vip($%) {
-    my ($vips, %data) = @_;
-    my $re = join "|", map { $a = $_; $a =~ s/([^\da-z])/\\$1/gi; $a } @$vips;
-    my @matched;
-
-    foreach (qw(from to cc bcc)) {
-        push @matched, "VIP $_" if $data{$_} =~ /$re/o;
+    if (not $type or pass_mime($type, $mimes)) {
+        #warn "passing: " . ($type ? $type : "no mime type") . "\n";
+        print $header;
+        print_message($m, to => $boundary);
+        return;
     }
 
-    return @matched if wantarray;
-    return join ", ", @matched;
-}
-
-sub check_part($$$$$) {
-    my ($mimes, $part, $mtype, $mail_new, $level) = @_;
-    my $status = 'cut';
-
-    my $re = join "|", map { $a = $_; $a =~ s/([^\da-z])/\\$1/gi; $a } @$mimes;
+    if ($type =~ m{^multipart/}) {
+        #warn "forward to next multipart boundary: $boundary\n";
+        print $header;
+        print_message($m, to => $boundary);
 
-    my $disposition = ($part->get('Content-Disposition') =~ /filename="(.+)"/)
-        and my $filename = $1
-        if $part->get('Content-Disposition');
-
-    $filename = 'n/a' unless $filename;
+        while (not eof($m)) {
+            process($mimes, $m, boundary => $boundary);
+        }
 
-    if ($opt_text) {
-        if   ($mtype =~ m[text/plain]) { $status = 'kept' }
-        else                           { $status = 'cut' }
-    }
-    elsif ($re) {
-        if ($mtype =~ /$re/) { $status = 'kept' }
+	return;
     }
 
-    if ($status eq 'kept') {
-        $mail_new->add_part($part);
-    }
-    elsif ($status eq 'cut') { replace_part($part, $filename, $mail_new) }
+    #warn "removed: $type\n";
+
+    my ($eol) = ($header =~ /(\s*)$/);
+    $header =~ s/\s*$//;
+    $header =~ s/^/-- /gm;
 
-    warn sprintf "| %-30s | %-6s | %34.34s |\n", 
-		" " x ($level+1) . $mtype, 
-		$status,
-        $filename;
+    print "Content-Type: text/plain" . $eol x 2
+	. "Content removed (" . localtime() . ")$eol"
+	. $header
+	. $eol;
+
+    while (<$m>) {
+	if (/^--\Q$boundary\E/) {
+	    print;
+	    last;
+	}
+    }
+
 }
 
-sub replace_part($$$) {
-
-    # TODO	part ersetzen ohne boundary zu verlieren
-    # 		kurze info zu mime/filetype oder so
+sub pass_mime($$) {
+	my ($type, $mimes) = @_;
+    local $_ = $type;
+	my $re = join "|", map { $a = $_; $a =~ s/([^\da-z])/\\$1/gi; $a } @$mimes;
+	return m{$re};
 }
 
-=pod
-
-=head1 NAME
-
-mimecut -- entfernt oder ersetzt AnhE<auml>nge anhand MIME's
-
-=head1 SYNOPSIS
-
-=over
-
-=item B<mimecut> [OPTION] < Mail
+sub read_message() {
+    my $tmp = tempfile();
 
-=item B<mimecut> [ACTION]
-
-=back
-
-=head1 DESCRIPTION
-
-Eine e-Mail, die E<uuml>ber STDIN an mimecut E<uuml>bergeben wird, wird auf
-Ihre Struktur untersucht. Ist sie keine multipart e-Mail erfolgt die Ausgabe
-sofort und ungeE<auml>ndert E<uuml>ber STDOUT.
-
-Ist die e-Mail multipart, werden die einzelnen parts, gegebenenfalls rekursiv
-durchlaufen und auf ihre mime-types hin analysiert. 
-mimecut benE<ouml>tigt zwei Konfigurationsdateien:
+    local $/ = \102400;
+    print {$tmp} $_ while <>;
+    chmod 0400, $tmp or die "Can't fchmod on tmpfile: $!\n";
 
-=over
-
-=item B<mimes.conf>
-
-Hier sind die mime-types erfasst, welche in der e-Mail enthalten bleiben sollen.
-
-=item B<vips.conf>
-
-Die Liste der EmpfE<auml>nger/Sender/CC's/BCC's, welche ungekE<uuml>rzte e-Mails bekommen.
-
-=back
+    return $tmp;
+}
 
-Anhand der Konfiguration wird zunE<auml>chst der e-Mail header
-E<uuml>berprE<uuml>ft und falls keine VIP e-Mail vorliegt, werden die parts
-mit den zu entfernenden mimes abgetrennt.
-
-=head1 OPTIONS
-
-=over
-
-=item B<-d, --debug>
-
-Gibt einen Statusbericht auf STDERR aus.
-
-=item B<-l, --logfile>
-
-Schreibt das debug in oder hE<auml>ngt es an die Datei mimecut.log im Pfad von mimecut an.
+# in:	current message file handle
+# out:	($orignal_header, %parsed_header)
+sub read_header(*) {
+    my ($msg) = @_;
+    my $h = "";
 
-=item B<-t, --text>
-
-Entfernt alle AnhE<auml>nge mit einem anderen mimetype als plain/text.
-
-=item B<-f, --fake>
-
-Testet was passieren wE<uuml>rde, ohne jedoch eine e-Mail E<uuml>ber STDOUT auszugeben.
-(aktiviert automatisch B<-d>)
-
-=item B<-s, --strain>
-
-Gibt die e-Mail, ganz gleich VIP oder nicht, sofort und unverE<auml>ndert E<uuml>ber
-STDOUT aus
+    while (<$msg>) {
+        $h .= $_;
+        last if /^\s*$/m;
+    }
 
-=back
-
-=head1 ACTIONS
-
-=over
+    $_ = $h;    # unmodified header (excl. $from)
 
-=item B<-m, --mimes>
-
-Ausgabe der aus der mimes.conf eingelesenen MIME's.
-
-=item B<-v, --vips>
-
-Ausgabe der aus der vips.conf eingelesenen VIP-Adressen.
+    ### $_
 
-=back
-
-=head1 OTHER
-
-=over
-
-=item B<-h, --help>
-
-Kurze Hilfe mit SYNOPSIS, OPTIONS & ACTIONS.
-
-=item B<-p, --pod>
-
-Diese Dokumentation.
+    s/\r?\n\s+(?=\S)/ /gm;    # continuation lines
+    s/^(\S+):/\L$1:/gm;       # header fields to lower case
 
-=back
-
-=head1 FILES
-
-=over
-
-=item B<mimes.conf>, B<vips.conf>, B<mimecut.log>
-
-=back
-
-=cut
-
-# vim:ft=perl:tw=78:ts=4
+    return ($h,
+            map { ($a = $_) =~ s/\s*$//; $a }
+                ":unix_from:" => split(/^(\S+):\s*/m, $_));
+}
+__END__
+# vim:ts=4