X-Git-Url: http://git.jankratochvil.net/?p=PerlMail.git;a=blobdiff_plain;f=My-Audit.pm;h=4bcb2edc4815196f46d3c8ca92febe017fdcfc0a;hp=79ee8a13d06af028f4316ee21096871bb8e84076;hb=7161a361d1db1f9779809d8160de34f87ec80c7a;hpb=cd909d3187bdc3c87311b4ed8a9733596cb5e54a diff --git a/My-Audit.pm b/My-Audit.pm index 79ee8a1..4bcb2ed 100644 --- a/My-Audit.pm +++ b/My-Audit.pm @@ -19,6 +19,11 @@ sub audit_init { "SqueezeControl"=>"max" ,"SQZ_OPTIMIZE_LEVEL"=>0 }, { "SqueezeControl"=>"max" ,"SQZ_OPTIMIZE_LEVEL"=>1 }, ); + @alternates_host=( + "jabberwock.ucw.cz", # short@ucw.cz + "atrey.karlin.mff.cuni.cz", # short@atrey.karlin.mff.cuni.cz + "k332.feld.cvut.cz", # short@k332.feld.cvut.cz + ); } sub audit @@ -34,16 +39,6 @@ sub audit || headerhas "From",'' ); - # spam detection - return if did sub { - local $store_profile="silent"; - local $_; - store "=spam-rbl" .";$_" if $_=$Audit->rblcheck(); - store "=spam-razor".($_ eq 1 ? "" : ";$_") if $_=razor2(); - # I don't send viruses but viruses propagate mails of mine - store "=spam-av" if headeris "X-Mailer",'ravmd/8.3.2'; - }; - # spam honeypots return if did sub { local $_; @@ -53,6 +48,9 @@ sub audit store "=spamo" if headeris "From",''; store "=spamo" if headeris "From",''; store "=spamo" if headeris "From",''; + store "=spamo" if headeris "From",''; + store "=spamo" if headeris "From",''; + store "=spamo" if headeris "From",''; { # weak detection: files with text/html w/o text/plain are usually a spam my @types_linear=map({ mime_type($_); } parts_linear()); @@ -61,18 +59,36 @@ sub audit store "=spamo-big5" if ($_=mimehead(body_first())->mime_attr("Content-Type.charset")) && /^big5/i; }; + # spam detection + return if did sub { + local $store_profile="silent"; + local $_; + store "=spam-razor".($_ eq 1 ? "" : ";$_") if $_=razor2(); + }; + return if did sub { + local $store_profile="silent"; + local $_; + store "=spam-orbs" .";$_","log" if $_=dnsbl '.relays.ordb.org.' ,1; # all hosts + store "=spam-abuse" .";$_","log" if $_=dnsbl '.blackholes.mail-abuse.org.' ,1; # all hosts + # we don't check all hosts as they can be "dialup" category, FIXME: check for it + store "=spam-five" .";$_","log" if $_=dnsbl '.blackholes.five-ten-sg.com.',0; # just first + # I don't send viruses but viruses propagate mails of mine + store "=spam-av" if headeris "X-Mailer",'ravmd/8.3.2'; + }; + # special delivery store "=err","bell" and return if headerhas \&Received_for,''; # ppl-wished foreign remapping, Reply-To is left untouched! header_remap("From",{ - 'kerere@post.cz' =>'kamzik@k332.feld.cvut.cz', - 'profes@mbox.vol.cz' =>'kratochvilova@egp.cz', - 'jkrouzek@mbox.vol.cz' =>'krouzek@mbox.fsv.cuni.cz', - 'jakub.gorner@lidovky.cz' =>'tonda@disnet.cz', - 'jan.kolar@videoprogress.cz'=>'jenda.kolar@volny.cz', - 'daniel.rulicek@cponline.cz'=>'daniel.rulicek@cpress.cz', - 'pavel@suse.cz' =>'pavel@ucw.cz', + 'kerere@post.cz' =>'kamzik@k332.feld.cvut.cz', + 'profes@mbox.vol.cz' =>'kratochvilova@egp.cz', + 'jkrouzek@mbox.vol.cz' =>'krouzek@mbox.fsv.cuni.cz', + 'jakub.gorner@lidovky.cz' =>'tonda@disnet.cz', + 'jan.kolar@videoprogress.cz' =>'jenda.kolar@volny.cz', + 'daniel.rulicek@cponline.cz' =>'daniel.rulicek@cpress.cz', + 'pavel@suse.cz' =>'pavel@ucw.cz', + }); # My obsolete e-mail addresses @@ -80,7 +96,7 @@ sub audit # nasty public lists with $store_ignore { - local $store_profile="bell"; + local $store_profile="log"; local $store_ignore; $store_ignore="smsmail" if 1==$Audit->body() && length(join "",$Audit->body())<180; # SMS mail $store_ignore="sms OS" if $Audit->subject()=~/^Email pro: /; # "^Email pro: gsm@sh\.cvut\.cz$"; @@ -102,23 +118,25 @@ sub audit # lists store "=mozillabug","log" if headeris "From" ,''; - store "=9kc","bell" if headeris "List-Post",''; - store "=9kcd","bell" if headeris "List-Post",''; + store "=9kc","log" if headeris "List-Post",''; + store "=9kcd","log" if headeris "List-Post",''; store "=9ku","log" if headeris "List-Id" ,'<9000.listman.net>'; store "=9kd","log" if headeris "Sender" ,''; store "=spong","log" if headeris "List-Id" ,''; - store "=gtkd","log" if headeris "List-Id" ,''; + store "=gtkd","silent" if headeris "List-Id" ,''; + store "=gnomevfs","log" if headeris "List-Id" ,''; store "=mffstatnice","bell" if headeris "List-Post",''; store "=hw","log" if headeris "List-Post",''; store "=gnokii","log" if headeris "List-Id" ,''; store "=winelic","log" if headeris "List-Id" ,''; - store "=wined","log" if headeris "List-Id" ,''; + store "=wined","silent" if headeris "List-Id" ,''; store "=winepat","silent" if headeris "List-Id" ,''; store "=winecvs","silent" if headeris "List-Id" ,''; store "=wineann","log" if headeris "List-Id" ,''; store "=ros","log" if headeris "List-Post",''; store "=roskernel","log" if headeris "List-Post",''; store "=roscvs","silent" if headeris "List-Post",''; + store "=rosbug","log" if headeris "Reply-To" ,''; store "=fsd","log" if headeris "X-Mailing-List",''; store "=surprise","sms" if headeris "List-Post",''; store "=surprisesuse","sms" if headeris "Sender" ,''; @@ -136,8 +154,11 @@ sub audit store "=4c","sms" if headeris "List-Post",'<4cinfo@atrey.karlin.mff.cuni.cz>'; store "=slashdot","bell" if headeris "From" ,''; store "=freshmeat","bell" if headeris "From" ,''; + store "=sourceforge","bell" if headeris "From" ,''; store "=gsmperlcvs","silent" if headeris("From" ,'') && $Audit->subject()=~/^'.*' has been updated!$/; + store "=libtoold","log" if headeris "List-Id" ,''; + store "=libtoolpat","log" if headeris "List-Id" ,''; # own webs store "=energie","bell" if headeris "From" ,qr/^EnergieWeb/; @@ -149,29 +170,60 @@ sub audit store "==","sms" if !did; } +sub audit_sms_address +{ +my($obj)=@_; + + my $address=$obj->address(); + if (my $alternates=muttrc_get("alternates")) { + return "I" if $address=~/$alternates/si; + } + my %aliases=muttrc_aliases(); + if (my $alias=$aliases{lc $address}) { + local $_=$alias; + s/\b(Bus)siness$/$1/i; + s/\.ident$//i; + return $_; + } + local $_=$address; + s/\.cz$//i; + return $_; +} + sub audit_sms { my(%args)=@_; - my $from=(@{$args{"from"}} ? join(",",map({ - s/\.cz$//i; - $_; - } @{$args{"from"}})) : "?"); - local $_=$args{"body"}; - + my $from=(@{$args{"from"}} ? join(",",map({ audit_sms_address($_); } @{$args{"from"}})) : "?"); + local $_; + + $_=$args{"subject"}; + # headers + s/(?:Re|Aw|Odp|Fw|Fwd|OT)(?:\[\d+\])?://ig; + # former subject + s/\bbylo:.*$//i; + s/\[\s*WAS:.*\]\s*$//i; + # trim + s/^\s*//s; + s/\s*$//s; + my $subject=$_; + + $_=$args{"body"}; # max. 9 lines of .sig s/\n-- (?:\n[^\n]*){0,9}$//gs; # "Original Message"/"Puvodni zprava" etc. up to empty line - s/(^|\n)[\s^\n]*-----[\w\s]*-----[\s^\n]*(?:\n[^\n]+)*\n{2,}(?:\s*[^>\s].*$)?/\n/gs; + # "- - - Original message: - - -" is by "Lotus Notes Release 5.0.5 September 22, 2000" + s/(^|\n)[\s^\n]*(?:-----[\w\s]*-----|- - - Original message: - - -)[\s^\n]*(?:\n[^\n]+)*\n{2,}(?:\s*[^>\s].*$)?/\n/gs; # Remove "..." lines (is it used by anyone except me?) s/^\Q...\E$/*/gm; # quoting "> " - s/^\s*[>][>\s]*.*$/*/gm; + s/^(?:\s*[[:upper:]]{0,3}>)+.*$/*/gm; s/(?:^|\n)(?:\*\n+)+/\n*\n/gs; # attributions - s/^.*\b(?:wrote|writes):\s*$//gm; + s/^.*\b(?:wrote|writes|napsal jste):\s*$//gm; + my $body=$_; - return [$from,"(".$args{"subject"}.")".$_]; + return [$from,"($subject)$body"]; } 1;