ius/mimecut: comparison mimecut.pl

equal deleted inserted replaced

-:c43594b89549
+:b58ecd25d1f1
-#!/usr/bin/perl
+#! /usr/bin/perl
-#$Id$
+# $Id$
 use strict;
 use warnings;
 use MIME::Parser;
 use MIME::Entity;
 use MIME::Head;
 use Getopt::Long;
 use File::Basename;
 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 $opt_help;
 my $opt_pod;
 my $conf_mimes = "$CONFDIR/mimes.conf";
 my $conf_vips  = "$CONFDIR/vips.conf";
-my $vips;
+my @vips;
-my $mimes;
+my @mimes;
-my $out_err;
-my $out_std;
 my $logfile;
-my $prefix = '';
 sub read_conf($);
 sub new_parser();
-sub get_mail_data($);
+sub get_mail_header($);
 sub new_mail(%);
 sub new_mail_send($);
-sub check_vip(%);
+sub check_vip($%);
-sub check_multipart($$);
+sub check_multipart($$$$);
-sub check_part($$$);
+sub check_part($$$$$);
 sub replace_part($$$);
 MAIN: {
 Getopt::Long::Configure("bundling");
 GetOptions("d|debug"  => \$opt_debug,
 }
 if ($opt_pod) {
 system("pod2usage -v 3 $0") and exit 0;
 }
-$out_std = *STDOUT;
 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") }
+elsif (!$opt_debug) { open(STDERR, ">/dev/null") }
 if ($opt_strain) {
 if ($opt_fake) {
-print $out_err "$ME: can't fake in strain mode!\n";
+warn "$ME: can't fake in strain mode!\n";
 exit 0;
 }
 if ($opt_text) {
-print $out_err "$ME: can't use text-only in strain mode!\n";
+warn "$ME: can't use text-only in strain mode!\n";
 exit 0;
 }
 }
-$mimes = read_conf($conf_mimes) unless $opt_text;
+@mimes = read_conf($conf_mimes) unless $opt_text;
-$vips = read_conf($conf_vips);
+@vips = read_conf($conf_vips);
 if ($opt_mimes) {
-$mimes =~ s/\|/\n/g;
+local $" = ", ";
-print "$mimes\n";
+print "mimes: @mimes\n";
-exit 0 unless $opt_vips;
+exit 0;
 }
 if ($opt_vips) {
-$vips =~ s/\|/\n/g;
+local $" = ", ";
-print "$vips\n";
+print "vips: @vips\n";
 exit 0;
 }
 die "$ME: no mail on stdin!\n$!" if (-z *STDIN);
 ###
-my $mail = new_parser();
+my $parser = new MIME::Parser;
-my %data = get_mail_data($mail);
+$parser->output_to_core(1);    # FIXME: was ist bei sehr großen Mails?
-print $out_err "\n$ME\[$MEPID\]: " . scalar localtime() . "\n";
+my $mail   = $parser->parse(\*STDIN);
-print $out_err "<< " . $data{from} . "\n>> " . $data{to} . "\n";
+my %header = get_mail_header($mail);
+warn "\n$ME\[$MEPID\]: @{[scalar localtime]}\n"
+. "<<$header{from}\n"
+. ">>$header{to}\n";
 if ($opt_strain) {
-print $out_err "   STRAIN MODE\n";
+warn "   STRAIN MODE\n";
 new_mail_send($mail);
 exit 0;
 }
-if (my $result = check_vip(%data)) {
+{
-print $out_err "   $result\n";
+#### checking vips: \@vips
-new_mail_send($mail);
+my $result;
-exit 0;
+if (@vips and $result = check_vip(\@vips, %header)) {
-}
+warn "   $result\n";
+new_mail_send($mail);
-if ($data{mtype} =~ /multipart/) {
+exit 0;
+}
+}
+if ($header{mtype} =~ /multipart/) {
 my $hl1 = '-' x 32;
 my $hl2 = '-' x 8;
 my $hl3 = '-' x 36;
 my $hl  = '-' x 78;
-print $out_err ",$hl1.$hl2.$hl3.\n";
+warn ",$hl1.$hl2.$hl3.\n";
-printf $out_err "| %-30s | %-6s | %-34s |\n", "part [subparts]",
+warn sprintf "| %-30s | %-6s | %-34s |\n", "part [subparts]",
 "status", "filename";
-print $out_err "+$hl1+$hl2+$hl3+\n";
+warn "+$hl1+$hl2+$hl3+\n";
-my $mail_new = new_mail(%data);
+my $mail_new = new_mail(%header);
-$mail_new = check_multipart($mail, $mail_new);
+$mail_new = check_multipart(\@mimes, $mail, $mail_new, 0);
-print $out_err "`$hl1'$hl2'$hl3'\n";
+warn "`$hl1'$hl2'$hl3'\n";
 new_mail_send($mail_new);
 exit 0;
 }
 else {
-print $out_err "** SINGLEPART\n";
+warn "** SINGLEPART\n";
 new_mail_send($mail);
 exit 0;
 }
 }
 die "$ME: can't find $conf!\n" if (!-e $conf);
 my $fh;
 open($fh, "< $conf") or die "$ME: can't read $conf!\n";
-my $re = join('|', my @re = grep (!/(?:^\s{0,}#|^\s{0,}$)/, <$fh>));
-$re =~ s/(?:\n|\s)//g;
+return map { chomp; $_ } grep !/(?:^\s*#|^\s*$)/, <$fh>;
-return $re;
+}
-}
+sub get_mail_header($) {
-sub new_parser() {
+my $mail = shift;
-my $parser = new MIME::Parser;
-$parser->output_to_core(1);
+my %data;
-return $parser->parse(\*STDIN);
-}
+$data{mtype}    = $mail->mime_type;
+$data{preamble} = $mail->preamble || '';
-sub get_mail_data($) {
+$data{epilogue} = $mail->epilogue || '';
-my $mail = shift @_;
+$data{date}     = $mail->head->get('Date') || '';
+$data{subject}  = $mail->head->get('Subject') || '';
-my $mt = $mail->mime_type;
+$data{from}     = $mail->head->get('From') || '';
-my $pr = $mail->preamble || '';
+$data{to}       = $mail->head->get('To') || '';
-my $ep = $mail->epilogue || '';
+$data{cc}       = $mail->head->get('CC') || '';
-my $da = $mail->head->get('Date') || '';
+$data{bcc}      = $mail->head->get('BCC') || '';
-my $su = $mail->head->get('Subject') || '';
-my $fr = $mail->head->get('From') || '';
+map { chomp } values %data;
-my $to = $mail->head->get('To') || '';
-my $cc = $mail->head->get('CC') || '';
-my $bc = $mail->head->get('BCC') || '';
-chomp($mt, $pr, $ep, $da, $su, $fr, $to, $cc, $bc);
-my %data = (mtype    => $mt,
-preamble => $pr,
-epilogue => $ep,
-date     => $da,
-subject  => $su,
-from     => $fr,
-to       => $to,
-cc       => $cc,
-bcc      => $bc,
-);
 return (%data);
 }
 sub new_mail(%) {
 my %data = @_;
-my $mail_new = MIME::Entity->build(Type    => $data{mtype},
+return
-Date    => $data{date},
+MIME::Entity->build(Type    => $data{mtype},
-From    => $data{from},
+Date    => $data{date},
-To      => $data{to},
+From    => $data{from},
-CC      => $data{cc},
+To      => $data{to},
-BCC     => $data{bcc},
+CC      => $data{cc},
-Subject => $data{subject},
+BCC     => $data{bcc},
-);
+Subject => $data{subject},
-return $mail_new;
+);
 }
 sub new_mail_send($) {
 my $mail = shift @_;
 if (!$opt_fake) {
-print $out_std "From $ME " . scalar localtime() . "\n";
+print "From $ME " . scalar localtime() . "\n";
 $mail->print;
 }
 }
-sub check_multipart($$) {
+sub check_multipart($$$$) {
-my ($multipart, $mail_new) = @_;
+my ($mimes, $old, $new, $level) = @_;
-my $parts_count = $multipart->parts;
+my $parts_count = $old->parts;
-printf $out_err "| %-30s | %-6s | %-34s |\n",
+warn sprintf "| %-30s | %-6s | %-34s |\n",
-"" . $prefix . $multipart->mime_type . " [$parts_count]", '', '';
+" " x $level . $old->mime_type . " [$parts_count]", "", "";
-$prefix = $prefix . " ";
+my @parts = $old->parts;
-my @parts = $multipart->parts;
 foreach my $part (@parts) {
 my $mtype = $part->mime_type;
-check_part($part, $mtype, $mail_new) unless $mtype =~ /^multipart/;
-$mail_new = check_multipart($part, $mail_new)
+		if ($mtype =~ /multipart/) {
-if $mtype =~ /^multipart/;
+				$new = check_multipart($mimes, $part, $new, $level + 1);
-}
+		}
-return $mail_new;
+		else {
-}
+				check_part($mimes, $part, $mtype, $new, $level);
+		}
-sub check_vip(%) {
+}
-if ($vips) {
-my %data = @_;
+return $new;
-return "VIP FROM" if $data{from} =~ /<(?:$vips)>/i;
+}
-return "VIP RCPT" if $data{to}   =~ /<(?:$vips)>/i;
-return "VIP CC"   if $data{cc}   =~ /<(?:$vips)>/i;
+sub check_vip($%) {
-return "VIP BCC"  if $data{bcc}  =~ /<(?:$vips)>/i;
+my ($vips, %data) = @_;
-}
+my $re = join "|", map { $a = $_; $a =~ s/([^\da-z])/\\$1/gi; $a } @$vips;
-}
+my @matched;
-sub check_part($$$) {
+foreach (qw(from to cc bcc)) {
-my ($part, $mtype, $mail_new) = @_;
+push @matched, "VIP $_" if $data{$_} =~ /$re/o;
+}
+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;
 my $disposition = ($part->get('Content-Disposition') =~ /filename="(.+)"/)
 and my $filename = $1
 if $part->get('Content-Disposition');
 $filename = 'n/a' unless $filename;
 if ($opt_text) {
 if   ($mtype =~ m[text/plain]) { $status = 'kept' }
 else                           { $status = 'cut' }
 }
-elsif ($mimes) {
+elsif ($re) {
-if ($mtype =~ m[(?:$mimes)]) { $status = 'kept' }
+if ($mtype =~ /$re/) { $status = 'kept' }
 }
 if ($status eq 'kept') {
 $mail_new->add_part($part);
 }
 elsif ($status eq 'cut') { replace_part($part, $filename, $mail_new) }
-printf $out_err "| %-30s | %-6s | %34.34s |\n", "$prefix$mtype",
+warn sprintf "| %-30s | %-6s | %34.34s |\n",
-"$status", "$filename";
+		" " x ($level+1) . $mtype,
+		$status,
+$filename;
 }
 sub replace_part($$$) {
 # TODO	part ersetzen ohne boundary zu verlieren

changeset 6	b58ecd25d1f1
parent 5	c43594b89549