--- /dev/null
+# $Id$
+
+sub audit_init
+{
+ %audit_profile=(
+ "btw" =>[],
+ "silent"=>["=btw" ,"did","syslog"],
+ "log" =>["=silent","syslog"],
+ "bell" =>["=log" ,"bell"],
+ "sms" =>["=bell" ,"sms=1"],
+ "crit" =>["=sms" ,"sms=3"],
+ );
+ @sms_squeezes=(
+ { "SqueezeControl"=>"noconv" },
+ { "SqueezeControl"=>"conv" ,"SQZ_OPTIMIZE_LEVEL"=>0 },
+ { "SqueezeControl"=>"conv" ,"SQZ_OPTIMIZE_LEVEL"=>1 },
+ { "SqueezeControl"=>"med" ,"SQZ_OPTIMIZE_LEVEL"=>0 },
+ { "SqueezeControl"=>"med" ,"SQZ_OPTIMIZE_LEVEL"=>1 },
+ { "SqueezeControl"=>"max" ,"SQZ_OPTIMIZE_LEVEL"=>0 },
+ { "SqueezeControl"=>"max" ,"SQZ_OPTIMIZE_LEVEL"=>1 },
+ );
+}
+
+sub audit
+{
+ {
+ local $store_ignorenewmail=1; # no reason now, just a paranoia
+ store "=input","btw";
+ }
+
+ # TODO: <short-m@> storage?
+
+ # never spawn new mail if FROM_MAILER
+ # $isFROM_MAILER postponed after maillists as they may look as FROM_MAILER
+ #use re 'debug';
+ my $isFROM_MAILER=$Audit->header()=~/$procmailFROM_MAILER/mio;
+ $store_ignorenewmail=(0
+ || $isFROM_MAILER
+ || headerhas "From",'<Regexp:^owner->'
+ );
+
+ # 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 $_;
+ local $store_profile="silent";
+ store "=spamo-k332" if grep /^\Qshort\@k332.feld.cvut.cz\E/i,Received_for();
+ # TODO: foreign violation of RFC 822 section 4.4.4, Subject:.*Automatick.+odpov.+v.+nep.+tomnosti
+ store "=spamo" if headeris "From",'<ghandchi@hotmail.com>';
+ store "=spamo" if headeris "From",'<newsletter@levnapc.cz>';
+ store "=spamo" if headeris "From",'<Tomas@dtpstudio.cz>';
+ {
+ # weak detection: files with text/html w/o text/plain are usually a spam
+ my @types_linear=map({ mime_type($_); } parts_linear());
+ store "=spamo-html" if grep({ $_ eq "text/html"; } @types_linear) && !grep({ $_ eq "text/plain"; } @types_linear);
+ }
+ store "=spamo-big5" if ($_=mimehead(body_first())->mime_attr("Content-Type.charset")) && /^big5/i;
+ };
+
+ # special delivery
+ store "=err","bell" and return if headerhas \&Received_for,'<short+err@>';
+
+ # 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',
+ });
+
+ # My obsolete e-mail addresses
+ store_muttrc_alternates "=redirect-","btw";
+
+ # nasty public lists with $store_ignore
+ {
+ local $store_profile="bell";
+ 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$";
+ $store_ignore="list-moron" if grep { headeris "From",$_; } qw(
+ <kempny@>
+ <help.me@wo.cz>
+ <mr.death@mail.cz>
+ <danx3@centrum.cz>
+ <@mujoskar.cz>
+ <satko@quanto.nr.sanet.sk>
+ <vithous@attorney.cz> <viroman@attorney.cz>
+ <konf@klain.cz>
+ );
+
+ store "=gsm" if headeris "Sender" ,'<owner-gsm@sh.cvut.cz>';
+ store "=gsmpand" if headeris "List-Post",'<gsm@pandora.cz>';
+ }
+
+ # lists
+ store "=mozillabug","log" if headeris "From" ,'<bugzilla-daemon@mozilla.org>';
+ store "=9kc","bell" if headeris "List-Post",'<n9k@pandora.cz>';
+ store "=9kcd","bell" if headeris "List-Post",'<dev9k@pandora.cz>';
+ store "=9ku","log" if headeris "List-Id" ,'<9000.listman.net>';
+ store "=9kd","log" if headeris "Sender" ,'<owner-9000-developers@geekstuff.co.uk>';
+ store "=spong","log" if headeris "List-Id" ,'<spong-users.lists.sourceforge.net>';
+ store "=gtkd","log" if headeris "List-Id" ,'<gtk-devel-list.gnome.org>';
+ store "=mffstatnice","bell" if headeris "List-Post",'<statnice@atrey.karlin.mff.cuni.cz>';
+ store "=hw","log" if headeris "List-Post",'<hw-news@list.gin.cz>';
+ store "=gnokii","bell" if headeris "List-Id" ,'<gnokii-users.mail.freesoftware.fsf.org>';
+ store "=winelic","log" if headeris "List-Id" ,'<wine-license.winehq.com>';
+ store "=wined","log" if headeris "List-Id" ,'<wine-devel.winehq.com>';
+ store "=winepat","log" if headeris "List-Id" ,'<wine-patches.winehq.com>';
+ store "=winecvs","silent" if headeris "List-Id" ,'<wine-cvs.winehq.com>';
+ store "=ros","log" if headeris "List-Post",'<ros-general@reactos.com>';
+ store "=roskernel","bell" if headeris "List-Post",'<ros-kernel@reactos.com>';
+ store "=roscvs","silent" if headeris "List-Post",'<ros-cvs@reactos.com>';
+ store "=fsd","log" if headeris "X-Mailing-List",'<linux-fsdevel@vger.kernel.org>';
+ store "=surprise","sms" if headeris "List-Post",'<surprise@atrey.karlin.mff.cuni.cz>';
+ store "=surprisesuse","sms" if headeris "Sender" ,'<owner-surprise@suse.cz>';
+ store "=tacacs","log" if headeris "Sender" ,'<tacplus-l@disaster.com>';
+ store "=pm","sms" if headeris "Sender" ,'<owner-prague-pm@pm.org>';
+ store "=radary","sms" if headeris "Reply-To" ,'<pha@radary.cz>';
+ store "=dnet","log" if headeris "Sender" ,'<@lists.distributed.net>';
+ store "=linux-input","log" if headeris "List-Post",'<linux-input@atrey.karlin.mff.cuni.cz>';
+ store "=strom","bell" if headeris "List-Post",'<vodni-strom@atrey.karlin.mff.cuni.cz>';
+ store "=netinfo","log" if headeris "Sender" ,'<owner-netinfo-l@vol.cz>';
+ store "=saintmj","log" if headeris "From" ,'<netsaint@kam-enterprise.ms.mff.cuni.cz>';
+ store "=saintmj","log" if headeris "From" ,'<netsaint@kam.mff.cuni.cz>';
+ store "=4cerr","bell" if headeris "From" ,'<owner-4cinfo@atrey.karlin.mff.cuni.cz>';
+ store "=4c","sms" if headeris "List-Post",'<4cinfo@atrey.karlin.mff.cuni.cz>';
+ store "=slashdot","bell" if headeris "From" ,'<slashdot@slashdot.org>';
+ store "=gsmperlcvs","silent" if headeris("From" ,'<johan@intra.tektonica.com>')
+ && $Audit->subject()=~/^'.*' has been updated!$/;
+ # own webs
+ store "=energie","bell" if headeris "From" ,qr/^EnergieWeb/;
+
+ # Petr Koutecky does not mark his Stuff
+ store "=koutecky","bell" if headeris "From" ,'<velkyhroch@seznam.cz>';
+
+ store "=errm","bell" if $isFROM_MAILER && !did();
+
+ store "==","sms" if !did;
+}
+
+sub audit_sms
+{
+my(%args)=@_;
+
+ my $from=(@{$args{"from"}} ? join(",",map({
+ s/\.cz$//i;
+ $_;
+ } @{$args{"from"}})) : "?");
+ local $_=$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;
+ # Remove "..." lines (is it used by anyone except me?)
+ s/^\Q...\E$/*/gm;
+ # quoting "> "
+ s/^\s*[>][>\s]*.*$/*/gm;
+ s/(?:^|\n)(?:\*\n+)+/\n*\n/gs;
+ # attributions
+ s/^On.*\b(?:wrote|writes):\s*$//gm;
+
+ return [$from,"(".$args{"subject"}.")".$_];
+}
+
+1;
--- /dev/null
+#! /usr/bin/perl
+#
+# $Id$
+
+use vars qw($VERSION);
+$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; };
+use strict;
+use warnings;
+
+
+INIT {
+ require Sys::Syslog;
+ Sys::Syslog::openlog("lacemail","pid","mail");
+ my @syslogging_stack;
+ sub syslogging_on_save
+ {
+ push @syslogging_stack,$SIG{"__WARN__"},$SIG{"__DIE__" };
+ $SIG{"__WARN__"}=sub { Sys::Syslog::syslog("warning","WARN: %s",$_[0]); }; # disabled: print STDERR $_[0];
+ $SIG{"__DIE__" }=sub { Sys::Syslog::syslog("crit" ,"DIE: %s" ,$_[0]); };
+ }
+ syslogging_on_save();
+ sub syslogging_restore
+ {
+ $SIG{"__DIE__" }=pop @syslogging_stack;
+ $SIG{"__WARN__"}=pop @syslogging_stack;
+ }
+ }
+
+
+use Mail::Audit qw(MAPS);
+require IO::Handle;
+use Carp qw(cluck confess);
+use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG);
+require POSIX; # for ceil
+use User::Utmp;
+require File::Basename;
+use Getopt::Long;
+require Mail::Address;
+require MIME::Words;
+require Cz::Cstocs;
+require HTML::Entities;
+require MIME::Head;
+require Lingua::EN::Squeeze;
+require Mail::Mailer;
+require HTTP::Cookies;
+require HTTP::Request;
+require LWP::UserAgent;
+use URI::Escape 'uri_escape';
+
+
+my $HOME="/home/lace";
+my $Mail="$HOME/Mail";
+my @ValidUsers=qw(root lace short kratochvil _local);
+my $IdleMax=60;
+my $MaxBodySMS=0x1000; # max bytes to pass to Lingua::EN::Squeeze
+my $SMSmailError='short+err@ucw.cz';
+my $SMSwebRcpt='00420602431329';
+my $SMSmailRcpt=$SMSwebRcpt.'@sms.eurotel.cz';
+my $SMScontact='<short@ucw.cz>';
+
+our($Message,$Audit,@AuditStored,$store_ignore,$store_ignorenewmail,$store_profile,$DoBell);
+our(%audit_profile,@sms_squeezes); # imported
+
+# from RedHat "procmail-3.22-5"
+# /i should be only $procmailFROM_DAEMON but how it can hurt to /i all?
+our $procmailTO_ =qr'^((Original-)?(Resent-)?(To|Cc|Bcc)|(X-Envelope|Apparently(-Resent)?)-To):(.*[^-a-zA-Z0-9_.])?'mio;
+our $procmailTO =qr'^((Original-)?(Resent-)?(To|Cc|Bcc)|(X-Envelope|Apparently(-Resent)?)-To):(.*[^a-zA-Z])?'mio;
+our $procmailFROM_DAEMON=qr'^(Mailing-List:|Precedence:.*(junk|bulk|list)|To: Multiple recipients of |(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )([^>]*[^(.%@a-z0-9])?(Post(ma?(st(e?r)?|n)|office)|(send)?Mail(er)?|daemon|m(mdf|ajordomo)|n?uucp|LIST(SERV|proc)|NETSERV|o(wner|ps)|r(e(quest|sponse)|oot)|b(ounce|bs\.smtp)|echo|mirror|s(erv(ices?|er)|mtp(error)?|ystem)|A(dmin(istrator)?|MMGR|utoanswer))(([^).!:a-z0-9][-_a-z0-9]*)?[%@> ][^<)]*(\(.*\).*)?)?$([^>]|$))'mio;
+our $procmailFROM_MAILER=qr'^(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )[^>]*\b(Post(ma(st(er)?|n)|office)|(send)?Mail(er)?|daemon|mmdf|n?uucp|ops|r(esponse|oot)|(bbs\.)?smtp(error)?|s(erv(ices?|er)|ystem)|A(dmin(istrator)?|MMGR))(([^).!:a-z0-9][-_a-z0-9]*)?[%@> ][^<)]*(\(.*\).*)?)?$([^>]|$)'mio;
+# perl-5.8.0 does not cope w/original FROM_MAILER on the third '?' character
+# Thus we did '([^>]*[^(.%@a-z0-9])?' -> '[^>]*\b', I hope it is somehow similiar
+# original FROM_MAILER =qr'^(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )([^>]*[^(.%@a-z0-9])?(Post(ma(st(er)?|n)|office)|(send)?Mail(er)?|daemon|mmdf|n?uucp|ops|r(esponse|oot)|(bbs\.)?smtp(error)?|s(erv(ices?|er)|ystem)|A(dmin(istrator)?|MMGR))(([^).!:a-z0-9][-_a-z0-9]*)?[%@> ][^<)]*(\(.*\).*)?)?$([^>]|$)'mio;
+
+my $opt_mode;
+my $opt_smstest; # 1 or $smscount
+my $opt_idle;
+
+
+sub process;
+
+sub stdin
+{
+ syslogging_restore(); # This is more a debugging session
+ local $/="\n";
+ my $message="";
+ local $_;
+ while (<>) {
+ die "Invalid 'From ' line: $_" if $message eq "" && !/^From /;
+ if (/^From / && $message) {
+ process $message;
+ $message="";
+ }
+ $message.=$_;
+ }
+ process $message if $message;
+ exit 0;
+}
+
+sub inetd
+{
+ die "Excessive arguments" if @ARGV;
+
+ IO::Handle::autoflush STDOUT 1;
+
+ while (1) {
+ local $/="\n";
+ my $length=<STDIN>;
+ confess "Unexpected EOF" if !defined $length;
+ confess "Missing EOL" if $length!~s/\n$//s;
+ exit 0 if $length eq "BYE";
+ confess "Unrecognized length: $length" if $length!~/^\d+$/;
+ my $message;
+ local $_;
+ $length==($_=read STDIN,$message,$length) or confess "Got $_ out of required $length bytes";
+ $length==length $message or confess "False read return ".length($message)." instead of $length";
+ {
+ local *STDOUT;
+ local *STDERR;
+ local $DoBell=0;
+ process $message;
+ if ($DoBell) {
+ bell() or warn "Unable to BELL";
+ }
+ }
+ print STDOUT "1";
+ }
+ die "NOTREACHED";
+}
+
+sub bell
+{
+ local *BELL;
+ open BELL,">/dev/tty11" or return 0;
+ print BELL "\x07";
+ close BELL or return 0;
+ return 1;
+}
+
+sub useridle
+{
+ my %valid_users=map(($_=>1),@ValidUsers);
+ my($idlebest,$linebest);
+ for my $utmp (User::Utmp::getut(),{ "ut_line"=>"psaux" }) {
+ local $_;
+ next if defined($_=$utmp->{"ut_type"}) && $_!=User::Utmp::USER_PROCESS;
+ next if defined($_=$utmp->{"ut_user"}) && !$valid_users{$_};
+ my $line="/dev/".$utmp->{"ut_line"};
+ my $atime=(stat $line)[8];
+ my $what="user \"".($utmp->{"ut_user"} || "<local>")."\", line \"$line\"";
+ warn "Unable to stat $what" and next if !$atime;
+ my $idle=time()-$atime;
+ warn "atime in future for $what" and next if $idle<0;
+ next if $idle>$IdleMax;
+ next if defined $idlebest && $idlebest<=$idle;
+ $idlebest=$idle;
+ $linebest=$line;
+ }
+ return !wantarray() ? $idlebest : ($idlebest,$linebest);
+}
+
+# return only the very (recursive) first part
+sub body_first
+{
+ return $Audit if !$Audit->is_mime();
+ my $first=$Audit;
+ local $_;
+ $first=$_ while $_=$first->parts(0);
+ return $first;
+}
+
+sub mimehead
+{
+my($part)=@_;
+
+ return $Audit->is_mime() ? $part->head()
+ : MIME::Head->new([ split "\n",$Audit->head()->as_string() ])
+ ;
+}
+
+sub mimebody
+{
+my($part)=@_;
+
+ # be vary cautious here as most of $part methods will encode it!
+ return join "",@{$Audit->body()} if !$Audit->is_mime();
+ my $bodyhandle=$part->bodyhandle();
+ # If MIME is corrupted we don't get bodyhandle() for this part
+ # It may occur when "boundary" is specified by header but no such boundary is found in the body
+ return $bodyhandle->as_string() if $bodyhandle;
+ warn "MIME corrupted, adapting";
+ return $part->body_as_string();
+}
+
+sub mime_type
+{
+my($part)=@_;
+
+ return $Audit->is_mime() ? $part->effective_type() : mimehead($part)->mime_type();
+}
+
+sub body_simple
+{
+ my $first=body_first();
+ my $r=mimebody($first);
+ my $mime_type=mime_type($first);
+ if ($mime_type eq "text/html") {
+ # HTML::FormatText just does a useless text layouts
+ # PerlIO::via::StripHTML probably needs PerlIO input (?)
+ $r=~s/<[^>]*>//gs;
+ $r=HTML::Entities::decode($r);
+ # FIXME: detect charset from <meta> tag: "Content-type: text/html; charset=<???>"
+ }
+ elsif ($mime_type eq "application/pgp-encrypted"
+ && (my $filename=mimehead($first)->mime_attr("Content-Disposition.filename"))
+ ) {
+ # first part contains just "Version: 1" as of GnuPG v1.0.4 (GNU/Linux)
+ $r="pgp($filename)";
+ }
+ if ((my $charset=mimehead($first)->mime_attr("Content-Type.charset"))) {
+ my $cstocs=Cz::Cstocs->new($charset,"ascii");
+ $r=&$cstocs($r) if $cstocs; # charset may be unknown
+ }
+ return $r;
+}
+
+sub parts_linear
+{
+my($part)=@_;
+
+ return $Audit if !$part && !$Audit->is_mime();
+ $part||=$Audit;
+ # don't use '!$part->parts()' as even 0-parts-multiparts are still multiparts
+ return $part if $part->bodyhandle();
+ return map { (parts_linear($_)); } $part->parts();
+}
+
+sub smsbuild
+{
+my($smsi,$smscount)=@_;
+
+ return "$smsi/$smscount:" if $smscount>1;
+ return "";
+}
+
+# patch for http://kiwi.ms.mff.cuni.cz/%7Etom/programming/src/sendsms.tar.gz/sendsms.pl
+my $agent=LWP::UserAgent->new();
+$agent->agent("LaceMail $VERSION; contact=$SMScontact; ");
+my($request1,$response1); # for &send_cz_eurotel
+my($name,$value,$type,$disabled,$q2);
+
+# &send_cz_eurotel returns: error
+# BEGIN http://kiwi.ms.mff.cuni.cz/%7Etom/programming/src/sendsms.tar.gz/sendsms.pl
+sub parse_inputs
+{
+ my ($resp) = @_;
+ my @inputs;
+ my $ct;
+ my @c;
+ $ct=$resp->content();
+
+ @c=split '>', $ct;
+ grep {
+ if (/(<input|<select|<textarea)([^<>]*)(>|$)/i) {
+ my $txt=$2, $name="", $value="", $type="x", $disabled=0;
+ my $ipoc;
+ if ($txt =~ /type="([^"]*)"/i) { $type=$1; }
+ elsif ($txt =~ /type=([^" ]*)[ >]/i) { $type=$1; }
+ if ($txt =~ /name="([^"]*)"/i) { $name=$1; }
+ elsif ($txt =~ /name=([^" ]*)[ >]/i) { $name=$1; }
+ if ($txt =~ /value="([^"]*)"/i) { $value=$1; }
+ elsif ($txt =~ /value=([^" ]*)[ >]/i) { $value=$1; }
+ if ($txt =~ /disabled/i) { $disabled=1; }
+ if ($name ne "" && $type ne "" && $type ne "button" && ! $disabled)
+ {
+ $ipoc=$#inputs;
+ $inputs[$ipoc+1][0]=$name;
+ $inputs[$ipoc+1][1]=$value;
+ }
+ }
+ 0; } @c;
+ return @inputs;
+}
+
+sub make_query
+{
+ my (@inputs) = @_;
+
+ my $i;
+ my $query = "";
+
+ for ($i=0; $i<=$#inputs; $i++)
+ {
+ my($q1, $q2);
+ if ($i>0) { $query="$query&"; }
+ $q1=uri_escape($inputs[$i][0]);
+ $q2=uri_escape($inputs[$i][1]);
+ $query="$query$q1=$q2";
+ }
+
+ #change @ and space back
+ $query=~ s/%20/+/g;
+ $query=~ s/%40/@/g;
+ return $query;
+}
+
+sub send_cz_eurotel
+{
+ my ($id,$text,$mail,$directd) = @_;
+ my $src_url = "http://www2.eurotel.cz/sms/index.html";
+ my @inputs;
+ my $query = "";
+ my $cookie = HTTP::Cookies->new;
+ my $pref;
+
+ #check if correct number
+ if (substr($id,0,5)!="00420") { return -1; }
+ $pref=substr($id,5,3);
+ if (!($pref eq "601" || $pref eq "602" || $pref eq "606" || $pref eq "607" || ($pref ge "720" && $pref le "729"))) { return -1; }
+
+ #get form page, extract cookies
+ $request1=new HTTP::Request('GET', "$src_url?n_pagestyle=new");
+ $response1=$agent->request($request1);
+ if ($response1->code != 200) { return -3; }
+ $cookie->extract_cookies($response1);
+
+ #parse the form
+ @inputs=parse_inputs($response1);
+
+ #fill the form
+ $inputs[2][1]=substr($id,5,3);
+ $inputs[3][1]=substr($id,8,6);
+ $inputs[4][1]=$mail;
+
+ #direct display
+ $inputs[6][1]="sms";
+ $inputs[6][1]="show" if ($directd>0);
+
+ $inputs[7][1]=$text;
+
+# for ($i=0; $i<=$#inputs; $i++) { print "[$i] $inputs[$i][0] $inputs[$i][1]\n"; }
+
+ #make query
+ $query=make_query(@inputs);
+
+ #POST the form
+ my $header = new HTTP::Headers(
+ 'Content-Length' => length($query),
+ 'Content-Type' => 'application/x-www-form-urlencoded',
+ 'Accept' => '*/*',
+ 'Referer' => $src_url
+ );
+ my $request2 = new HTTP::Request('POST',$src_url, $header, $query);
+ $cookie->add_cookie_header($request2);
+ my $response2 = $agent->request($request2);
+
+ if ($response2->code != 200) { return -3; }
+
+ #check for success
+ if ($response2->content() !~ /byla.*odesl.*na na SMS centrum/)
+ {
+ return -2;
+ }
+ return 0;
+}
+# END http://kiwi.ms.mff.cuni.cz/%7Etom/programming/src/sendsms.tar.gz/sendsms.pl
+
+sub smslens
+{
+my($ignorenewmail,$smscount,%args)=@_;
+
+ return map({
+ my $l=160;
+ if (!$ignorenewmail) { # send by mail
+ $l-=length("Z emailu $SMSmailError: ");
+ $l-=length(smsbuild($_,$smscount));
+ }
+ else { # send by web
+ $l-=length("Z WWW x/5: ");
+ $l-=length(smsbuild($_,POSIX::ceil($smscount/5)));
+ }
+ $l;
+ } (0..$smscount-1));
+}
+
+sub smssend_web
+{
+my($squeezed,$smscount,@lens)=@_;
+
+ $smscount=POSIX::ceil($smscount/5);
+ for my $smsi (0..$smscount-1) {
+ my $len=$lens[$smsi];
+ $squeezed=~/^.{0,$len}/s;
+ my $frag=$&;
+ $squeezed=$';
+ return 0 if send_cz_eurotel($SMSwebRcpt,$frag,"",0);
+ }
+ return 1;
+}
+
+sub smssend_mail
+{
+my($squeezed,$smscount,@lens)=@_;
+
+ my $recalclen=0;
+ for ($smscount=0;$recalclen<length $squeezed;$smscount++) {
+ $recalclen+=$lens[$smscount];
+ }
+ for my $smsi (0..$smscount-1) {
+ my $len=$lens[$smsi];
+ $squeezed=~/^.{0,$len}/s;
+ my $frag=$&;
+ $squeezed=$';
+ my $mail=Mail::Mailer->new("sendmail","-f","$SMSmailError");
+ $mail->open({
+ "To"=>$SMSmailRcpt,
+ "From"=>$SMSmailError, # no longer displayed anyway
+ "X-LaceMail-Version"=>$VERSION,
+ "X-LaceMail-Contact"=>$SMScontact,
+ });
+ print $mail smsbuild($smsi,$smscount).$frag."\n";
+ # FIXME: check errors
+ $mail->close();
+ }
+ return 1;
+}
+
+sub smssend
+{
+my($ignorenewmail,$smscount,%args)=@_;
+
+ my %aliases=muttrc_aliases();
+ my $text=audit_sms(
+ "subject"=>unmime($Audit->subject()),
+ "from"=>[ map({ $_=$_->address(); $_="\L$_"; $aliases{$_} || $_; } Mail::Address->parse(unmime($Audit->from()))) ],
+ "body"=>substr(body_simple(),0,$MaxBodySMS*(1+0.25*$smscount)),
+ %args);
+ my $texthead="";
+ ($texthead,$text)=@$text if ref $text;
+ do { print "$texthead\n$text\n"; return; } if $opt_smstest;
+ my @lens=smslens($ignorenewmail,$smscount,%args);
+ my $maxlen=0;
+ $maxlen+=$_ for (@lens);
+ my $squeezed;
+ for my $squeeze (@sms_squeezes) {
+ local $_;
+ Lingua::EN::Squeeze::SqueezeControl($_) if defined ($_=$squeeze->{"SqueezeControl"});
+ $Lingua::EN::Squeeze::SQZ_OPTIMIZE_LEVEL or 1; # prevent: Name "$_" used only once: possible typo
+ $Lingua::EN::Squeeze::SQZ_OPTIMIZE_LEVEL=$_ if defined ($_=$squeeze->{"SQZ_OPTIMIZE_LEVEL"});
+ $squeezed=Lingua::EN::Squeeze::SqueezeText($text);
+ chomp $squeezed;
+ last if $maxlen>=length($texthead.$squeezed);
+ }
+ $squeezed=substr $texthead.$squeezed,0,$maxlen; # strip if we passed thru last for() above
+ my $recalclen=0;
+ for ($smscount=0;$recalclen<length $squeezed;$smscount++) {
+ $recalclen+=$lens[$smscount];
+ }
+ my $func=($ignorenewmail ? \&smssend_web : \&smssend_mail);
+ &$func($squeezed,$smscount,@lens);
+}
+
+sub smssend_tryall
+{
+my($ignorenewmail,@args)=@_;
+
+ return if !$opt_smstest && !$opt_idle && defined useridle();
+ local $_;
+ return $_ if $_=smssend(1,@args); # web
+ return $_ if !$ignorenewmail && ($_=smssend(0,@args)); # mail
+ warn "Unable to SMSsend the mail";
+ return 0;
+}
+
+sub cut
+{
+ local $_=$_[0];
+ return "<???>" if !defined($_) || /^\s*$/s;
+ s/^\s*//s;
+ s/\s*$//s;
+ return $_ if length($_)<64;
+ return substr($_,0,64)."...";
+}
+
+our $profile_eval_depth=0;
+# ($name || @$name)
+sub profile_eval
+{
+my($name)=@_;
+
+ die "Nesting profile: $name" if 0x10<=(local $profile_eval_depth=$profile_eval_depth+1);
+ return @$name if ref $name;
+ die "Profile not found: $name" if !exists $audit_profile{$name};
+ my @this=@{$audit_profile{$name}};
+ return (profile_eval($'),@this[1..$#this]) if $this[0] && $this[0]=~/^=/;
+ return @this;
+}
+
+sub address_show
+{
+my($text)=@_;
+
+ return join(",",map({ $_->name() or $_->address(); } Mail::Address->parse($text)));
+}
+
+sub unmime
+{
+my($text)=@_;
+
+ return join "",map({
+ my $cstocs;
+ for (${$_}[1],"iso-8859-2") {
+ last if $_ && ($cstocs=Cz::Cstocs->new($_,"ascii"));
+ }
+ &$cstocs(${$_}[0]);
+ } MIME::Words::decode_mimewords($text));
+}
+
+# $folder: "$folder; comment"
+# $profile as profile_eval($name)
+sub store
+{
+my($folder,$profile,%args)=@_;
+
+ $profile=$store_profile if !$profile;
+ my %do=map({ (!/=/ ? ($_=>1) : ($`=>$')); } profile_eval($profile));
+ Sys::Syslog::syslog("info","%s%s: %s: %s",
+ (!$store_ignore ? "" : "IGNORED[$store_ignore]: "),
+ map({ cut($_); } $folder,address_show(unmime($Audit->from())),unmime($Audit->subject())),
+ )
+ if $do{"syslog"};
+ $DoBell++ if $do{"bell"};
+ $folder=~s/;.*$//s;
+ $folder="$Mail/".$' if $folder=~/^=/;
+ if (!$store_ignore) {
+ $Audit->noexit(1);
+ $Audit->accept($folder);
+ }
+ smssend_tryall $store_ignorenewmail,$do{"sms"},%args if $do{"sms"};
+ push @AuditStored,$folder if $do{"did"};
+}
+
+our $did_last=0;
+
+# no &$funcref=>did smth in this block
+# &$funcref,@funcargs
+sub did
+{
+my($funcref,@funcargs)=@_;
+
+ return @AuditStored!=$did_last if !$funcref;
+ local $did_last=@AuditStored;
+ &$funcref(@funcargs);
+ return @AuditStored!=$did_last;
+}
+
+sub process
+{
+my($message)=@_;
+
+ local $_=$_;
+ my $save_=$_;
+ local $Message=$message;
+ local $Audit=Mail::Audit->new(
+ "emergency"=>"$Mail/emergency",
+ "data"=>[map("$_\n",split("\n",$message))],
+ );
+ local @AuditStored=();
+ do { smssend $opt_smstest; return; } if $opt_smstest;
+ audit();
+ warn 'Corrupted $_, repaired' if defined($save_)!=defined($_) || (defined($_) && $save_ ne $_);
+}
+
+# utility functions:
+
+# return: true (error-message or "1") if is spam
+sub razor2
+{
+ # razor-check has exit code 1 if NOT spam, code 0 if IS spam
+ local *CHILD;
+ # prevent Razor2's: Can't call method "log" on unblessed reference at Razor2/Client/Agent.pm line 212.
+ local $ENV{"HOME"}=$HOME;
+ open CHILD,'|'
+ .'('.'(razor-check 2>&1;echo >&3 $?)'
+ .'|sed "s/^/razor-check: /"'
+ .'|logger -t "lacemail['.$$.']" -p mail.crit'
+ .') 3>&1'
+ .'|exit `cat`'
+ or return 0;
+ print CHILD $Message;
+ my $return;
+ {
+ local $/=undef();
+ $return=<CHILD> || 1;
+ }
+ close CHILD;
+ return undef() if !WIFEXITED($?);
+ return undef() if WIFSIGNALED($?);
+ return undef() if WIFSTOPPED($?);
+ return undef() if WEXITSTATUS($?);
+ return $return; # is-spam
+}
+
+# NOTE: returns undef() if !wantarray and the first header is unrecognized
+sub Received_for
+{
+ my @r=();
+ for my $hdr ($Audit->head->get("Received")) {
+ my($for)=($hdr=~/\bfor\s+\<?(\S+)\>?\b/);
+ return $for if !wantarray();
+ push @r,$for if $for;
+ }
+ return @r;
+}
+
+our %muttrc_pending=();
+sub muttrc
+{
+my($muttrc)=@_;
+
+ $muttrc||="$HOME/.muttrc";
+ $muttrc=~s/^\~/$HOME/;
+ do { warn "Looping muttrc, ignoring: $muttrc"; return (); } if $muttrc_pending{$muttrc};
+ local $muttrc_pending{$muttrc}=1;
+ local *MUTTRC;
+ open MUTTRC,$muttrc or do { warn "open \"$muttrc\": $!"; return (); };
+ local $/="\n";
+ local $_;
+ my @r=();
+ # far emulation mutt/init.c/mutt_parse_rc_line()
+ while (<MUTTRC>) {
+ s/^[\s;]*//s;
+ s/[#;].*$//s;
+ s/\s*$//s;
+ next if !/^(\S+)\s*/s;
+ if ($1 eq "source") {
+ $_=$';
+ do { warn "Wrong 'source' parameters at $muttrc:$.: $_"; next; } if !/^\S+$/;
+ push @r,muttrc($_);
+ next;
+ }
+ push @r,$_;
+ }
+ close MUTTRC or warn "close \"$muttrc\": $!";
+ return wantarray() ? @r : join("",map("$_\n",@r));
+}
+
+sub muttrc_get
+{
+my(@headers)=@_;
+
+ my @r=map({ (ref $_ ? $_ : qr/^\s*set\s+\Q$_\E\s*=\s*"([^"]*)"\s*$/si); } @headers);
+ my %r=map(($_=>undef()),@r);
+ for (muttrc()) {
+ for my $ritem (@r) {
+ /$ritem/si or next;
+ $r{$ritem}=$1;
+ }
+ }
+ for my $var (grep { !defined($r{$_}) } @r) {
+ warn "Variable '$var' not found in muttrc";
+ return undef();
+ }
+ return wantarray() ? %r : $r{$r[0]};
+}
+
+sub muttrc_aliases
+{
+ my %r=();
+ for (muttrc()) {
+ next if !(my $key=(/^alias\s+(\S+)\s+/)[0]);
+ for my $addrobj (Mail::Address->parse($')) {
+ my $addr=$addrobj->address();
+ my $ref=\$r{"\L$addr"};
+ $$ref=$key if !$$ref;
+ }
+ }
+ return %r;
+}
+
+sub store_muttrc_alternates
+{
+my($prefix,$profile)=@_;
+
+ my $alternates=muttrc_get("alternates") or return;
+ my $alternatesre=qr/$alternates/si;
+ my $From=muttrc_get(qr/^\s*my_hdr\s+From:.*\<(\S+)\>\s*$/si) or return;
+ my $Fromre=qr/^\Q$From\E$/si;
+ warn "'From' \"$From\" not matches by 'alternates': $alternatesre"
+ if $From!~/$alternates/si;
+ for my $for (reverse Received_for()) {
+ return if $for=~/$From/si;
+ next if $for!~/$alternatesre/si;
+ store "$prefix\L$for",($profile || []);
+ return;
+ }
+}
+
+# $header: ref CODE
+# $header: !ref => $Audit->get($header)
+# $maybeaddress: qr/regex/i
+# $maybeaddress: "string"
+# $maybeaddress: "<Regexp:regex>" # hack :-(
+# $maybeaddress: "<user@host>"
+# $maybeaddress: "<user@>"
+# $maybeaddress: "<@host>"
+sub _headercore
+{
+my($re,$justone,$header,$maybeaddress)=@_;
+
+ if (ref $header) {
+ $header=join(",",&$header());
+ }
+ else {
+ $header=$Audit->get($header);
+ }
+ return 0 if !$header;
+ return $header=~/$maybeaddress/i if "Regexp" eq ref $maybeaddress;
+ return $header=~/$re/i if !defined(my $want=($maybeaddress=~/^\<(.*)\>$/)[0]);
+ my @parsed=Mail::Address->parse($header);
+ warn "'mailto:' forbidden in pattern: $want" if $want=~/^\Qmailto:\E/;
+ return 0 if $justone && 1!=@parsed;
+ return grep {
+ if ($want=~/^Regexp:/)
+ { $_->address()=~/$'/i; }
+ elsif ($want=~/\@$/)
+ { $_->user() =~/^(?:\Qmailto:\E)?\Q$`\E/i; }
+ elsif ($want=~/^\@/)
+ { $_->host() =~/^\Q$'\E/i; }
+ else
+ { $_->address()=~/^(?:\Qmailto:\E)?\Q$want\E/i; }
+ } @parsed;
+}
+
+sub headerhas
+{
+my($header,$substr)=@_;
+
+ return _headercore(qr/\Q$substr\E/i,0,$header,$substr);
+}
+
+sub headeris
+{
+my($header,$string)=@_;
+
+ return _headercore(qr/\Q$string\E/i,1,$header,$string);
+}
+
+# $header,%$map
+sub header_remap
+{
+my($header,$map)=@_;
+
+ my $text=$Audit->get($header);
+ my $orig=$text;
+ while (my($from,$to)=each(%$map)) {
+ $text=~s/\b\Q$from\E\b/$to/gsi;
+ }
+ return if $text eq $orig;
+ $Audit->put_header("X-LaceMail-header_remap-$header",$orig);
+ $Audit->replace_header($header,$text);
+}
+
+
+# MAIN
+
+my $basedir=File::Basename::dirname($0);
+$Getopt::Long::ignorecase=0;
+die "GetOptions error" if !Getopt::Long::GetOptions(
+ "inetd" ,sub { $opt_mode=\&inetd; },
+ "stdin" ,sub { $opt_mode=\&stdin; },
+ "smstest:s",sub { $opt_mode=\&stdin; $opt_smstest=($_[1] || 1); },
+ "idle!" ,\$opt_idle,
+ "idletest" ,sub { syslogging_restore(); print((defined($_=useridle()) ? $_ : "<undef>")."\n"); exit 0; },
+ "muttrc" ,sub { syslogging_restore(); print scalar muttrc(); exit 0; },
+ "d|basedir=s",\&basedir,
+ );
+# "Excessive arguments" checked in &inetd
+die "Missing mode" if !$opt_mode;
+
+my $filenameMyAudit="$basedir/My-Audit.pm";
+open AUDIT,$filenameMyAudit or die "open \"$filenameMyAudit\": $!";
+{
+ local $/=undef();
+ eval <AUDIT> or die "eval \"$filenameMyAudit\": $@";
+ audit_init();
+ }
+close AUDIT or warn "close \"$filenameMyAudit\": $!";
+
+&$opt_mode();
+die "NOTREACHED";
git://git.jankratochvil.net / PerlMail.git / commitdiff