--- a/mimecut.pl Mon Sep 03 12:57:43 2007 +0000
+++ b/mimecut.pl Mon Sep 03 14:55:32 2007 +0000
@@ -1,5 +1,5 @@
-#!/usr/bin/perl
-#$Id$
+#! /usr/bin/perl
+# $Id$
use strict;
use warnings;
@@ -9,6 +9,11 @@
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 = $$;
@@ -64,22 +69,19 @@
my $conf_mimes = "$CONFDIR/mimes.conf";
my $conf_vips = "$CONFDIR/vips.conf";
-my $vips;
-my $mimes;
+my @vips;
+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_multipart($$);
-sub check_part($$$);
+sub check_vip($%);
+sub check_multipart($$$$);
+sub check_part($$$$$);
sub replace_part($$$);
MAIN: {
@@ -102,8 +104,6 @@
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;
@@ -112,30 +112,30 @@
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;
- $vips = read_conf($conf_vips);
+ @mimes = read_conf($conf_mimes) unless $opt_text;
+ @vips = read_conf($conf_vips);
if ($opt_mimes) {
- $mimes =~ s/\|/\n/g;
- print "$mimes\n";
- exit 0 unless $opt_vips;
+ local $" = ", ";
+ print "mimes: @mimes\n";
+ exit 0;
}
if ($opt_vips) {
- $vips =~ s/\|/\n/g;
- print "$vips\n";
+ local $" = ", ";
+ print "vips: @vips\n";
exit 0;
}
@@ -143,47 +143,55 @@
###
- my $mail = new_parser();
- my %data = get_mail_data($mail);
+ my $parser = new MIME::Parser;
+ $parser->output_to_core(1); # FIXME: was ist bei sehr großen Mails?
- print $out_err "\n$ME\[$MEPID\]: " . scalar localtime() . "\n";
- print $out_err "<< " . $data{from} . "\n>> " . $data{to} . "\n";
+ 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) {
- 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";
- new_mail_send($mail);
- 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 ($data{mtype} =~ /multipart/) {
+ 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";
- printf $out_err "| %-30s | %-6s | %-34s |\n", "part [subparts]",
+ warn ",$hl1.$hl2.$hl3.\n";
+ 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);
- $mail_new = check_multipart($mail, $mail_new);
+ my $mail_new = new_mail(%header);
+ $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;
}
@@ -198,110 +206,104 @@
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 $re;
-}
-sub new_parser() {
- my $parser = new MIME::Parser;
- $parser->output_to_core(1);
- return $parser->parse(\*STDIN);
+ return map { chomp; $_ } grep !/(?:^\s*#|^\s*$)/, <$fh>;
}
-sub get_mail_data($) {
- my $mail = shift @_;
+sub get_mail_header($) {
+ my $mail = shift;
- my $mt = $mail->mime_type;
- my $pr = $mail->preamble || '';
- my $ep = $mail->epilogue || '';
- my $da = $mail->head->get('Date') || '';
- my $su = $mail->head->get('Subject') || '';
- my $fr = $mail->head->get('From') || '';
- my $to = $mail->head->get('To') || '';
- my $cc = $mail->head->get('CC') || '';
- my $bc = $mail->head->get('BCC') || '';
+ my %data;
- chomp($mt, $pr, $ep, $da, $su, $fr, $to, $cc, $bc);
+ $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') || '';
- my %data = (mtype => $mt,
- preamble => $pr,
- epilogue => $ep,
- date => $da,
- subject => $su,
- from => $fr,
- to => $to,
- cc => $cc,
- bcc => $bc,
- );
+ map { chomp } values %data;
return (%data);
}
sub new_mail(%) {
my %data = @_;
- my $mail_new = MIME::Entity->build(Type => $data{mtype},
- Date => $data{date},
- From => $data{from},
- To => $data{to},
- CC => $data{cc},
- BCC => $data{bcc},
- Subject => $data{subject},
- );
- return $mail_new;
+ 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 $out_std "From $ME " . scalar localtime() . "\n";
+ print "From $ME " . scalar localtime() . "\n";
$mail->print;
}
}
-sub check_multipart($$) {
- my ($multipart, $mail_new) = @_;
- my $parts_count = $multipart->parts;
+sub check_multipart($$$$) {
+ my ($mimes, $old, $new, $level) = @_;
+ my $parts_count = $old->parts;
- printf $out_err "| %-30s | %-6s | %-34s |\n",
- "" . $prefix . $multipart->mime_type . " [$parts_count]", '', '';
- $prefix = $prefix . " ";
+ warn sprintf "| %-30s | %-6s | %-34s |\n",
+ " " x $level . $old->mime_type . " [$parts_count]", "", "";
- my @parts = $multipart->parts;
+ my @parts = $old->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);
+ }
+ else {
+ check_part($mimes, $part, $mtype, $new, $level);
+ }
}
- return $mail_new;
+
+ return $new;
}
-sub check_vip(%) {
- if ($vips) {
- my %data = @_;
- return "VIP FROM" if $data{from} =~ /<(?:$vips)>/i;
- return "VIP RCPT" if $data{to} =~ /<(?:$vips)>/i;
- return "VIP CC" if $data{cc} =~ /<(?:$vips)>/i;
- return "VIP BCC" if $data{bcc} =~ /<(?:$vips)>/i;
+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;
}
+
+ return @matched if wantarray;
+ return join ", ", @matched;
}
-sub check_part($$$) {
- my ($part, $mtype, $mail_new) = @_;
+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) {
- if ($mtype =~ m[(?:$mimes)]) { $status = 'kept' }
+ elsif ($re) {
+ if ($mtype =~ /$re/) { $status = 'kept' }
}
if ($status eq 'kept') {
@@ -309,8 +311,10 @@
}
elsif ($status eq 'cut') { replace_part($part, $filename, $mail_new) }
- printf $out_err "| %-30s | %-6s | %34.34s |\n", "$prefix$mtype",
- "$status", "$filename";
+ warn sprintf "| %-30s | %-6s | %34.34s |\n",
+ " " x ($level+1) . $mtype,
+ $status,
+ $filename;
}
sub replace_part($$$) {