#!/usr/bin/perl
# rebuilds bayesian spam database
our $VERSION = "2.9.4.0";
our $modversion = '(1.0.02)'; 
# (c) John Hanna 2003 under the terms of the GPL
# Updated July 2004 for simple proxy support.
# (c) Fritz Borgstedt 2006 under the terms of the GPL
# Updated Feb 2008 refactoring and rewrites
# (c) Kevin 2008 under the terms of the GPL
use bytes;    # get rid of anoying 'Malformed UTF-8' messages
use Digest::MD5 qw(md5_hex);
use English '-no_match_vars';
use File::Copy;
use IO::Handle;
use IO::Socket;
use Time::Local;
use Time::HiRes;
use Cwd;
use strict qw(vars subs);
our $AvailLWP  = eval('use LWP::Simple; 1');    # LWP::Simple module installed
our $CanUseLWP = $AvailLWP;
our	$noGriplistUpload;
our	$noGriplistDownload;
our $gripListDownUrl = 'http://*HOST*/cgi-bin/assp_griplist?binary';
our $gripListUpUrl = 'http://*HOST*/cgi-bin/assp_griplist?binary';
our $gripListUpHost = 'assp.sourceforge.net';
$gripListDownUrl =~ s/\*HOST\*/$gripListUpHost/o;
$gripListUpUrl  =~ s/\*HOST\*/$gripListUpHost/o;

our $HeaderValueRe=qr/[ \t]*[^\r\n]*(?:\r?\n[ \t]+\S[^\r\n]*)*(?:\r?\n)?/o;
# IP Address representations
our $IPprivate;
our $IPQuadSectRE;
our $IPQuadSectDotRE;
our $IPQuadRE;
our $IPStrictQuadRE;

# Host
our $IPSectRe;
our $IPSectHexRe;
our $IPSectDotRe;
our $IPSectHexDotRe;
our $IPRe;
our $IPv4Re;
our $IPv6Re;
our $IPv6LikeRe;
our $PortRe;
our $HostRe;
our $HostPortRe;
# IP Address representations
my $sep;
my $v6Re = '[0-9A-Fa-f]{1,4}';
$IPSectRe = '(?:25[0-5]|2[0-4]\d|1\d\d|0?\d?\d)';
$IPSectHexRe = '(?:(?:0x)?(?:[A-Fa-f][A-Fa-f0-9]?|[A-Fa-f0-9]?[A-Fa-f]))';

$IPprivate  = '^(?:0{1,3}\.0{1,3}\.0{1,3}\.0{1,3}|127(?:\.'.$IPSectRe.'){3}|169\.254(?:\.'.$IPSectRe.'){2}|0?10(?:\.'.$IPSectRe.'){3}|192\.168(?:\.'.$IPSectRe.'){2}|172\.0?1[6-9](?:\.'.$IPSectRe.'){2}|172\.0?2[0-9](?:\.'.$IPSectRe.'){2}|172\.0?3[01](?:\.'.$IPSectRe.'){2})$';   #RFC 1918 decimal
$IPprivate .= '|^(?:(?:0x)?0{1,2}\.(?:0x)?0{1,2}\.(?:0x)?0{1,2}\.(?:0x)?0{1,2}|(?:0x)?7[Ff](?:\.'.$IPSectHexRe.'){3}|(?:0x)?[aA]9\.(?:0x)?[Ff][Ee](?:\.'.$IPSectHexRe.'){2}|(?:0x)?0[aA](?:\.'.$IPSectHexRe.'){3}|(?:0x)?[Cc]0\.(?:0x)?[Aa]8(?:\.'.$IPSectHexRe.'){2}|(?:0x)[Aa][Cc]\.(?:0x)1[0-9a-fA-F](?:\.'.$IPSectHexRe.'){2})$';   #RFC 1918 Hex
$IPprivate .= '|^(?:0{0,4}:){2,6}'.$IPprivate.'$';  # privat IPv4 in IPv6
$IPprivate .= '|^(?:0{0,4}:){2,7}[1:]?$';  # IPv6 loopback and universal

$IPQuadSectRE='(?:0([0-7]+)|0x([0-9a-fA-F]+)|(\d+))';
$IPQuadSectDotRE='(?:'.$IPQuadSectRE.'\.)';
$IPQuadRE=qr/$IPQuadSectDotRE?$IPQuadSectDotRE?$IPQuadSectDotRE?$IPQuadSectRE/o;



$IPSectDotRe = '(?:'.$IPSectRe.'\.)';
$IPSectHexDotRe = '(?:'.$IPSectHexRe.'\.)';
$IPv4Re = qr/(?:
(?:$IPSectDotRe){3}$IPSectRe
|
(?:$IPSectHexDotRe){3}$IPSectHexRe
)/xo;

# privat IPv6 addresses
$IPprivate .= <<EOT;
|^(?i:FE[89A-F][0-9A-F]):
(?:
(?:(?:$v6Re:){6}(?:                                $v6Re      |:))|
(?:(?:$v6Re:){5}(?:                   $IPv4Re |   :$v6Re      |:))|
(?:(?:$v6Re:){4}(?:                  :$IPv4Re |(?::$v6Re){1,2}|:))|
(?:(?:$v6Re:){3}(?:(?:(?::$v6Re)?    :$IPv4Re)|(?::$v6Re){1,3}|:))|
(?:(?:$v6Re:){2}(?:(?:(?::$v6Re){0,2}:$IPv4Re)|(?::$v6Re){1,4}|:))|
(?:(?:$v6Re:)   (?:(?:(?::$v6Re){0,3}:$IPv4Re)|(?::$v6Re){1,5}|:))|
                (?:(?:(?::$v6Re){0,4}:$IPv4Re)|(?::$v6Re){1,6}|:)
)\$
EOT
$IPprivate = qr/$IPprivate/xo;

# RFC4291, section 2.2, "Text Representation of Addresses"
$sep = '[:-]';
$IPv6Re = $IPv6LikeRe = <<EOT;
(?:
(?:(?:$v6Re$sep){7}(?:                                         $v6Re      |$sep))|
(?:(?:$v6Re$sep){6}(?:                         $IPv4Re |   $sep$v6Re      |$sep))|
(?:(?:$v6Re$sep){5}(?:                     $sep$IPv4Re |(?:$sep$v6Re){1,2}|$sep))|
(?:(?:$v6Re$sep){4}(?:(?:(?:$sep$v6Re)?    $sep$IPv4Re)|(?:$sep$v6Re){1,3}|$sep))|
(?:(?:$v6Re$sep){3}(?:(?:(?:$sep$v6Re){0,2}$sep$IPv4Re)|(?:$sep$v6Re){1,4}|$sep))|
(?:(?:$v6Re$sep){2}(?:(?:(?:$sep$v6Re){0,3}$sep$IPv4Re)|(?:$sep$v6Re){1,5}|$sep))|
(?:(?:$v6Re$sep)   (?:(?:(?:$sep$v6Re){0,4}$sep$IPv4Re)|(?:$sep$v6Re){1,6}|$sep))|
(?:        $sep    (?:(?:(?:$sep$v6Re){0,5}$sep$IPv4Re)|(?:$sep$v6Re){1,7}|$sep))
)
EOT

$IPv6Re =~ s/\Q$sep\E/:/go;
$IPv6Re = qr/$IPv6Re/xo;
$IPv6LikeRe = qr/$IPv6LikeRe/xo;

$IPRe = qr/(?:
$IPv4Re
|
$IPv6Re
)/xo;
our $EmailDomainRe;
$EmailDomainRe=qr/(?:\w[\w\.\-]*\.\w\w+|\[[\d\.]*\.\d+\])/o;
# re for a single port - could be number 1 to 65535
$PortRe = qr/(?:(?:[1-6]\d{4})|(?:[1-9]\d{0,3}))/o;
# re for a single host - could be an IP a name or a fqdn
$HostRe = qr/(?:(?:$IPv4Re|\[?$IPv6Re\]?)|$EmailDomainRe|\w\w+)/o;
$HostPortRe = qr/$HostRe:$PortRe/o;

our %m;
our %GpOK;
if ($CanUseLWP) {
#        my $ver        = eval('LWP::Simple->VERSION');
#        print "LWP::Simple $ver installed - download griplist available\n" ;
    } elsif ( !$AvailLWP ) {
        print "LWP::Simple module not installed - download griplist not available\n";
    }
#use warnings;

#no output buffering to screen
*STDOUT->autoflush();

#holy predeclarations Batman!
use vars qw(
    $autoCorrectCorpus $base $DropList $correctednotspam $correctednotspamcount $correctedspam
    $correctedspamcount $discarded $DoDropList $DoNotCollectRed $EmailAdrRe $EmailDomainRe $EmailFrom $EmailAdminReportsTo $griplist $HamWordCount
    $KeepWhitelistedSpam $lowernorm $logfile $Log $LogDateFormat $maillogExt $MaxBytes $MaxCorrectedDays $MaxBayesFileAge $MaxNoBayesFileAge  $MaintBayesCollection $MaxFiles $MaxKeepDeleted $MaxWhitelistDays
    $MaxWhitelistLength  $maintbayescollection $minimumfiles $minimumdays $mydb $myhost $mypassword $myuser $myName $notspamlog $processTime
    $notspamlogcount $npRe $incomingOkMail $OrderedTieHashSize $pbdbfile $proxyserver $proxyuser $proxypass $noGriplist		
    $RebuildLog $rebuildrun $redlistdb $redRe $redReRE $resendmail $setFilePermOnStart $silent $spamdb $spamdberror $spamdbFile $spamdberrorFile $RegExLength
    $spam $spamdbFname $spamdberrorFname $spamlog $spamlogcount $SpamWordCount $starttime
    $usesubject $WhitelistCleanFreq $whitelistdb $WhitelistObject $RebuildNotify $RedlistObject $viruslog $whiteRe $whiteReRE $wildcardUser
    %HamHash %Helo %Redlist %spam %SpamHash %Whitelist $asspLog $DoNotCollectRedList $DoNotCollectRedRe
    $DoFullGripDownload $UseLocalTime $uppernorm $TrashObject %Trashlist
    $runAsUser $runAsGroup
);
# load from command line if specified
if($ARGV[0]) { 
 $base=$ARGV[0]; 
} else { 
 # the last one is the one used if all else fails 
 $base = cwd(); 
 unless (-e "$base/assp.cfg") { 
   foreach ('.','/usr/local/assp','/home/assp','/etc/assp','/usr/assp','/applications/assp','/assp','.') {
    if (-e "$_/assp.cfg") {
      $base=$_; 
      last ; 
    } 
   } 
 } 
 $base = cwd() if $base eq '.'; 
}
unless (chdir $base) {
print
"Usage:
  perl rebuildspamdb.pl  c:\\assp  -- runs the programm in basedirectory c:\\assp\n
";
 die "Abort: unable to change to basedirectory $base";
}
$silent = 1 if (lc $ARGV[1] =~ /silent/i ||  lc $ARGV[0] =~ /silent/i);

#load configuration options from assp.cfg file
&loadconfig();

fork() && exit;

# open log file
if ( -e "$rebuildrun.bak" ) {
    unlink("$rebuildrun.bak") or die "unable to remove file: $!";
}
if ( -e $rebuildrun ) {
    copy( $rebuildrun, "$rebuildrun.bak" ) or die "unable to copy file for: $!";
}
open( $RebuildLog, '>', "$rebuildrun" ) or die "unable to open file for logging: $!";

our $silentlog;
$starttime = time;
&printlog("\n");
for ( my $c = 10; $c >= 1; $c-- ) { &printlog(q{*}); }
my $savesilent=$silent;
$silent=0;
printlog (&timestring(time) . " RebuildSpamDB $VERSION $modversion is starting;\n") ;
$silent=$savesilent;

&printlog( "\nRunning in $myName basedirectory '$base'\n");
#-- check if running as root 
&printlog( "Running as root!!\n") if $< == 0 && $^O ne "MSWin32";
 
#-- print username
&printlog( "Running as user '" . (getpwuid($<))[0] . "'\n") if $< != 0 && $^O ne "MSWin32";
 
&printlog("\n--- ASSP $myName Settings ---\n");
#if ($silent && $< == 0 && $^O ne "MSWin32") {
#	my ( $uid, $gid ) = getUidGid( $runAsUser, $runAsGroup )
#      if ( $runAsUser || $runAsGroup );
#	switchUsers( $uid, $gid ) if ( $runAsUser || $runAsGroup );
#}

my $AvailTieRDBM  = eval "use Tie::RDBM; 1";    # Is the required module installed?
my $CanUseTieRDBM = $AvailTieRDBM;              # this looks wierd but it's the only way it works
undef $AvailTieRDBM;
$EmailAdrRe    = "[^()<>@,;:\\\"\\[\\]\000-\040]+";
$EmailDomainRe = '(?:\w[\w\.\-]*\.\w+|\[[\d\.]*\.\d+\])';

# set counts
$HamWordCount          = $SpamWordCount = $correctedspamcount = 0;
$correctednotspamcount = $spamlogcount  = $notspamlogcount    = 0;

# read old norm
our $Normfile;
our ($oldnorm, $oldcorrectedspamcount, $oldcorrectednotspamcount, $oldspamlogcount, $oldnotspamlogcount);
open( $Normfile, '<', "$base/normfile" ) || warn "unable to open $base/normfile: $!\n";
if ($Normfile) {
	while (<$Normfile>) {
    	($oldnorm, $oldcorrectedspamcount, $oldcorrectednotspamcount, $oldspamlogcount, $oldnotspamlogcount) = split(" ",$_);
    }
    close $Normfile;
}



if ($DoNotCollectRedList) {
    &printlog(
        "Do Not Collect Messages with RedListed address: Enabled\n**Messages with RedListed addresses will be removed from the corpus!**\n\n"
    );
}

&printlog("Maxbytes: $MaxBytes \n");
&printlog("Maxfiles: $MaxFiles \n");


#rebuild various cache files and lists
&repair();

# Let's clean the old entries

 &cleanTrashlist();
# Let's clean the non bayesian folder of old entries 
# Let's clean the bayesian folder of old entries  
# Let's clean the corrected spam/notspam folder of old entries
 &cleanUpCollection();


# name, contents, refrence to "compiled" object
#&compileregex( "whiteRe", $whiteRe, \$whiteReRE );
&compileregex( "redRe",   $redRe,   \$redReRE );

# redlist,whitelist
&createlistobjects();

# isspam?, path, filter, weight, processing sub
$correctedspamcount    = &processfolder( 1, $correctedspam,    "*",      2, \&dospamhash );
$correctednotspamcount = &processfolder( 0, $correctednotspam, "*",      4, \&dohamhash );
$spamlogcount          = &processfolder( 1, $spamlog,          "*", 1, \&checkspam );
$notspamlogcount       = &processfolder( 0, $notspamlog,       "*", 1, \&checkham );
our $norm = $HamWordCount ? ( $SpamWordCount / $HamWordCount ) : 1;
$norm = sprintf("%.4f",$norm);
open( my $normFile, '>', "$base/normfile" ) || warn "unable to open $base/normfile: $!\n";
if ($normFile) {
    print { $normFile } "$norm $correctedspamcount $correctednotspamcount $spamlogcount $notspamlogcount";
    close $normFile;
}

# Create Bayesian DB
&generatescores();

# Create HELo blacklist
&createheloblacklist();
&printlog(
    "\nSpam Weight:\t   " . commify($SpamWordCount) . "\nNot-Spam Weight:   " . commify($HamWordCount) . "\n\n" );
if ( !($norm) ) {    #invalid norm
    &printlog("Warning: Corpus insufficent to calculate normality!\n");
}
else {               #norm exists, print it


        my $normdesc = '';
        
        &printlog( "Wanted Corpus norm:\t%.4f %s $normdesc \n", $autoCorrectCorpus  );
        &printlog( "Reached Corpus norm:\t%.4f %s $normdesc \n", $norm  );
        

}


$lowernorm = 0.5 if $lowernorm && ($lowernorm > 1 or $lowernorm < 0.5);


if   ( time - $starttime != 0 ) { $processTime = time - $starttime; }
else                            { $processTime = 1; }
&printlog( "\nTotal processing time: %d second(s)\n\n", $processTime );

&downloadGripConf();
&uploadgriplist() if ! $noGriplistUpload && !$noGriplist;
&downloadgriplist() if ! $noGriplistDownload && !$noGriplist;


&downloaddroplist();

$savesilent=$silent;
$silent=0;
&printlog( "\n");
&printlog( &timestring(time) . " RebuildSpamDB $VERSION $modversion ended;\n");
$silent=$savesilent;
&printlog( "Sending Notify to $RebuildNotify\n") if $RebuildNotify;
&printlog( "Sending Notify not possible, address in RebuildNotify missing\n") if !$RebuildNotify;
close $RebuildLog;
if ($RebuildNotify) {
        &sendNotification(
          $EmailFrom,
          $RebuildNotify,
          'RebuildSpamDB - report',
          "File rebuildrun.txt follows:\r\n\r\n",
          "$base/rebuildrun.txt");
    }


##########################################
#           script ends here
##########################################
sub createlistobjects {

    if ( $CanUseTieRDBM && $whitelistdb =~ /mysql/ && !$KeepWhitelistedSpam ) {
        eval {
            $WhitelistObject = tie %Whitelist, 'Tie::RDBM', "dbi:mysql:database=$mydb;host=$myhost",
                { user => "$myuser", password => "$mypassword", table => 'whitelist', create => 0 };
        };
        if ($EVAL_ERROR) {
            &printlog("whitelist mysql error: $@");
            $CanUseTieRDBM = 0;
            $whitelistdb   = "whitelist";
        }
    }
    elsif ( !$KeepWhitelistedSpam ) {
        if ( -e $whitelistdb ) { $WhitelistObject = tie( %Whitelist, 'orderedtie', "$whitelistdb" ); }
    }
    if ( $CanUseTieRDBM && $redlistdb =~ /mysql/ && ( $DoNotCollectRed || $DoNotCollectRedList ) ) {
        eval {
            $RedlistObject = tie %Redlist, 'Tie::RDBM', "dbi:mysql:database=$mydb;host=$myhost",
                { user => "$myuser", password => "$mypassword", table => 'redlist', create => 0 };
        };
        if ($EVAL_ERROR) {
            &printlog("redlist mysql error: $@");
            $CanUseTieRDBM = 0;
            $redlistdb     = "redlist";
        }
    }
    elsif ($DoNotCollectRed) {
        if ( -e $redlistdb ) { $RedlistObject = tie( %Redlist, 'orderedtie', "$redlistdb" ); }
    }
    return;
} ## end sub createlistobjects

sub generatescores {
    my ( $t, $s, @result, $pair, $v );
    &printlog("\nGenerating weighted Bayesian tuplets...");
    open( $spamdbFile, '>', "$spamdb.tmp" ) || die "unable to open $spamdb.tmp: $!\n";
    binmode $spamdbFile;
    print { $spamdbFile } "\n";
    while ( ( $pair, $v ) = each(%spam) ) {
        ( $s, $t ) = split( q{ }, $v );
        $t = ( $t - $s ) * $norm + $s;    # normalize t
        if ( $t < 5 ) {

            #$unknowns+=$s; $unknownt+=$t;
            next;
        }

        # if token represents all spam or all ham then square its value
        if ( $s == $t || $s == 0 ) {
            $s = $s * $s;
            $t = $t * $t;
        }
        $v = ( 1 + $s ) / ( $t + 2 );
        $v = sprintf( "%.7f", $v );
        $v = '0.9999999' if $v >= 1;
        $v = '0.0000001' if $v <= 0;
        push( @result, "$pair\002$v\n" ) if abs( $v - .5 ) > .09;
    }
    &printlog("done\n");
    undef %spam;    # free some memory
    &printlog("\nSaving rebuilt SPAM database...");
    for ( sort @result ) { print { $spamdbFile } $_; }
    close $spamdbFile;
    if ( -e "$spamdb.bak" ) { unlink("$spamdb.bak") || &printlog("unable to remove '$spamdb.bak' $!\n") }
    if ( -e $spamdb ) {
        rename( $spamdb, "$spamdb.bak" ) || &printlog("unable to rename '$spamdb' to '$spamdb.bak' $!\n");
    }
    rename( "$spamdb.tmp", $spamdb ) || &printlog("unable to rename '$spamdb.tmp' to '$spamdb' $!\n");
    &printlog("done\n");
    my $filesize = -s "$spamdb";
    &printlog( "\nResulting file '$spamdbFname' is " . commify($filesize) . " bytes\n" );
    my $pairs = scalar @result;
    &printlog( "Bayesian Pairs: " . commify($pairs) . "\n" );
    return;
} ## end sub generatescores


sub createheloblacklist {
    my (@Helo);
    open( my $FheloBlack, '>', "$spamdb.helo.tmp" ) || &printlog("unable to open '$spamdb.helo.tmp' $!\n");
    binmode $FheloBlack;
    print { $FheloBlack } "\n";
    while ( my ( $helostr, $weights ) = each(%Helo) ) {
        $weights->[1] = 0 if ( !defined $weights->[1] );
        $weights->[0] = 0 if ( !defined $weights->[0] );
        if ( $weights->[1] / ( $weights->[0] + $weights->[1] + .1 ) > .98 ) { push( @Helo, "$helostr\0021\n" ); }
    }
    print { $FheloBlack } sort @Helo;
    close $FheloBlack;
    &printlog( "\nHELO Blacklist: " . scalar(@Helo) . " HELOs\n" );
    if ( -e "$spamdb.helo.bak" ) {
        unlink("$spamdb.helo.bak") || &printlog("unable to remove '$spamdb.helo.bak' $!\n");
    }
    if ( -e "$spamdb.helo" ) {
        rename( "$spamdb.helo", "$spamdb.helo.bak" )
            || &printlog("unable to rename '$spamdb.helo' to '$spamdb.helo.bak' $!\n");
    }
    rename( "$spamdb.helo.tmp", "$spamdb.helo" )
        || &printlog("unable to rename '$spamdb.helo.tmp' to '$spamdb.helo' $!\n");
    return;
}

sub loadconfig {
    open( my $confFile, '<', "$base/assp.cfg" ) || die "cannot open \"$base/assp.cfg\": $!";
    local $/;
    my %Config = split( /:=|\n/, <$confFile> );

    close $confFile or die "unable to close: $!";
    $TrashObject       = tie %Trashlist,   'orderedtie', "$base/trashlist.db";
    
    $DoDropList     	 = $Config{ DoDropList };
    $runAsUser			 = $Config{ runAsUser };
    $runAsGroup			 = $Config{ runAsGroup };
    $correctednotspam    = $Config{ correctednotspam } && "$Config{base}/$Config{correctednotspam}" || 'errors/notspam';
    $correctedspam       = $Config{ correctedspam } && "$Config{base}/$Config{correctedspam}" || 'errors/spam';
	$incomingOkMail      		 = $Config{ incomingOkMail } && "$Config{base}/$Config{incomingOkMail}" || 'okmail';
    $DoNotCollectRed     = $Config{ DoNotCollectRed };
    $DoNotCollectRedRe   = $Config{ DoNotCollectRedRe };
    $DoNotCollectRedList = $Config{ DoNotCollectRedList };
    $KeepWhitelistedSpam = $Config{ KeepWhitelistedSpam };
    $logfile             = $Config{ logfile } && "$Config{base}/$Config{logfile}" || 'maillog.txt';
	$Log                 = $Config{ logfile } && "$Config{base}/$Config{logfile}" || 'maillog.txt';
    $maillogExt          = $Config{ maillogExt };
    $MaxBytes            = $Config{ MaxBytes };
    $MaxFiles            = $Config{ MaxFiles };
    
    $MaxWhitelistDays    = $Config{ MaxWhitelistDays } || 90;
    $MaxCorrectedDays    		= $Config{ MaxCorrectedDays } || 1000;
    $MaxNoBayesFileAge	 		= $Config{ MaxNoBayesFileAge } || 30; 
    $MaxBayesFileAge	 		= $Config{ MaxBayesFileAge };
    $MaintBayesCollection	 	= $Config{ MaintBayesCollection } || 1;
    $maintbayescollection		= $MaintBayesCollection;
    $MaxWhitelistLength  	= $Config{ MaxWhitelistLength } || 60;
    $MaxKeepDeleted  		= $Config{ MaxKeepDeleted } || 30;
    $notspamlog          	= $Config{ notspamlog } && "$Config{base}/$Config{notspamlog}" || 'notspam';
    $npRe                = $Config{ npRe };
    $OrderedTieHashSize  = $Config{ OrderedTieHashSize } || 10_000;
    $pbdbfile            = $Config{ pbdb };
    
    $proxyserver         = $Config{ proxyserver };
    $proxyuser			 = $Config{ proxyuser };	
    $proxypass			 = $Config{ proxypass };
    $resendmail			 = $Config{ resendmail };
    $redlistdb           = $Config{ redlistdb } && "$Config{base}/$Config{redlistdb}" || 'redlist';
    $redRe               = $Config{ redRe };
	$myName				 = $Config{ myName };
    $setFilePermOnStart	 = $Config{ setFilePermOnStart };
    $spamdb              = $Config{ spamdb } && "$Config{base}/$Config{spamdb}" || 'spamdb';
    $spamdbFname         = $Config{ spamdb } || 'spamdb';
    $spamdberrorFname    = $spamdbFname.'error';
    $spamdberror    	 = $spamdb.'error';
    $spamlog             = $Config{ spamlog } && "$Config{base}/$Config{spamlog}" || 'spam';
    $discarded           = $Config{ discarded } && "$Config{base}/$Config{discarded}" || 'discarded';
	$viruslog            = $Config{ viruslog } && "$Config{base}/$Config{viruslog}" || 'viruslog';
    $usesubject          = $Config{ UseSubjectsAsMaillogNames };
    $whitelistdb         = $Config{ whitelistdb } && "$Config{base}/$Config{whitelistdb}" || 'whitelist';
	$griplist			 = $Config{ griplist };
	$DropList            = $Config{ DropList } || 'file:files/droplist.txt';
	($DropList) 		 = $DropList =~ /^ *file: *(.+)/i if $DropList =~ /^ *file:/;
    $noGriplist    		 = $Config{ noGriplist };
	$noGriplistUpload    = $Config{ noGriplistUpload };
	$noGriplistDownload  = $Config{ noGriplistDownload };
    $asspLog             = $Config{ asspLog };
    $whiteRe             = $Config{ whiteRe };
    $wildcardUser        = $Config{ wildcardUser };
    $mydb                = $Config{ mydb };
    $myhost              = $Config{ myhost };
    $myuser              = $Config{ myuser };
    $mypassword          = $Config{ mypassword };
    $rebuildrun          = &fixPath($base) . "/rebuildrun.txt";
    $EmailAdminReportsTo = $Config{ EmailAdminReportsTo };
    $RebuildNotify		 = $Config{ RebuildNotify };


    $autoCorrectCorpus	 = $Config{ autoCorrectCorpus } || "1";


	$minimumfiles = 10000 if !$minimumfiles;
	$minimumfiles = 5000 if  $minimumfiles < 5000;
	$minimumdays = 14 if !$minimumdays;
	$minimumdays = 7 if  $minimumdays < 7;
	
    $EmailFrom		 	 = $Config{ EmailFrom };
    $RegExLength         = $Config{ RegExLength };
    $UseLocalTime        = $Config{ UseLocalTime };
    $LogDateFormat		 = $Config{ LogDateFormat } || "MMM-DD-YY hh:mm:ss";
	
    $DoFullGripDownload  = $Config{ DoFullGripDownload };

    return;
} ## end sub loadconfig

sub processfolder {
    my ( $fldrType, $fldrpath, $filter, $weight, $sub ) = @_;
    my ( $count, $processFolderTime, $folderStartTime, $fileCount, @files );
    our ( $WhiteCount, $RedCount );
    $folderStartTime = time;
    $fldrpath        = &fixPath($fldrpath);
    &printlog( "\n" . $fldrpath . "\n" );
    $fldrpath .= "/*";
    $fileCount = &countfiles($fldrpath);
    &printlog( "File Count:\t" . commify($fileCount) );
    &printlog("\nProcessing...");
    $count = $WhiteCount = 0;
    @files = glob($fldrpath);
    my $importmaxfiles = $MaxFiles;

	my $percent;


	my $filenum;




    
    #while( glob($fldrpath) && $count <= $MaxFiles ) {
    foreach my $file (@files) {
    	
        &add( $fldrType, $file, $weight, $sub );
        last if  ($spamlogcount && $autoCorrectCorpus && !$fldrType && $SpamWordCount && ($HamWordCount * $autoCorrectCorpus) > $SpamWordCount);
        $count++;
        last if $count >= $importmaxfiles;    #too many files
    }
    if   ( time - $folderStartTime != 0 ) { $processFolderTime = time - $folderStartTime; }
    else                                  { $processFolderTime = 1; }
    $count = $count - $WhiteCount ;


    if ($WhiteCount) {
        &printlog( "\nRemoved White:\t" . commify($WhiteCount) );
    }

    &printlog( "\nImported Files:\t" . commify($count) );
    &printlog( "\nImported SpamWordCount(total):\t" . commify($SpamWordCount) );
    &printlog( "\nImported HamWordCount(total):\t" . commify($HamWordCount) );
	

    if ( $count  > $MaxFiles ) {
        $maintbayescollection = 1;
    }

    #&printlog( "\n " . commify($SpamWordCount) . " spam weight \n " . commify($HamWordCount) . " non-spam weight." );
    &printlog("\nFinished in $processFolderTime second(s)\n");
    
    return $count;
} ## end sub processfolder

sub countfiles {
    my ($fldrpath) = @_;
    my @fileCount = glob("$fldrpath");
    return scalar(@fileCount);
}

sub commify {
    local $_ = shift;
    1 while s/^([-+]?\d+)(\d{3})/$1,$2/;
    return $_;
}

sub hash {
    my ($msgText) = @_;

    my ( $head, $body );

    # creates a md5 hash of $msg body
    if ( $msgText =~ /^(.*?)\n\r?\n(.*)/s ) {

        $head = $1;
        $body = $2;

        return md5_hex($body);
    }
    else {

        #return q;
        #There is no split, the message has no valid body
        return md5_hex($msgText);
    }

    #return $value;
    return;
}

sub dospamhash {
    my ( $FileName, $msgText ) = @_;
    $SpamHash{ &hash($msgText) } = '1';
    return;
}

sub dohamhash {
    my ( $FileName, $msgText ) = @_;
    $HamHash{ &hash($msgText) } = q{};
    return;
}

sub checkspam {
    my ( $FileName, $msgText ) = @_;
    our $HamHash;
    $msgText = &hash($msgText);
    my ( $return, $reason );
    if ( defined( $HamHash{ $msgText } ) ) {

        # we've found a message in the spam database that is the same as one in the corrected Ham group
        my $fn = shift;
        &deletefile( $fn, "found in $correctednotspam" );
        return 1;
    } elsif ( $reason = &redlisted( $_[1] ) ) {
        my $fn = shift;
        &deletefile( $fn, $reason );
        return 1;

    } elsif ( $reason = &whitelisted( $_[1] ) ) {
        my $fn = shift;
        &deletefile( $fn, $reason );
        return 1;
    }
    return 0;
}

sub checkham {
    my ( $FileName, $msgText ) = @_;
    our $SpamHash;
    my ( $return, $reason );
    $msgText = &hash($msgText);
    if ( defined( $SpamHash{ $msgText } ) ) {

        # we've found a message in the ham database that is the same as one in the corrected spam group
        my $fn = shift;
        &deletefile( $fn, "found in $correctedspam" );
        return 1;

    }
    return 0;
}

sub getrecontent {
    my ( $value, $name ) = @_;
    my $fromfile = 0;
    if ( $value =~ /^ *file: *(.+)/i ) {

        # the option list is actually saved in a file.
        $fromfile = 1;
        my $fil = $1;
        $fil = "$base/$fil" if $fil !~ /^\Q$base\E/i;
        local $/;
        if ( open( my $File, '<', $fil ) ) {
            $value = <$File>;

            # clean off comments
            $value =~ s/#.*//g;

            # replace newlines (and the whitespace that surrounds them) with a |(pipe character)
            $value =~ s/\s*\n\s*/|/g;
            close $File;
        }
        else { $value = q{}; }
    }
    $value =~ s/\|\|/\|/g;
    $value =~ s/\s*\|/\|/g;
    $value =~ s/\|\s*/\|/g;
    $value =~ s/\|\|+/\|/g;
    $value =~ s/^\s*\|?//;
    $value =~ s/\|?\s*$//;
    $value =~ s/\|$//;
    return $value;
} ## end sub getrecontent

sub batv_remove_tag {
    my $mailfrom = shift;
    
    if ($mailfrom =~ /^(prvs=.*=)(.*)/o) {
	
        $mailfrom = lc $2;
       
    }
    return $mailfrom;
}

sub whitelisted {
    return 0 if $KeepWhitelistedSpam;
    my $m = shift;
    my $curaddr;
    my %seen;


    $m =~ s/\n\r?\n.*//s;    # remove body
    while ( $m =~ 	/(?:from|sender|reply-to|errors-to|envelope-from|list-\w+):($HeaderValueRe)/igo) {
    	my $s = $1;

    	if ($s !~ /($EmailAdrRe\@$EmailDomainRe)/io) {
    		next;
    	} else {
            $curaddr = batv_remove_tag($1);

   		}
        
        if ( exists $seen{ $curaddr } ) {

            next;                #we already checked this address
        } else { 
        	$seen{ $curaddr } = 1; 
        }
        
        if ( $Whitelist{ $curaddr } ) {
            my $reason = $curaddr;
            $reason =~ s/\s+$/ /g;
            $reason =~ s/[\r\n]/ /g;
            our $WhiteCount++;
            return ( " -- '$reason' is in Whitelist");
        }
        if ($wildcardUser) {
            my ( $mfdd, $alldd, $reason );
            $mfdd = $1 if $curaddr =~ /(\@.*)/;
            $alldd = "$wildcardUser$mfdd";
            if ( $Whitelist{ lc $alldd } ) {
                $reason = $curaddr;
                $reason =~ s/\s+$/ /g;
                $reason =~ s/[\r\n]/ /g;
                our $WhiteCount++;
                return ( " -- '$reason' is in Whitelist ($wildcardUser)");
            }
        }
    } ## end while ( $m =~ /($EmailAdrRe\@$EmailDomainRe)/igo)
    return 0;
} ## end sub whitelisted

sub redlisted {
    my $m = shift;
    my (%seen);
	my $isasspheader;

    if ( $DoNotCollectRedList) {    
        $m =~ s/\n\r?\n.*//s;                            # remove body
        while ( $m =~ /($EmailAdrRe\@$EmailDomainRe)/igo ) {
            my $curaddr = lc($1);

            #$curaddr = lc( $1 . $2 );
            if ( exists $seen{ $curaddr } ) {
                next;                                    #we already checked this address
            }
            else { $seen{ $curaddr } = 1; }
            if ( $Redlist{ $curaddr } ) {
                my $reason = $curaddr;
                $reason =~ s/\s+$/ /g;
                $reason =~ s/[\r\n]/ /g;
                our $RedCount++;
                return ( " -- '$reason' is in Redlist");
            }
        }
    }
    return 0;
} ## end sub redlisted

sub deletefile {
    my ( $fn, $reason, $nolog ) = @_;

	if ( -e $fn ) {
        	if ( -w $fn || -W $fn ) {
            	&printlog( "\nremoving " . $fn . q{ } . $reason );
            	if ($MaxKeepDeleted) {
    				$Trashlist{$fn}=time;
    			} else {
            	
            		my $discardfn = $fn;
            		$discardfn =~ s/$spamlog/$discarded /g;
            		copy( $fn, $discardfn );
            		if ($!) {
            			printlog( "\n unable to copy file $fn to $discardfn for: $!");
            		} else {
            		 	&printlog( "\nmoving $fn to $discardfn");
            			unlink($fn);
            		}
            	}
        	} else { 
        		printlog( "\ncannot delete " . $reason . " message " . $fn . ": file is not writable: $!" ) ; 
			}
	} else { 
    		printlog( "\ncannot delete " . $reason . " message " . $fn . ": $!" ) if !$nolog; 
    }
    
 
}

sub getfile {
    my ( $fn, $sub ) = @_;
    my $message;
    my $count;
    my $numreadchars;
    return if exists $Trashlist{$fn};
    open( my $file, '<', "$fn" ) || return;
	
#	my $dtime=(stat($fn))[9]-time;
	
#    return if $dtime > 0;
    # Maxbytes or 10000, whichever is less
    $numreadchars = $MaxBytes <= 10_000 ? $MaxBytes : 10_000;
    $count = read( $file, $message, $numreadchars );    # read characters into memory
    close $file;
    return if $sub->( $fn, $message );                  # have i read this before?

    return $message;
}

sub add {
    my ( $isspam, $fn, $factor, $sub ) = @_;
    
    return if -d $fn;
    my ( $curHelo, $CurWord, $PrevWord, $sfac, $tfac );
    $PrevWord = $CurWord = q{};
    my $content = &getfile( $fn, $sub );
    return unless $content;
    if ( $content =~ /helo=(.*?)\)/i ) {
        $curHelo = lc($1);
        if ( $Helo{ $curHelo } ) { $Helo{ $curHelo }->[$isspam] += $factor; }
        else {    #it doesn't seem to exist. create it.
            $Helo{ $curHelo }->[$isspam] = $factor;
        }
    }
    my $OK;
    ($content,$OK) = &clean($content);
    while ( $content =~ /([-\$A-Za-z0-9\'\.!\240-\377]{2,})/g ) {
        if  ($spamlogcount && $autoCorrectCorpus && !$isspam && $SpamWordCount && ($HamWordCount * $autoCorrectCorpus) > $SpamWordCount) {
        
        return; 
        }
        if ( length($1) > 20 || length($1) < 2 ) { next }
        $PrevWord = $CurWord;

		$CurWord  = BayesWordClean($1);
  
        if ( !$PrevWord ) { next }  # We only want word pairs
        if ( length($CurWord) < 2 || length($PrevWord) < 2 ) { next }    # too short after cleaning

        # increment global weights, they are not really word counts
        if   ($isspam) { $SpamWordCount += $factor; }
        else           { $HamWordCount  += $factor; }
        if ( exists( $spam{ "$PrevWord $CurWord" } ) ) {
            ( $sfac, $tfac ) = split( q{ }, $spam{ "$PrevWord $CurWord" } );
        }
        else {

            # the pair does not exist, create it
            $spam{ "$PrevWord $CurWord" } = "0 0";
            ( $sfac, $tfac ) = split( q{ }, $spam{ "$PrevWord $CurWord" } );
        }
        $sfac += $isspam ? $factor : 0;
        $tfac += $factor;
        $spam{ "$PrevWord $CurWord" } = "$sfac $tfac";
    } ## end while ( $content =~ /([-\$A-Za-z0-9\'\.!\240-\377]{2,})/g)
    return;
} ## end sub add

sub Umlaute {
	my $string = shift;
	my %umlaute = ("ä" => "ae", "Ä" => "Ae", "ü" => "ue", "Ü" => "Ue", "ö" => "oe", "Ö" => "Oe", "ß" => "ss" );
	my $umlautkeys = join ("|", keys(%umlaute));
	$string =~ s/($umlautkeys)/$umlaute{$1}/g;
	return $string;
} ##

sub BayesWordClean {
    my $word = lc(shift);
    $word =~ s/#(?:[a-f0-9]{2})+/randcolor/go;
    $word =~ s/^#\d+/randdecnum/go;

    $word =~ s/[_\[\]\~\@\%\$\&\{\}<>#(),.'";:=!?*+\/\\\-]+$//o;
    $word =~s/^[_\[\]\~\@\%\$\&\{\}<>#(),.'";:=!?*+\/\\\-]+//o;
    $word =~ s/!!!+/!!/go;
    $word =~ s/\*\*+/**/go;
    $word =~ s/--+/-/go;
    $word =~ s/__+/_/go;
    $word =~ s/[\d,.]{2,}/randnumber/go;
    $word =~ s/^[\d:\.\-+();:<>,!"'\/%]+(?:[ap]m)?$/randwildnum/o;    # ignore numbers , dates, times, versions ...
#    $word = &Umlaute($word);

    return if length($word) > 20 or length($word) < 2;
    return $word;
}
# clean up source email
sub clean {
    my $m = shift;

    my $msg = ref($m) ? $$m : $m;
    my $t = time + 15;     # max 15 seconds for this cleaning
    my $body;
    my $header;
    my $undec = 1;



    local $_= "\n". (($header) ? $header : $msg);
    my ($helo,$rcpt);
    if ($header) {
        ($helo)=/helo=([^)]+)\)/io;
        $helo=~s/(\w+)/ hlo $1 /go if length($helo) > 19; # if the helo string is long, break it up
        $rcpt="rcpt ".join(" rcpt ",/($EmailAdrRe\@$EmailDomainRe)/go);
        return "helo: $helo\n$rcpt\n",0 if (time > $t);
        # mark the subject
        $rcpt .= "\n".fixsub($1) if /\nsubject: (.*)/io;
        return "helo: $helo\n$rcpt\n",0 if (time > $t);
    }

    # from now only do the body if possible
    local $_ = $body if $body;

    # replace &#ddd encoding
    s/\&\#(\d{1,5})\;?/chr($1)/geo;
    s/\&\#x(\d{1,4})\;?/chr(hex($1))/geo;
    s/([^\\])?[%=]([0-9A-F]{2})/$1.chr(hex($2))/gieo; # replace url encoding
    return "helo: $helo\n$rcpt\n",0 if (time > $t);

    if ($undec) {
      # replace base64 encoding
      s/\n([a-zA-Z0-9+\/=]{40,}\r?\n[a-zA-Z0-9+\/=\r\n]+)/base64decode($1)/gseo;
      return "helo: $helo\n$rcpt\n",0 if (time > $t);

      # clean up quoted-printable references
      s/(Subject: .*)=\r?\n/$1\n/o;
      return "helo: $helo\n$rcpt\n",0 if (time > $t);
      s/=\r?\n//go;
      return "helo: $helo\n$rcpt\n",0 if (time > $t);
      # strip out mime continuation
      s/.*---=_NextPart_.*\n//go;
      return "helo: $helo\n$rcpt\n",0 if (time > $t);
    }

    # clean up MIME quoted-printable line breakings
    s/=\r?\n//gos;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);

    # clean up &nbsp; and &amp;
    s/&nbsp;?/ /gio; s/&amp;?/and/gio;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);
    s/(\d),(\d)/$1$2/go;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);
    s/\r//go; s/ *\n/\n/go;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);
    s/\n\n\n\n\n+/\nblines blines\n/go;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);

    # clean up html stuff
    s/<\s*script[^>]+>.*?<\s*\/\s*script\s*>/ jscripttag /igos;
    s/<\s*script[^>]+>/ jscripttag /igos;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);
    # remove style sheets
    s/<\s*style[^>]*>.*?<\s*\/\s*style\s*>//igso;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);

#    while (s/(\w+)(<[^>]*>)((?:<[^>]*>)*\w+)/$2$1$3/go){return "helo: $helo\n$rcpt\n",0 if (time > $t);} # move html out of words
    s/<\s*(?:[biu]|strong)\s*>/ boldifytext /gio;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);

    # remove some tags that are not informative
    s/<\s*\/?\s*(?:p|br|div|t[drh]|li|[uo]l|center)[^>]*>/\n/gios;
    s/<\s*\/?\s*(?:[biuo]|strong)\s*>//gio;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);
    s/<\s*\/?\s*(?:html|meta|head|body|span|table|font|col|map)[^>]*>//igos;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);
    s/(<\s*a\s[^>]*>)(.*?)(<\s*\/a\s*>)/$1.fixlinktext($2)/igseo;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);

    # treat titles like subjects
    s/<\s*title[^>]*>(.*?)<\s*\/\s*title\s*>/fixsub($1)/igeos;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);

    # remove html comments
    s/<\s*!.*?-->//gso; s/<\s*![^>]*>//go;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);

    # look for random words
    s/[ a-z0-9][ghjklmnpqrstvwxz_]{2}[bcdfghjklmnpqrstvwxz_0-9]{3}\S*/ randword /gio;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);

    # remove mime separators
    s/\n--.*?randword.*//go;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);

    # look for linked images
    s/(<\s*a[^>]*>[^<]*<\s*img)/ linkedimage $1/giso;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);
    s/<[^>]*href\s*=\s*("[^"]*"|\S*)/fixhref($1)/isgeo;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);
    s/(?:ht|f)tps?:\/\/(\S*)/fixhref($1)/isgeo;
    return "helo: $helo\n$rcpt\n",0 if (time > $t);
    s/(\S+\@\S+\.\w{2,5})\b/fixhref($1)/geo;
    s/<?\s*img .{0,50}src\s*=\s*['"]([^'"]*)['"][^>]+>/$1/gois;
    s/["']\s*\/?s*>|target\s*=\s*['"]_blank['"]|<\s*\/|:\/\/ //go;
    s/ \d{2,} / 1234 /go;


    return ("helo: $helo\n$rcpt\n$_",1);

}

sub cleanwhite {
    &printlog("\n---Cleaning whitelist ($whitelistdb)---\n");
   
    &printlog( "whitelist entries older than " . $MaxWhitelistDays . " days (MaxWhitelistDays) will be removed\n" );
    my $calcTime = time - 24 * 3600 * $MaxWhitelistDays;
    
    my $wlbefore = 0;
    my $wlafter = 0;
    if ( !( $whitelistdb =~ /mysql/ ) ) {
        if ( open( F, "<", "$whitelistdb" ) ) {
            binmode(F);
	    $_ = <F>; # ignore blank line at start of file
            my $nwhite;
            local $/ = "\n";
            $nwhite = "\n";
            while (<F>) {
                chomp;
                $wlbefore++;
                my ( $adr, $time ) = split( "\002", $_ );
                next if ( !$time || !$adr );
                $adr =~ s/^\'//g;
                $adr =~ s/^\"//g;
                $adr = batv_remove_tag($adr);
                next if ($adr =~ m/^'/);    #skip addresses with leading ' chars
                next if $calcTime > $time || length($adr) > $MaxWhitelistLength;
                $nwhite .= "$adr\002$time\n";
                $wlafter++;
            }
            close F;

                unlink "$whitelistdb.bak";
                rename( $whitelistdb, "$whitelistdb.bak" );
                open( O, ">", "$whitelistdb" );
                binmode(O);
                print O $nwhite;
                close O;           
          
        }
    } ## end if ( !( $whitelistdb =~...
    else {
        my %Whitelist;
        my $WhitelistObject;
        eval {
            $WhitelistObject = tie %Whitelist, 'Tie::RDBM', "dbi:mysql:database=$mydb;host=$myhost",
                { user => "$myuser", password => "$mypassword", table => 'whitelist', create => 0 };
        };
        if ($EVAL_ERROR) {
            &printlog("whitelist mysql error: $@");
            $CanUseTieRDBM = 0;
            $whitelistdb   = "whitelist";
        }
        $wlbefore = scalar keys %Whitelist;
        $wlafter  = $wlbefore;
        while ( my ( $key, $value ) = each %Whitelist ) {

            #my $date1 = localtime($value); #debugging stuff
            #my $date2 = localtime($calcTime);
            #print "$key=$value\n";
            if ( $value < $calcTime || length($key) > $MaxWhitelistLength ) {
                if ( $Whitelist{ $key } ) {
                    delete $Whitelist{ $key };
                    $wlafter--;
                }
            }
        }
        $WhitelistObject->flush() if $WhitelistObject && $whitelistdb !~ /mysql/;

        #untie %Whitelist;
    } ## end else [ if ( !( $whitelistdb =~...
    &printlog( "whitelist before: " . commify($wlbefore) . "\n" );
    &printlog( "whitelist after:  " . commify($wlafter) . "\n" );
    return;
} ## end sub cleanwhite

sub dayofweek {

    # this is mercilessly hacked from John Von Essen's Date::Day
    my ( $d, $m, $y ) = $_[0] =~ /(\S+) +(\S+) +(\S+)/;

    # data for DayOfWeek function
    my %Months = (
        'Jan', 1, 'Feb', 2, 'Mar', 3, 'Apr', 4,  'May', 5,  'Jun', 6,
        'Jul', 7, 'Aug', 8, 'Sep', 9, 'Oct', 10, 'Nov', 11, 'Dec', 12,
    );
    my %Month = ( 1, 0, 2, 3, 3, 2, 4, 5, 5, 0, 6, 3, 7, 5, 8, 1, 9, 4, 10, 6, 11, 2, 12, 4, );
    my %Weekday = ( 0, 'srdSUN', 1, 'srdMON', 2, 'srdTUE', 3, 'srdWED', 4, 'srdTHU', 5, 'srdFRI', 6, 'srdSAT', );
    $y += 2000;
    $m = $Months{ $m };
    if ( $m <= 2 ) { $y--; }
    my $wday = ( ( $d + $Month{ $m } + $y + ( int( $y / 4 ) ) - ( int( $y / 100 ) ) + ( int( $y / 400 ) ) ) % 7 );
    return $Weekday{ $wday };
}
sub fixhref     { my $t = shift; $t =~ s/(\w+)/ href $1 /g; return $t; }
sub fixlinktext { my $t = shift; $t =~ s/(\w+)/atxt $1/g;   return $t; }

sub fixurl {
    my $a = shift;
    $a =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack('C',hex($1))/ge;
    return $a;
}

sub fixsub {
    my $s = shift;

    #print "$s=>";
    $s =~ s/ {3,}/ lotsaspaces /g;
    $s =~ s/(\S+)/ssub $1/g;

    #print "$s\n";
    return "\n$s ssub";
}

sub base64decode {
    my $str = shift;
    my $res = "\n\n";
    $str =~ tr|A-Za-z0-9+/||cd;
    $str =~ tr|A-Za-z0-9+/| -_|;
    while ( $str =~ /(.{1,60})/gs ) {
        my $len = chr( 32 + length($1) * 3 / 4 );
        $res .= unpack( "u", $len . $1 );
    }
    return $res;
}

sub printlog {
    return if $silentlog;
    my ( $text, $format ) = @_;
    if ( !$format ) {
        print "$text" unless $silent;
        print $RebuildLog "$text";
    }
    if ($format) {
        printf "$text", $format unless $silent;
        printf $RebuildLog "$text", $format;
    }
    return;
}
sub timestring {
    my ($time,$what) = @_;
    my @m = $time ? localtime($time) : localtime();
    my $tstr = $time ? scalar(localtime($time)) : scalar(localtime());
    my ($day,$month) = $tstr =~ /(...) (...)/;
    my $format = $LogDateFormat;
    if (lc $what eq 'd') {   # date only - remove time part from format
        $format =~ s/[^YMD]*(?:hh|mm|ss)[^YMD]*//g;
    } elsif (lc $what eq 't') { # time only - remove date part from format
        $format =~ s/[^hms]*(?:Y{2,4}|M{2,3}|D{2,3})[^hms]*//g;
    }
    $format =~ s/^[^YMDhms]//;
    $format =~ s/[^YMDhms]$//;
    $format =~ s/YYYY/sprintf("%04d",$m[5]+1900)/e;
    $format =~ s/YY/sprintf("%02d",$m[5]-100)/e;
    $format =~ s/MMM/$month/;
    $format =~ s/MM/sprintf("%02d",$m[4]+1)/e;
    $format =~ s/DDD/$day/e;
    $format =~ s/DD/sprintf("%02d",$m[3])/e;
    $format =~ s/hh/sprintf("%02d",$m[2])/e;
    $format =~ s/mm/sprintf("%02d",$m[1])/e;
    $format =~ s/ss/sprintf("%02d",$m[0])/e;

    return $format;
}

sub downloadGripConf {


    my $rc;

    my $griplistUrl = "http://downloads.sourceforge.net/project/assp/griplist/griplist.conf";
    my $file     = "$base/griplist.conf";

    $file		 = &fixPath($file);


    if ( !$CanUseLWP ) {
        &printlog("$file download failed: LWP::Simple Perl module not available\n");
        return;
    }

    if ( -e $file  ) {
        if ( !-r $file  ) {
            &printlog( "$file download failed: $file  not readable!\n" );
            return;
        } elsif ( !-w $file  ) {
            &printlog( "$file download failed: $file  not writable!\n" );
            return;
        }
    }
    else {
        if ( open( TEMPFILE, ">", $file ) ) {
            #we can create the file, this is good, now close the file and keep going.
            close TEMPFILE;
	    unlink($file);
        } else {
            &printlog("$file download failed: Cannot create $file - $!\n" );
            return;
        }
    }

    # Create LWP object
    use LWP::Simple qw(mirror is_success status_message $ua);

    # Set useragent to Rebuild version
    $ua->agent(
        "rebuildspamdb/$VERSION ($^O; Perl/$]; LWP::Simple/$LWP::VERSION)");
    $ua->timeout(20);
    if ($proxyserver) {
        $ua->proxy( 'http', "http://" . $proxyserver );

    } else {
  
    }

    # call LWP mirror command
    $rc = mirror( $griplistUrl, $file );

    if ( $rc == 304 ) {
        # HTTP 304 not modified status returned
        return;
    } elsif ( !is_success($rc) ) {
        #download failed-error code output to logfile
        &printlog("$file download failed: $rc " . status_message($rc). "\n" );
        return;
    } elsif ( is_success($rc) ) {
        # download complete
        my $filesize = -s "$file";
        &printlog("$file download complete: $filesize bytes\n" );
        chmod 0644, "$file";
    }
    my $ret = $rc;
#    &printlog("info: updated GRIPLIST upload and download URL's in $file\n") if $ret;
    $ret = 0;
    open my $GC , '<', $file or return 0;
    binmode $GC;
    while (<$GC>) {
        s/\r|\n//o;
        if (/^\s*(gripList(?:DownUrl|UpUrl|UpHost))\s*:\s*(.+)$/) {
            ${$1} = $2;
            $ret++;
        }
    }
    close
#    &printlog("info: loaded GRIPLIST upload and download URL's from $file\n") if $ret;
    &printlog("info: GRIPLIST config $file is possibly incomplete\n") if $ret < 3;
    $gripListDownUrl =~ s/\*HOST\*/$gripListUpHost/o;
    $gripListUpUrl  =~ s/\*HOST\*/$gripListUpHost/o;
    return $ret;
}


sub uploadgriplist {
    local $/ = "\n";

    #&printlog("Start building Griplist \n");
    open( my $FLogFile, '<', "$Log" ) || &printlog("Unable to create Griplist.\n unable to open logfile '$Log': $!\n");
    my ( $date, $ip, $ipnet, %m, %ok, %locals, $match, $peeraddress, $hostaddress, $connect, $day, $gooddays, $st );
    my $buf;
	my $iday;
    #build list of the last 2 days
    my $time = Time::HiRes::time();
    my $dayoffset = $time % ( 24 * 3600 );
    
    for ( my $i = 0 ; $i < 2 ; $i++ ) {
        $gooddays .= '|' if ( $i > 0 );
        $day = localtime( $time - $i * 24 * 3600 );
        $day =~ s/^... (...) +(\d+) (\S+) ..(..)/$1-$2-$4/;
        $gooddays .= $day;
    }
    if ($LogDateFormat !~ /MMM-DD-YY/)  {
	$gooddays .= '|';
    for ( my $i = 0 ; $i < 2 ; $i++ ) {
        $gooddays .= '|' if ( $i > 0 );
        $day = &timestring( $time - $i * 24 * 3600 , 'd');
        $gooddays .= $day;
    }}

   
    undef $day;
    %locals = ( '127', 1, '10', 1, '192.168', 1, '169.254', 1, '::1', 1, 'fe80:', 1 );    #RFC 1918, IPv6
    for ( 16 .. 31 ) { $locals{ "172.$_" } = 1 }                                          #RFC 1918

    while (<$FLogFile>) {
        next unless ( $date, $ip, $match ) = /($gooddays) .*\s([0-9a-f\.:]+) .* to: \S+ (.*)/io;
	$ipnet = $ip;
	if ($ipnet =~ /:.*:/) {
		$ipnet =~ s/:.*/:/ if ($ipnet !~ /^:/);
        	next if $locals{ $ipnet };		# ignore local IP ranges
	}
	else {
		$ipnet =~ s/^(\d+\.\d+)\..*/$1/;
        	next if $locals{ $ipnet };		# ignore local IP ranges
		$ipnet =~ s/^(\d+)\..*/$1/;
        	next if $locals{ $ipnet };		# ignore local IP ranges
	}
	$ipnet = $ip;
	if ($ipnet =~ /:.*:/) {
		$ipnet =~ s/^([0-9a-f]+:[0-9a-f]+:[0-9a-f]+:[0-9a-f]*:).*/$1/i;	# yes: "+++*" so as to allow "2001:123:456::"
	}
	else {
		$ipnet =~ s/(\d+)\.(\d+)\.(\d+)\.(\d+)/$1.$2.$3/;
	}

        if (m/(\[Local]|\[MessageOK]|\[RWL]|\[Whitelisted])|\[NoProcessing]/i) {

            #Good IP
            $m{ $ipnet }  += 1;
            $ok{ $ipnet } += 1;
            next;
        }
        if (m/(Connection idle for|\[Backscatter]|\[Bayesian]|\[BlackDomain]|\[BlackHELO]|\[BombBlack]|\[BombData]|\[BombHeader]|\[BombRaw]|\[BombScript]|\[BombSender]|\[Collect]|\[Connection]|\[DNSBL]|\[DenyIP]|\[DenyStrict]|\[Extreme]|\[ForgedHELO]|\[ForgedLocalSender]|\[FromMissing]|\[IPfrequency]|\[IPperDomain]|\[InvalidHELO]|\[MalformedAddress]|\[MaxErrors]|\[MessageScore]|\[MissingMX]|\[MsgID]|\[OversizedHeader]|\[PTRinvalid]|\[PTRmissing]|\[PenaltyBox]|\[Penalty]|\[RelayAttempt]|\[SpoofedSender]|\[Trap]|\[URIBL]|\[VIRUS]|\[ValidHELO]|spam found|\[blocked\])/i) {

            #Bad IP
            $m{ $ipnet }  += 1;
            $ok{ $ipnet } += 0;
            next;
        }
    }
    close $FLogFile;
    if ( !%m ) {
        &printlog( "Skipping Griplist upload. Not enough messages processed.\n");
        return;
    }
    &printlog("Preparing binary Griplist upload...");
    my $n6 = 0;
    my $n4 = 0;
    my ($buf6, $buf4);
    foreach (keys %m) {
        next if (!$m{$_});
        if ($_ =~ /:/) {
            my $ip = $_;
            $ip =~ s/([0-9a-f]*):/0000$1:/gi;
            $ip =~ s/0*([0-9a-f]{4}):/$1:/gi;
            $buf6 .= pack("H4H4H4H4", split(/:/, $ip));
            $buf6 .= pack("C", (1 - $ok{$_} / $m{$_}) * 255);
            $n6++;
        } else {
            $buf4 .= pack("C3C", split(/\./, $_), (1 - $ok{$_} / $m{$_}) * 255);
            $n4++;
        }
    }
    $st = pack("N2", $n6 / 2**32, $n6);
    $st .= pack("N", $n4);
    $st .= $buf6 . $buf4;
    &printlog(" done\n");
    if ($proxyserver) {
        &printlog("Uploading Griplist via Proxy: $proxyserver\n");

        my $user = $proxyuser ? "$proxyuser:$proxypass\@": '';
        $peeraddress = $user . $proxyserver;
        $hostaddress = $proxyserver;
        $connect     = "POST $gripListUpUrl HTTP/1.0";
    } else {
        &printlog("Uploading Griplist via Direct Connection\n");
        $peeraddress = $gripListUpHost . ':80';
        $hostaddress = $gripListUpHost;
        my ($url) = $gripListUpUrl =~ /http:\/\/[^\/](\/.+)/oi;
        $connect     = <<"EOF";
POST $url HTTP/1.1
User-Agent: rebuildspamdb/$VERSION ($^O; Perl/$];)
Host: $gripListUpHost
EOF
    }
    my $socket = new IO::Socket::INET( Proto => 'tcp', PeerAddr => $peeraddress, Timeout => 2 );
    if ( defined $socket ) {
        my $len = length($st);
        $connect .= <<"EOF";
Content-Type: application/x-www-form-urlencoded
Content-Length: $len

$st
EOF
        print { $socket } $connect;
        $socket->sysread($buf, 4096);
        $socket->close;
        &printlog("Submitted $len bytes: $n6 IPv6 addresses, $n4 IPv4 addresses\n");
    }
    else {
        &printlog("unable to connect to assp.sourceforge.net to upload griplist\n");
        return;
    }
    return;
} ## end sub uploadgriplist

sub downloadgriplist {
    &printlog("Griplist download disabled\n")  if $noGriplist;
    return if $noGriplist;
    &printlog("Griplist file not configured\n")  if (!$griplist);
    return if (!$griplist);

    my $rc;

    my $gripListUrl = "http://assp.sourceforge.net/cgi-bin/assp_griplist?binary";
    my $gripFile    = "$base/$griplist";

    ## let's check if we really need to
    if (-e $gripFile) {
        my @s     = stat($gripFile);
        my $mtime = $s[9];
        if (time - $mtime < 8*60*60) {
            &printlog("Griplist download failed: last download too recent\n");
            return;
        }
    }

    # check for previous download timestamp, so we can do delta now
    my %lastdownload;
    $lastdownload{full} = 0;
    $lastdownload{fullUTC} = 0;
    $lastdownload{delta} = 0;
    $lastdownload{deltaUTC} = 0;
    my $delta = "";
    if (open(UTC, "$gripFile.utc")) {
        local $/;
        my $buf = <UTC>;
        close(UTC);
        chop($buf);
        if ($buf =~ /full/ && $buf =~ /delta/) {
            %lastdownload = split(/\s+|\n/, $buf);
        } else {
            $lastdownload{delta} = $buf;
        }
        if (! ($DoFullGripDownload && time - $lastdownload{fullUTC} > $DoFullGripDownload*24*60*60)) {
            my $lasttime;
            $lasttime = $lastdownload{full};
            $lasttime = $lastdownload{delta} if ($lastdownload{delta} > $lastdownload{full});
            $gripListUrl .= "&delta=$lasttime";
            $delta = " (delta)";
        }
    }

    if (!$CanUseLWP) {
        &printlog("Griplist download failed: LWP::Simple Perl module not available\n");
        return;
    }

    if (open(TEMPFILE, ">", "$gripFile.tmp")) {
        #we can create the file, this is good, now close the file and keep going.
        close TEMPFILE;
        unlink("$gripFile.tmp");
    } else {
        &printlog("Griplist download failed: Cannot create $gripFile.tmp\n");
        return;
    }

    # Create LWP ogject
    use LWP::Simple qw(mirror is_success status_message $ua);

    # Set useragent to Rebuild version
    $ua->agent("rebuildspamdb/$VERSION ($^O; Perl/$]; LWP::Simple/$LWP::VERSION)");
    $ua->timeout(20);
    if ($proxyserver) {
        $ua->proxy('http', "http://" . $proxyserver);
        &printlog("Downloading Griplist$delta via HTTP proxy: $proxyserver\n");
    } else {
        &printlog("Downloading Griplist$delta via direct HTTP connection\n");
    }

    # call LWP mirror command
    my $dltime = time;
    $rc = mirror($gripListDownUrl, "$gripFile.tmp");

    if ($rc == 304) {
        # HTTP 304 not modified status returned
        # can't happen - we ALWAYS get new data
        unlink("$gripFile.tmp");
        return;
    } elsif (!is_success($rc)) {
        # download failed-error code output to logfile
        # &printlog("Griplist download failed: $rc " . status_message($rc). "\n");
        unlink("$gripFile.tmp");
        return;
    }

    # download complete
    my $filesize = -s "$gripFile.tmp";
    &printlog("Griplist download complete: binary download $filesize bytes\n");

    # enough data?
    if ($filesize < 12) {
        &printlog("Griplist download error: grip data too small\n");
        unlink("$gripFile.tmp");
        return;
    }

    # record download time so we can do delta next time
    unlink("$gripFile.utc");
    if (open(UTC, ">$gripFile.utc")) {
        my ($sec, $min, $hour, $day, $mon, $year, $wday, $yday, $isdst) = gmtime($dltime);
        $year += 1900;
        $mon += 1;
        if (! $delta) {
            $lastdownload{full} = sprintf "%04d%02d%02d%02d%02d%02d", $year, $mon, $day, $hour, $min, $sec;
            $lastdownload{fullUTC} = $dltime;
        } else {
            $lastdownload{delta} = sprintf "%04d%02d%02d%02d%02d%02d", $year, $mon, $day, $hour, $min, $sec;
            $lastdownload{deltaUTC} = $dltime;
        }
        printf UTC "full\t%s\n", $lastdownload{full};
        printf UTC "fullUTC\t%s\n", $lastdownload{fullUTC};
        printf UTC "delta\t%s\n", $lastdownload{delta};
        printf UTC "deltaUTC\t%s\n", $lastdownload{deltaUTC};
        close(UTC);
    }

    # if we did a delta download, read in previous data so we can merge
    my @binFiles;
    push(@binFiles, "$gripFile.bin") if ($gripListUrl =~ /delta=/);
    push(@binFiles, "$gripFile.tmp");

    # convert binary download form to text form used by ASSP
    my $buf;
    my %grip;
    my $action = "read";
    foreach my $binF (@binFiles) {
        my $binSize = -s $binF;
        open(BIN, $binF);   
        binmode(BIN);
        read(BIN, $buf, $binSize);
        close(BIN);

    # IPv6 count
    	my ($n6h, $n6l) = unpack("N2", $buf);
    	my $n6 = $n6h * 2**32 + $n6l;

    # IPv4 count
    	my $n4;
    	eval { $n4 = unpack("x[N2] N", $buf); };


    # decode IPv6 data
    	my $x6 = 0;
    	eval {
    	for (my $i = 0; $i < $n6; $i++) {
        my ($bip, $grey) = unpack("x[N2] x[N] x$x6 a8 C", $buf);
        my $ip = join(":", unpack("H4H4H4H4", $bip)) . ":";
        $ip =~ s/:0+([0-9a-f])/:$1/gio;
        $ip =~ s/:0:$/::/o;

        #                $grip{$ip} = $grey / 255;
        #                $gripdelta{$ip} = $grey / 255 if $deltayonly;
        $x6 += 9;
    	}
    	};

    # decode IPv4 data
    	my $x4 = 0;
    	for (my $i = 0; $i < $n4; $i++) {
        my ($bip, $grey) = unpack("x[N2] x[N] x$x6 x$x4 a3 C", $buf);
        my $ip = join(".", unpack("C3", $bip));
        $grip{$ip} = $grey / 255;

        $x4 += 4;
    }
        &printlog("Griplist binary $action OK: $binF, $n6 IPv6 addresses, $n4 IPv4 addresses\n");
        $action = "merge";
    }

    # remove download file
    unlink("$gripFile.tmp");

    # output binary version, so we can do a delta next time
    &printlog("Writing merged Griplist binary...");
    my $buf;
    my $n6 = 0;
    my $n4 = 0;
    my ($buf6, $buf4);
    foreach my $ip (keys %grip) {
        if ($ip =~ /:/) {
            my $ip2 = $ip;
            $ip2 =~ s/([0-9a-f]*):/0000$1:/gi;
            $ip2 =~ s/0*([0-9a-f]{4}):/$1:/gi;
            $buf6 .= pack("H4H4H4H4", split(/:/, $ip2));
            $buf6 .= pack("C", int($grip{$ip} * 255));
            $n6++;
        } else {
            $buf4 .= pack("C3C", split(/\./, $ip), int($grip{$ip} * 255));
            $n4++;
        }
    }
    $buf = pack("N2", $n6/2**32, $n6);
    $buf .= pack("N", $n4);
    $buf .= $buf6 . $buf4;
    unlink("$gripFile.bin");
    open (BIN, ">$gripFile.bin");
    binmode(BIN);
    print BIN $buf;
    close(BIN);
    chmod 0644, "$gripFile.bin";
    &printlog(" done\n");

    # output text version
    &printlog("Writing merged Griplist text...");
    unlink("$gripFile");
    open (TEXT, ">$gripFile");
    binmode(TEXT);
    print TEXT "\n";
    foreach my $ip (sort keys %grip) {

        printf TEXT "$ip\002%.2f\n", $grip{$ip};
    }
    close(TEXT);
    chmod 0644, "$gripFile";
    &printlog(" done\n");

    &printlog("Griplist writing complete: $n6 IPv6 addresses, $n4 IPv4 addresses\n\n");
}


sub downloaddroplist {

	&printlog("Droplist download disabled\n\n")  if !$DoDropList;
	return if !$DoDropList;
    my $rc;

    my $droplistUrl = "http://www.spamhaus.org/drop/drop.lasso";
    my $dropFile     = "$base/$DropList";

    $dropFile		 = &fixPath($dropFile);

    # let's check if we really need to
    if (-e $dropFile) {
        my @s     = stat($dropFile);
        my $mtime = $s[9];
        my $random = int(rand(144-72)+72)+1; 
        if (time - $mtime < $random*60*60) {
        
            &printlog("Droplist download skipped: last download too recent\n");
            return;
        }
    }

    if ( !$CanUseLWP ) {
        &printlog("Droplist download failed: LWP::Simple Perl module not available\n");
        return;
    }

    if ( -e $dropFile  ) {
        if ( !-r $dropFile  ) {
            &printlog( "Droplist download failed: $dropFile  not readable!\n" );
            return;
        } elsif ( !-w $dropFile  ) {
            &printlog( "Droplist download failed: $dropFile  not writable!\n" );
            return;
        }
    }
    else {
        if ( open( TEMPFILE, ">", $dropFile ) ) {
            #we can create the file, this is good, now close the file and keep going.
            close TEMPFILE;
	    unlink($dropFile);
        } else {
            &printlog("Droplist download failed: Cannot create $dropFile \n" );
            return;
        }
    }

    # Create LWP ogject
    use LWP::Simple qw(mirror is_success status_message $ua);

    # Set useragent to Rebuild version
    $ua->agent(
        "rebuildspamdb/$VERSION ($^O; Perl/$]; LWP::Simple/$LWP::VERSION)");
    $ua->timeout(20);
    if ($proxyserver) {
        $ua->proxy( 'http', "http://" . $proxyserver );
        &printlog("Downloading $dropFile via HTTP proxy: $proxyserver\n" );
    } else {
        &printlog("Downloading $dropFile via direct HTTP connection\n" );
    }

    # call LWP mirror command
    $rc = mirror( $droplistUrl, $dropFile );

    if ( $rc == 304 ) {
        # HTTP 304 not modified status returned
        return;
    } elsif ( !is_success($rc) ) {
        #download failed-error code output to logfile
        &printlog("$dropFile download failed: $rc " . status_message($rc). "\n" );
        return;
    } elsif ( is_success($rc) ) {
        # download complete
        my $filesize = -s "$dropFile";
        &printlog("$dropFile download complete: $filesize bytes\n" );
        chmod 0644, "$dropFile";
    }
}

sub compileregex {
    use re 'eval';
    my ( $name, $contents, $REname ) = @_;
    $contents = getrecontent( $contents, $name );
    $contents ||= '^(?!)';    # regexp that never matches

    # trim long matches to 32 chars including '...' at the end
    eval { $$REname = qr/(?si)$contents/ };
    if ($EVAL_ERROR) { print "regular expression error in '$contents' for $name: $@\n"; }
    return q{};
}

sub optionList {

    # this converts a | separated list into a RE
    my ( $d, $configname ) = @_;
    $d = getrecontent( $d, $configname );
    $d =~ s/([\.\[\]\-\(\)\*\+\\])/\\$1/g;
    return $d;
}

sub fixPath {
    my ($path) = @_;
    my $len = length($path);
    if   ( !substr( $path, ( $len - 1 ), 1 ) eq q{/} ) { return $path . q{/}; }
    else                                               { return $path; }
    return;
}

sub repair {
    $/ = "\n";

    # mxa ptr rbl spf uribl white black
    my $pbdb = "$base/$pbdbfile";
    my ( @files, %w );
    my ( $k,     $v );
    if ( !( $pbdbfile =~ /mysql/ ) ) {
        foreach ( glob("$pbdb.*.db") ) { push( @files, $_ ); }
    }
    if ( !( $whitelistdb =~ /mysql/ ) ) { push( @files, $whitelistdb ); }
    if ( !( $redlistdb   =~ /mysql/ ) ) { push( @files, $redlistdb ); }
    foreach my $f (@files) {
        if ( !-e $f ) { next }
        open( my $curfile, "<", $f );

        #<$curfile>;
        while (<$curfile>) {
            ( $k, $v ) = split( /[\001\002\n]/, $_ );
            if ( $k eq q{} || $v eq q{} ) { next }

            #print "$k=$v\n";
            $w{ $k } = $v;
        }
        close $curfile;
        open( my $newfile, ">", "$f.new" );
        binmode $newfile;
        print { $newfile } "\n";
        for ( sort keys %w ) { print { $newfile } "$_\002$w{$_}\n"; }
        close $newfile;
        rename( $f, "$f.bak" );
        rename( "$f.new", $f );
        undef %w;
    }
    return;
} ## end sub repair



sub sendNotification {
    my ($from,$to,$sub,$body,$file) = @_;
    my $text;
    return unless $to;
    return unless $resendmail;    
    my $date=$UseLocalTime ? localtime() : gmtime();
    my $tz=$UseLocalTime ? tzStr() : '+0000';
    $date=~s/(\w+) +(\w+) +(\d+) +(\S+) +(\d+)/$1, $3 $2 $5 $4/;
    $text = "Date: $date $tz\r\n";
    $text .= "X-Assp-Notification: YES\r\n";
  	$text .= "From: <$from>\r\nTo:" if $from !~ /\</;
    $text .= "From: $from\r\nTo:" if $from =~ /\</;

    foreach (split(/\|/, $to)) {
        $text .= " <$_>,";
    }
    chop $text;
    $text .= "\r\n";
    $text .= "Subject: $sub\r\n";
    $text .= "Content-Type: text/plain;	charset=\"ISO-8859-1\"\r\n";
    $text .= "Content-Transfer-Encoding: 7bit\r\n";
    my $msgid = int(rand(1000000));
    $text .= "Message-ID: a$msgid\@$myName\r\n";
    $text = &headerWrap($text);
    $text .= "\r\n";           # end header
    foreach (split(/\r?\n/,$body)) {
        $text .= "$_\r\n";
    }
   	
    my $f;
    if ($file && -e $file && open($f,"<",$file)) {
    	
        while (<$f>) {        	 	
             s/\r?\n//g;
             $text .= "$_\r\n";
        
        }
        close $f;
    }

    $text .= ".\r\n";
    $text =~ tr/\x80-\xFF/_/;   # 7bit only
    my $rfile = "$base/$resendmail/n$msgid$maillogExt";
	-d "$base/$resendmail" or mkdir "$base/$resendmail", 0777;
    if (open($f,">",$rfile)) {
        binmode $f;
        print $f $text;
        close $f;
        &printlog( "write notify message to $rfile\n" );        
    } else {

        &printlog( "error: unable to write notify message to $rfile - $!\n" );
    }
   
}
sub tzStr {

    # calculate the time difference in minutes
    my $minoffset =
      ( Time::Local::timelocal( localtime() ) -
          Time::Local::timelocal( gmtime() ) ) / 60;

   # translate it to "hour-format", so that 90 will be 130, and -90 will be -130
    my $sign = $minoffset < 0 ? -1 : +1;
    $minoffset = abs($minoffset) + 0.5;
    my $tzoffset = 0;
    $tzoffset = $sign * ( int( $minoffset / 60 ) * 100 + ( $minoffset % 60 ) )
      if $minoffset;

    # apply final formatting, including +/- sign and 4 digits
    return sprintf( "%+05d", $tzoffset );
}
# wrap long headers
sub headerWrap {
    my $header = shift;
    $header =~
s/(?:([^\r\n]{60,75}?;)|([^\r\n]{60,75}) ) {0,5}(?=[^\r\n]{10,})/$1$2\r\n\t/g;

    return $header;
}
sub cleanUpFiles {
    my ($folder, $filter, $filetime) = @_;

    my $textfilter = " (*$filter)" if $filter;
    my @files;
    my $file;
    my $count;
    my $dir = &fixPath($folder); 
    $dir =~ s/\\/\//g;
    return unless -e $dir;
    &printlog( "starting cleanup old files$textfilter for folder $dir\n" );
        
    opendir(my $DIR,"$dir");
    @files = readdir($DIR);
    close $DIR;
	my $fldrpath        = $dir . "/*"; 

    my $filecount = &countfiles($fldrpath);
    foreach $file (@files) {
        next if $file eq '.';
        next if $file eq '..';
        next unless $file =~ /$maillogExt$/i or $file =~ /\.rpt$/i;
        next if ($filter && $file !~ /$filter$/i);
        next if ($filter && $file =~ /^$filter$/i);
        $file = "$dir/$file";
        next if -d $file;
        next unless -w $file;
        my $dtime=(stat($file))[9]-time;
        if (($dtime < $filetime * -1) or ($dtime > 0 && $dtime < $MaxKeepDeleted - $filetime)) {
            unlink $file;
            $count++;

        }
    }

    my $filecountafter = &countfiles($fldrpath);
    &printlog( "folder $dir before: $filecount\n" ) ;
	&printlog( "folder $dir deleted: $count\n" ) if $count;
	&printlog( "folder $dir after: $filecountafter\n\n" ) ;
	$correctedspamcount = $filecountafter if $dir =~ 'errors\/spam';
	$correctednotspamcount = $filecountafter if $dir =~ 'errors\/notspam';
	
}

sub cleanUpMaxFiles {
    my $folder = shift;
    my $percent = shift;

    my @files;
    my $file;
    my $count;
    my $info;
    my $dir = ($folder !~ /\Q$base\E/i) ? "$base/$folder" : $folder ;
    my $maxfiles = $MaxFiles;
    my $importmaxfiles = $MaxFiles;


    my $adiff = abs ($correctedspamcount - $correctednotspamcount);
    $maxfiles = $MaxFiles + $adiff if $dir =~ /assp\/spam/ && $correctednotspamcount > $correctedspamcount;
    $maxfiles = $MaxFiles + $adiff if $dir =~ /assp\/notspam/ && $correctedspamcount > $correctednotspamcount;
    
    $dir =~ s/\\/\//g;
    return unless -e $dir;


    opendir(my $DIR,"$dir");
    @files = readdir($DIR);
    close $DIR;
    my $filecount = @files - 2;

    printlog("cleaning $dir skipped - filecount: $filecount < maxfiles: $maxfiles\n") if $filecount <= $maxfiles;
    return $info if  $filecount <= $maxfiles;
    
    my %filelist = ();
    while (@files ) {
        $file = shift @files;
        next if $file eq '.';
        next if $file eq '..';
        $file = "$dir/$file";
        if (-d $file) {
            $filecount--;
            next;
        }
        my $ft = (stat($file))[9];
        $ft = $ft - (60 * 24 * 3600) if $ft > time;
        while (exists $filelist{$ft}) {
            $ft++;
        }
        $filelist{$ft} = $file;
        $count++;

    }
    return $info if $filecount <= $maxfiles;
    

    printlog("\nstarting cleaning $dir - delete files from $dir - old filecount: $filecount: \n");
    my $toFilenumber;
    my $filenum;
    my $time = time - ($minimumdays * 24 * 3600);   # two weeks ago
	my $savecount;

    $filenum = $maxfiles - $filecount;
    $toFilenumber = $maxfiles;

    $count = 0;
    
    foreach my $filetime (sort keys %filelist) {
        last if $filecount-- < $toFilenumber;

        unlink "$filelist{$filetime}";
        $count++;

    }

    opendir(my $DIR,"$dir");
    @files = readdir($DIR);
    close $DIR;
    my $newfilecount = @files - 2;

 
    printlog("finished cleaning $dir - new filecount: $newfilecount\n") ;

    return $info;
}


sub cleanUpCollection {
	my $age = $MaxNoBayesFileAge * 3600 * 24;
    my @dirs = ('incomingOkMail','discarded','viruslog');
    my $dir;

 
    	&printlog( "\n--- Cleaning NoBayesian folders ---\n" );
    	&printlog( "entries older than $MaxNoBayesFileAge days will be removed\n" ) if $MaxNoBayesFileAge;

    foreach my $dir (@dirs) {
        if ($age) {
            &cleanUpFiles(${$dir},'',$age) if ${$dir};
        } 
    }
    
    $age = $MaxCorrectedDays * 3600 * 24;
    @dirs = ('correctedspam','correctednotspam');
    
    &printlog( "\n--- Cleaning corrected (errors) spam/notspam folders ---\n" );
    &printlog( "entries older than $MaxCorrectedDays days will be removed\n" ) if $MaxCorrectedDays;

    foreach my $dir (@dirs) {
        if ($age) {
            &cleanUpFiles(${$dir},'',$age) if ${$dir};
        } else {
            &cleanUpMaxFiles(${$dir}) if ${$dir};
        }
    }

    return unless $maintbayescollection;
    $age = 0;
    @dirs = ('spamlog','notspamlog');
    
    &printlog( "\n--- Cleaning Bayesian folders ---\n" );
    &printlog( "entries older than $MaxBayesFileAge days will be removed\n" ) if $MaxBayesFileAge;

    foreach my $dir (@dirs) {
        if ($age) {
            &cleanUpFiles(${$dir},'',$age) if ${$dir};
        } else {
            &cleanUpMaxFiles(${$dir}) if ${$dir};
        }
    }
}
sub cleanTrashlist {
    my $files_before = my $files_deleted = 0;
    my $t = time;
    my $mcount;

    while ( my ( $k, $v ) = each(%Trashlist) ) {
		if (!-e $k) {
			delete $Trashlist{$k};
			$files_deleted++;
			next;
		}
        my $ct = $v;
        $files_before++;

        if (  $t - $ct >= $MaxKeepDeleted * 3600 * 24
            )
        {
        	deletefile ($k,"Trashlist",1);
            delete $Trashlist{$k};
            $files_deleted++;
        }
    }
    &printlog(
"\nTrashlist: cleaning finished; before=$files_before, deleted=$files_deleted\n"
    ) if $files_before>0 ;
   
}
sub getUidGid {
    my ( $uname, $gname ) = @_;

    my $rname = "root";
    eval('getgrnam($rname);getpwnam($rname);');
    if ($@) {

        # windows pukes "unimplemented" for these -- just skip it
        printlog(
"warning:   uname and/or gname are set ($uname,$gname) but getgrnam / getpwnam give errors: $@"
        );
        return;
    }
    my $gid;
    if ($gname) {
        $gid = getgrnam($gname);
        if ( defined $gid ) {
        } else {
            my $msg =
"could not find gid for group '$gname' -- not switching effective gid ";
            printlog( $msg );
            return;
        }
    }
    my $uid;
    if ($uname) {
        $uid = getpwnam($uname);
        if ( defined $uid ) {
        } else {
            my $msg =
"could not find uid for user '$uname' -- not switching effective uid ";
            printlog( $msg );
            return;
        }
    }
    ( $uid, $gid );
}

sub mlog {
}
sub switchUsers {
    my ( $uid, $gid ) = @_;

    my ( $uname, $gname ) = ( $runAsUser, $runAsGroup );
    $> = 0;
    if ( $> != 0 ) {
        my $msg =
"requested to switch to user/group '$uname/$gname' but cannot set effective uid to 0 --  uid is $>";
        printlog( $msg );
        return;
    }
    $< = 0;
    if ($gid) {
        $) = $gid;
        if ( $) + 0 == $gid ) {
            printlog( "\nswitched effective gid to $gid ($gname)\n" );
        } else {
            my $msg =
"failed to switch effective gid to $gid ($gname) -- effective gid=$) ";
            printlog( $msg );
            return;
        }
        $( = $gid;
        if ( $( + 0 == $gid ) {
            printlog( "\nswitched real gid to $gid ($gname)\n" );
        } else {
            printlog(
                "failed to switch real gid to $gid ($gname) -- real uid=$(" );
                return;
        }
    }
    if ($uid) {

        # do it both ways so linux and bsd are happy
        $< = $> = $uid;
        if ( $> == $uid ) {
            printlog( "\nswitched effective uid to $uid ($uname)\n" );
        } else {
            my $msg =
"failed to switch effective uid to $uid ($uname) -- real uid=$<";
            printlog( $msg );
            return;
        }
        if ( $< == $uid ) {
            printlog( "\nswitched real uid to $uid ($uname)\n" );
        } else {
            printlog(
                "failed to switch real uid to $uid ($uname) -- real uid=$<" );
                return
        }
    }
}
#####################################################################################
#                orderedtie
{

    package orderedtie;

    # This is a tied value that caches lookups from a sorted file; \n separates records,
    # \002 separates the key from the value. After OrderedTieHashSize lookups the cache is
    # cleared. This give us most of the speed of the hash without the huge memory overhead of storing
    # the entire hash and should be totally portable. Picking the best value for n requires some
    # tuning. A \n is required to start the file.
    # if you're updating entries it behoves you to call flush every so often to make sure that your
    # changes are saved. This also frees the memory used to remember updated values.
    # for my purposes a value of undef and a nonexistant key are the same
    # Obviosly if your keys or values contain \n or \002 it will totally goof things up.
    sub TIEHASH {
        my ( $c, $fn ) = @_;
        my $self = { fn => $fn, age => mtime($fn), cnt => 0, cache => {}, updated => {}, ptr => 1, };
        bless $self, $c;
        return $self;
    }
    sub DESTROY { $_[0]->flush(); }
    sub mtime { my @s = stat( $_[0] ); $s[9]; }

    sub flush {
        my $this = shift;
        return unless %{ $this->{ updated } };
        my $f = $this->{ fn };
        open( O, '>', "$f.tmp" ) || return;
        binmode(O);
        open( I, '<', "$f" ) || print O"\n";
        binmode(I);
        local $/ = "\n";
        my @l = ( sort keys %{ $this->{ updated } } );
        my ( $k, $d, $r, $v );

        while ( $r = <I> ) {
            ( $k, $d ) = split( "\002", $r );
            while ( @l && $l[0] lt $k ) {
                $v = $this->{ updated }{ $l[0] };
                print O"$l[0]\002$v\n" if $v;
                shift(@l);
            }
            if ( $l[0] eq $k ) {
                $v = $this->{ updated }{ $l[0] };
                print O"$l[0]\002$v\n" if $v;
                shift(@l);
            }
            else { print O$r; }
        }
        while (@l) {
            $v = $this->{ updated }{ $l[0] };
            print O"$l[0]\002$v\n" if $v;
            shift(@l);
        }
        close I;
        close O;
        unlink($f);
        rename( "$f.tmp", $f );
        $this->{ updated } = {};
    } ## end sub flush

    sub STORE {
        my ( $this, $key, $value ) = @_;
        $this->{ cache }{ $key } = $this->{ updated }{ $key } = $value;
    }

    sub FETCH {
        my ( $this, $key ) = @_;
        return $this->{ cache }{ $key } if exists $this->{ cache }{ $key };
        $this->resetCache()
            if ( $this->{ cnt }++ > 10000
            || ( $this->{ cnt } & 0x1f ) == 0 && mtime( $this->{ fn } ) != $this->{ age } );
        return $this->{ cache }{ $key } = binsearch( $this->{ fn }, $key );
    }

    sub resetCache {
        my $this = shift;
        $this->{ cnt }   = 0;
        $this->{ age }   = mtime( $this->{ fn } );
        $this->{ cache } = { %{ $this->{ updated } } };
    }

    sub binsearch {
        my ( $f, $k ) = @_;
        open( F, '<', "$f" ) || return;
        binmode(F);
        my $siz = my $h = -s $f;
        $siz -= 1024;
        my $l  = 0;
        my $k0 = $k;
        $k =~ s/([\[\]\(\)\*\^\!\|\+\.\\\/\?\`\$\@\{\}])/\\$1/g;    # make sure there's no re chars unqutoed in the key

        #print "k=$k ($_[1])\n";
        while (1) {
            my $m = ( ( $l + $h ) >> 1 ) - 1024;
            $m = 0 if $m < 0;

            #print "($l $m $h) ";
            seek( F, $m, 0 );
            my $d;
            my $read = read( F, $d, 2048 );
            if ( $d =~ /\n$k\002([^\n]*)\n/ ) {
                close F;

                #print "got $1\n";
                return $1;
            }
            my ( $pre, $first, $last, $post ) = $d =~ /^(.*?)\n(.*?)\002.*\n(.*?)\002.*?\n(.*?)$/s;

            #print "f=$first ";
            last unless defined $first;
            if ( $k0 gt $first && $k0 lt $last ) {

                #print "got miss\n";
                last;
            }
            if ( $k0 lt $first ) {
                last if $m == 0;
                $h = $m - 1024 + length($pre);
                $h = 0 if $h < 0;
            }
            if ( $k0 gt $last ) {
                last if $m >= $siz;
                $l = $m + $read - length($post);
            }

            #print "l=$l h=$h ";
        } ## end while (1)
        close F;
        return;
    } ## end sub binsearch

    sub FIRSTKEY {
        my $this = shift;
        $this->flush();
        $this->{ ptr } = 1;
        $this->NEXTKEY();
    }

    sub NEXTKEY {
        my ( $this, $lastkey ) = @_;
        local $/ = "\n";
        open( F, '<', "$this->{fn}" ) || return;
        binmode(F);
        seek( F, $this->{ ptr }, 0 );
        my $r = <F>;
        return unless $r;
        $this->{ ptr } = tell F;
        close F;
        my ( $k, $v ) = $r =~ /(.*?)\002(.*?)\n/s;

        if ( !exists( $this->{ cache }{ $k } ) && $this->{ cnt }++ > 10000 ) {
            $this->{ cnt }   = 0;
            $this->{ cache } = { %{ $this->{ updated } } };
        }
        $this->{ cache }{ $k } = $v;
        $k;
    }

    sub EXISTS {
        my ( $this, $key ) = @_;
        return FETCH( $this, $key );
    }

    sub DELETE {
        my ( $this, $key ) = @_;
        $this->{ cache }{ $key } = $this->{ updated }{ $key } = undef;
    }

    sub CLEAR {
        my ($this) = @_;
        open( F, '>', "$this->{fn}" );
        binmode(F);
        print "\n";
        close F;
        $this->{ cache }   = {};
        $this->{ updated } = {};
        $this->{ cnt }     = 0;
    }
}

