#!/usr/local/bin/perl -T

#
# Author:  Chris Mason <cmason@unixzone.com>
# Current maintainer: Lars Hecking <lhecking@users.sourceforge.net>
#
# Based on work by:
#       Mogens Kjaer, Carlsberg Laboratory, <mk@crc.dk>
#       Juergen Quade, Softing GmbH, <quade@softing.com>
#       Christian Bricart <shiva@aachalon.de>
#
# This script is part of the AMaViS package.  For more information see:
#
# http://amavis.org/
#
# Copyright (C) 2000 - 2002 the people mentioned above
#
#
# This software is licensed under the GNU General Public License (GPL)
# See:  http://www.gnu.org/copyleft/gpl.html
#


use strict;
use MIME::Parser;
use POSIX qw ( strftime geteuid setuid uname setsid
  WEXITSTATUS WIFEXITED WTERMSIG WIFSIGNALED );
use POSIX ":sys_wait_h";
use Fcntl;
use Fcntl ':flock';
use Unix::Syslog qw(:macros :subs);
use IO::File;
use IO::Pipe;
use Convert::TNEF;
use Convert::UUlib ':all';
use Compress::Zlib;
use Archive::Tar;
use Archive::Zip qw ( :CONSTANTS :ERROR_CODES );
use File::Basename;
use File::Copy;
use Socket;


#
# main()
#

package main;

#
# Configurable constants
#

# Config file
my $config_file = "/usr/local/etc/amavisd.conf";

# If $TESTING is yes, no mail is sent at all.  MIME decomposition
# and virus scanning are still performed.  Depending on $DEBUG, you'll
# have to monitor the daemon's log file or stderr to verify correct
# operation.
my $TESTING = "no";

# Create debugging output
# yes: log to stderr; no: log to syslog/file
my $DEBUG = "no";

#
# Non-configurable variables and constants
#

#
# Package related

my $pkg_home_url = "http://amavis.org/";

#
# Error codes
my ($VIRUSERR, $REGERR);

#
# Logging related

use vars qw ( $DO_SYSLOG $LOGDIR $LOGFILE $myname $log $log_level );

my $SYSLOG_LEVEL = "mail.info";
my ($FACILITY, $PRIORITY);

#
# Virus related

# Av scanners and related vars
use vars qw ( $antivir $avp $avpdc $AVPDIR $csav $drweb $fprot $fprotd $fsav
  $inocucmd $mks $nod32 $nod32cli $norman $oav $panda $rav $sophos
  $sophos_ide_path $cscmdline $scs_host $scs_port $uvscan $vbengcl $vexira 
  $vfind $vscan $sophie_sockname $trophie_sockname );

use vars qw ( $QUARANTINEDIR $VIRUSFILE @virusname
  $warnadmin $warnsender $warnrecip $warn_offsite @local_domains );

use vars qw ( $X_HEADER_TAG $X_HEADER_LINE );

#
# Various external programs
use vars qw ( $arc $bunzip $file $lha $unarj $uncompress $unrar $zoo );

#
# MTA related

use vars qw ( $localhost_ip $localhost_name $smtp_port $enable_relay
  $QMAILDIR $sendmail_cf_orig );

#
# sending email related

use vars qw ( $SENDER @RECIPS $LDA @LDAARGS $sendmail_wrapper
  $sendmail_wrapper_args $mailfrom $mailto );

# Temporary directory
# Moved this above MTA init section because milter init sets TEMPDIR
my $TEMPBASE = "/var/amavis";
use vars '$TEMPDIR';

#
# Client/server/daemon related

my ($socketname, $parentpid, $diedpid, $tmppid) = ("/var/amavis/amavisd.sock", 0, 0, 0);

# flag to indicate compressing file format
my $some_compression = 0;

#
# MTA init section
#

# sendmail

# error codes
$VIRUSERR = 0;
$REGERR = 75;   # EX_TEMPFAIL from sendmail sysexits.h

# suid?
#if (setuid(0) == -1) {
#    exit($REGERR)
#}

# set path explicitly
$ENV{PATH} = "/bin:/usr/bin:/usr/local/bin";

# End sendmail
#
# End MTA init section
#

#
# misc internals
use vars qw ( $MAXLEVELS $MAX_ARCHIVE_NESTING $MAXFILES $credits $fh );

# Magic number to detect DoS attacks
my $threshold = 14;

# MIME entity, av scanner output and return status
use vars qw ( $entity $output $errval );

#
# Subroutines
#

#
# Client/server/daemon stuff

# From perlipc(1)
sub daemonize {
    chdir("/")                or die "Can't chdir to /: $!";
    open STDIN, '/dev/null'   or die "Can't read /dev/null: $!";
    open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
    defined(my $pid = fork)   or die "Can't fork: $!";
    exit if $pid;
    setsid                    or die "Can't start a new session: $!";
    open STDERR, '>&STDOUT'   or die "Can't dup stdout: $!";
}

#
# Set up signal handling

my(%child_status,%child_stime,%child_etime);

#
# SIGCHLD handler
sub deadbabe {
    do {
      $tmppid = waitpid(-1, &WNOHANG);
    } while ($tmppid > 0);
    $diedpid = 1;
    $SIG{CHLD} = \&deadbabe;
# stupid sys5 resets the signal when called - but only -after- the wait...
}
# Catch any dead child process

# If IGNORE leaves zombies behind on your system,
# switch the comments between the two lines below
# $SIG{CHLD} = \&deadbabe;
$SIG{CHLD} = 'IGNORE';

# may need to do more - eg. if logging changes, close/reopen syslog/log file
# rethink - handler should be simple
sub read_config {
    -f $config_file or die "Cannot find config file $config_file";
    do $config_file or die "Error in config file $config_file: $@";
    $SIG{HUP} = \&read_config;
}
$SIG{HUP} = \&read_config;
# doesn't work yet!!

# Clean exit
$SIG{INT} = $SIG{TERM} = sub { do_exit(1, __LINE__); };

#
sub setup_socket() {
    my $uaddr = sockaddr_un($socketname);

    socket(Server, PF_UNIX, SOCK_STREAM, 0) || return 0;
    unlink ($socketname);
    do_log(3,"set up socket");

    bind (Server, $uaddr) || return 0;
    do_log(3,"bound socket");

    listen (Server, SOMAXCONN) || return 0;
    do_log(3,"listening");

    return 1;
}

#
# Examine and report children termination
sub report_children () {
    my @deceased_pids;
    while ( (@deceased_pids=keys(%child_status)) > 0) {
	my $cpid = $deceased_pids[0];
	my $elapsed = $child_etime{$cpid} && $child_stime{$cpid}
			? $child_etime{$cpid} - $child_stime{$cpid}
			: undef;
	my $status = $child_status{$cpid};
	my($status_exit,$status_sig) = ($status >> 8, $status & 255);
	my $msg = sprintf("child [%d] %s with status %d%s%s",
			  $cpid, ($status ? 'DIED' : 'terminated'),
			  $status_exit,
			  (!$status_sig ? '' : " (signal $status_sig)"),
			  (!defined $elapsed ? ''
				: sprintf(", elapsed time %.3f s",$elapsed)) );
	do_log( ($status ? 0 : 3), $msg);
	delete $child_status{$cpid};
	delete $child_stime{$cpid};
	delete $child_etime{$cpid};
    }
}

# The heart of the program
sub main_loop() {
    my ($inbuff, $mpid, $a);

    while (($a = accept(Client,Server)) || $diedpid) {

	do_log(3,"enter accept loop");
        # now we start the repeating loop...
        if ($diedpid) {
            $diedpid = 0;
            # if the accept returned purely because of a caught sigchld
            # then continue
            next unless (defined($a));
        }

	if (!defined($mpid = fork)) {
	    shutdown Server, 2;
	    do_log(0,"shutdown server - cannot fork");
	    do_exit($REGERR, __LINE__);
	}

	# if we're the parent, just go back to the accept loop
        next if ($mpid);
  
        do_log(3,"forked off -- child running...");
  
        $SIG{CHLD} = 'DEFAULT';
        # reset sigchild - we don't want to mess up $? for the virus scanner

	#
	# Receive TEMPDIR/SENDER/RCPTS/LDA/LDAARGS from client
	#

	my $ret;
	my $yval = "\1";
	# value to return to the client if AOK

	$ret = recv Client, $inbuff, 8192, 0;
	$TEMPDIR = $inbuff;
	if ($TEMPDIR =~ /^($TEMPBASE\/[-\w\.]+)$/) {
	    $TEMPDIR = $1;
	    # untaint the directory option...
	    $ret = send (Client, $yval, 0);
	} else {
	    do_log(0,"Invalid directory $TEMPDIR");
	    do_exit($REGERR, __LINE__);
	    # invalid directory
	}
	if (!defined($ret)) {
	    do_log(0,"failed to send response to client - $!");
	    do_exit($REGERR, __LINE__);
	}
	$ret = recv Client, $inbuff, 8192, 0;
	$SENDER = $inbuff;
	$ret = send (Client, $yval, 0);
	if (!defined($ret)) {
	    do_log(0,"failed to send response to client - $!");
	    do_exit($REGERR, __LINE__);
	}

	# Simple "protocol"
	# \2 means LDA; \3 means EOT (end of transmission)

	my $outvar = \@RECIPS;
	while (1) {
	    $ret = recv Client, $inbuff, 8192, 0;
	    last if ($inbuff eq "\3");

	    ($inbuff eq "\2") ? $outvar = \@LDAARGS : push(@$outvar, $inbuff);

	    $ret = send (Client, $yval, 0);
	    if (!defined($ret)) {
		do_log(0,"failed to send response to client - $!");
		do_exit($REGERR, __LINE__);
	    }
	}

	# Kiss
	$LDA = shift @LDAARGS;


# command line parsing, sendmail version

if ($enable_relay eq "yes") {
    # relay config

    $LDA = $sendmail_wrapper;
    push(@LDAARGS, "-C$sendmail_cf_orig");
    push(@LDAARGS, "-f<$SENDER>");
    push(@LDAARGS, "@RECIPS");
}

# End sendmail cmd line parsing

	# This is just for debugging purposes
	do_log(1,"$TEMPDIR: from=<$SENDER>, to=" . join(',',map{"<$_>"}@RECIPS));
	do_log(1,"LDA is \"$LDA\", LDAARGS is \"" . join(' ',@LDAARGS) . "\"") if ($LDA);

	$SENDER = "<>" unless ($SENDER);

	my($which_section) = "initialization";
	my($sts);
	eval {
	    mkdir("$TEMPDIR/parts", oct('700'))
		or die "Can't create directory $TEMPDIR/parts: $!";
	    chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";

	    # Mail message was saved by the client; this file is moved
	    # to a quarantine area if a virus was found

	    if (!-r "$TEMPDIR/email.txt") {
		die "Can't find mail file $TEMPDIR/email.txt";
	    } else {
		# already created by client, just open it
		$fh = IO::File->new("$TEMPDIR/email.txt")
		    or die "Can't open file $TEMPDIR/email.txt: $!";
	    }
	    $which_section = "decoding";        parse_decode($fh);
	    $which_section = "virus scanning";  virus_scan();
	    $which_section = "mail forwarding"; $sts = forward_mail();

	    $which_section = "finishing";
	};
	if ($@ ne '') {
	    chomp($@);
	    do_log(0,"$which_section failed, retry: $@");
	    do_exit($REGERR, __LINE__);
	}

	# forward_mail() returns 0 on success
	do_exit(0, __LINE__) if (!$sts);

	do_exit($REGERR, __LINE__)
    } # accept loop

} # main_loop

#
# Subroutines
#

# Run virus scanner(s)
sub virus_scan {
    # At least one scanner must work!
    #
    # If at least one scanner completes its job (either finding a virus
    # or declaring that files are safe), the value of $scanner_errors
    # will become 0, otherwise it remains true, meaning all of the
    # available scanners failed to run, or returned an error.
    my $scanner_errors = 1;

    #
    # Okay, now we scan for viruses
    #
    # If we find one, send mail right away and quit.  No point scanning any
    # more once we've found one.
    #








#
# DrWeb for Linux
#

if ($drweb) {
    do_log(2,"Using $drweb");
    chop($output = `$drweb -al -ar -fm -go -ha -ml -ni -ot -sd -up $TEMPDIR/parts`);
    $errval = retcode($?);
    do_log(2,$output);
    if ($errval == 0) {			# no errors, no viruses found
	$scanner_errors = 0;
    } elsif ($errval == 1) {		# no errors, viruses discovered
	$scanner_errors = 0;
	@virusname = ($output =~ /infected with (.+)/g);
	do_virus($output);
    } else {
	do_log(0,"Virus scanner failure: $drweb (error code: $errval)");
    }
}






#
# McAfee
# 

if ($uvscan) {
    do_log(2,"Using $uvscan");
    chop($output = `$uvscan --secure -rv --summary --noboot $TEMPDIR/parts`);
    $errval = retcode($?);
    do_log(2,$output);
    if ($errval == 0) {			# no errors, no viruses found
	$scanner_errors = 0;
    } elsif ($errval == 13) {		# no errors, viruses discovered
	$scanner_errors = 0;
	my $loutput = $output;
	$loutput =~ s/Found: (.+) NOT a/Found the $1/g;
	$loutput =~ s/Found the (.+) trojan/Found the $1 virus/g;
	$loutput =~ s/Found virus or variant (.+) /Found the $1 virus/g;
	@virusname = ($loutput =~ /Found the (.+) virus/g);
	@virusname = (undef)  if !@virusname;  # just in case: make list nonnil
	do_virus();
    } else {
	do_log(0,"Virus scanner failure: $uvscan (error code: $errval)");
    }
}













    if ($scanner_errors) {
	do_log(0,"All virus scanners failed!");
	do_exit($REGERR, __LINE__);
    }
}

# Forward original message
sub forward_mail {
    my $seen_xheader = ( $X_HEADER_LINE ? 0 : 1 );

    if ($TESTING ne "yes") {
	
    # sending mail, sendmail version
    # For sendmail, we call the "real" local delivery agent

    open(MAIL, "|-") || exec($LDA, @LDAARGS);
    while (<$fh>) {
	next if ($seen_xheader == 0 && m/^$X_HEADER_TAG:/o);
	if ($seen_xheader == 0 && m/\A\r?\n\Z/) {
	    print MAIL "$X_HEADER_TAG: $X_HEADER_LINE\n";
	    $seen_xheader = 1;
	}
	print MAIL $_;
    }

    close(MAIL);

    # Pass up the LDA's error code
    do_exit(retcode($?), __LINE__);
    # End sendmail
    } else {
	do_log(0,"Testing mode - no email sent. $X_HEADER_TAG: $X_HEADER_LINE");
    }
    return 0;
}

# If virus found
sub do_virus() {

    # early exit in testing mode
    do_exit(0, __LINE__) if ($TESTING eq "yes");

    log_msg_id(1);

    if ($QUARANTINEDIR) {
	do_quarantine("Virus found");
    } else {
	do_log(0,"Virus found - not quarantined");
    }

    # Then we send email
    warn_sender() if ($warnsender eq "yes");

    # warn_recip() is disabled by default because of possible problems
    # with mailing lists. Enable only if you know what you're doing!
    warn_recip() if ($warnrecip eq "yes");

    # Notify admin
    warn_admin() if ($warnadmin eq "yes");

    # Finally, we bounce the message or pretend everything was okay,
    # depending on the MTA
    do_exit($VIRUSERR, __LINE__);
}

#
sub do_quarantine(@) {
    my $reason = shift;
    $VIRUSFILE = "virus-" . strftime("%Y%m%d-%H%M%S", localtime) . "-" . "$$";
    move ("$TEMPDIR/email.txt", "$QUARANTINEDIR/$VIRUSFILE");
    do_log(0,"$reason - quarantined as $VIRUSFILE");
}

# Notify sender
sub warn_sender() {
    return 0 if ($SENDER eq "<>" or $entity->head->get("Precedence") =~ /bulk|list/i);

    open(MAIL, "|$sendmail_wrapper $sendmail_wrapper_args -f$mailfrom")
      or die "warn_sender: open failed: $!, $?";
    my $amavis_url = &amavisCredits();
    printf MAIL (<<"EOF",
From: $mailfrom
To: $SENDER
Subject: VIRUS IN YOUR MAIL

                           V I R U S  A L E R T

Our viruschecker found the

\t%s

virus%s in your email to the following recipient%s:

EOF
	# [still within printf syntax!]:
	join("\n\t", map(sanitize_str($_),@virusname)),
	(@virusname==1?"":"es"),
	(@RECIPS==1?"":"s") )  or die "warn_sender: printf failed: $!";

    foreach (@RECIPS) {
	printf MAIL ("-> %s\n", sanitize_str($_))
	    or die "warn_sender: printf failed: $!";
    }
    printf MAIL (<<"EOF",

Delivery of the email was stopped!

Please check your system for viruses,
or ask your system administrator to do so.
$amavis_url

For your reference, here are the SMTP envelope originator
and headers from your email:

From %s
------------------------- BEGIN HEADERS -----------------------------
EOF
	# [still within printf syntax!]:
	sanitize_str($SENDER) ) or die "warn_sender: printf failed: $!";

    $entity->print_header(\*MAIL) or die "warn_sender: print_header failed: $!";
    print MAIL <<"EOF" or die "warn_sender: print failed: $!";
-------------------------- END HEADERS ------------------------------

EOF
    close(MAIL) or die "warn_sender: close failed: $?";
}

# Notify admin
sub warn_admin() {
    open(MAIL, "|$sendmail_wrapper $sendmail_wrapper_args -f$mailfrom")
      or die "warn_admin: open failed: $!, $?";
    $SENDER = "(empty address)" if ($SENDER eq "<>");
    printf MAIL (<<"EOF",
From: $mailfrom
To: $mailto
Subject: VIRUS FROM %s (%s)

A virus was found in an email from:

   %s

The message was addressed to: 

EOF
	# [still within printf syntax!]:
	sanitize_str($SENDER),
	join(", ", map(sanitize_str($_),@virusname)),
	sanitize_str($SENDER) )  or die "warn_admin: printf failed: $!";

    foreach (@RECIPS) {
	printf MAIL ("-> %s\n", sanitize_str($_))
	    or die "warn_admin: print failed: $!";
    }

    if ($QUARANTINEDIR) {
	print MAIL <<"EOF" or die "warn_admin: print failed: $!";

The message has been quarantined as:

   $QUARANTINEDIR/$VIRUSFILE
EOF
    }
    print MAIL <<"EOF" or die "warn_admin: print failed: $!";

Here is the output of the scanner:

   $output

Here are the headers:
------------------------- BEGIN HEADERS -----------------------------
EOF
    $entity->print_header(\*MAIL) or die "warn_admin: print_header failed: $!";
    print MAIL <<"EOF" or die "warn_admin: print failed: $!";
-------------------------- END HEADERS ------------------------------
EOF
    close(MAIL) or die "warn_admin: close failed: $?";
}

# Notify recipient(s)
# if $warn_offsite is "no", recipient addresses where the domain-part
# is not in @local_domains don't get a notification
sub warn_recip() {
    my %local_domains = ();
    for (@local_domains) { $local_domains{lc($_)} = 1 }
    # hashes are faster than arrays
    foreach my $rcpt (@RECIPS) {
	my $rcpt_domain = ($rcpt =~ /^<([^>]*)>$/ ? $1 : $rcpt);
	$rcpt_domain = ($rcpt_domain =~ /^(.*)\@([^@]*)$/ ? $2 : '');
	my $rcpt_is_local = undef;
	$rcpt_is_local = 1  if $local_domains{lc($rcpt_domain)};
	if ($rcpt_is_local || $warn_offsite eq "yes") {
	    open(MAIL, "|$sendmail_wrapper $sendmail_wrapper_args -f$mailfrom")
	      or die "warn_recip: open failed: $!, $?";
	    my $amavis_url = &amavisCredits();
	    $SENDER = "(empty address)" if ($SENDER eq "<>");
	    printf MAIL (<<"EOF",
From: $mailfrom
To: $rcpt
Subject: VIRUS IN MAIL FOR YOU (from %s)

                           V I R U S  A L E R T

Our viruschecker found the

\t%s

virus%s in an email to you from:

\t%s

Delivery of the email was stopped!
Please contact your system administrator for details.

EOF
		# [still within printf syntax!]:
		sanitize_str($SENDER),
		join("\n\t", map(sanitize_str($_),@virusname)),
		(@virusname==1?"":"es"),
		sanitize_str($SENDER) )
		    or die "warn_recip: printf failed: $!";

	    if ($QUARANTINEDIR) {
		print MAIL <<"EOF" or die "warn_recip: print failed: $!";
The ID of your quarantined message is: $VIRUSFILE
EOF
	    }
	    if ($amavis_url ne "") {
		print MAIL $amavis_url,"\n" or die "warn_recip: print failed: $!";
	    }
	    close(MAIL) or die "warn_recip: close failed: $?";
	}
    }
}

# amavis credits.
# Called from the notification routines.
sub amavisCredits {
    if ($credits eq "yes" ) {
	return <<EOF;

For further information about this viruschecker see:

$pkg_home_url
AMaViS - A Mail Virus Scanner, licensed GPL

EOF
    }

    return "";
}

# Get ready to break up mime parts
sub parse_decode(@) {
    my $fileh = shift;
    my ($parser, $filer, %atomic, %selfextract);
    my $previous = 0;
    my $warn_files = 0;
    my $warn_compression = 0;

    $parser = new MIME::Parser;
    $filer = MIME::Parser::FileInto->new("$TEMPDIR/parts");
    $filer->ignore_filename(1);
    $parser->filer($filer);
    $parser->extract_nested_messages("NEST");

    do_log(4,"Extracting mime components");

    $entity = $parser->parse($fileh);
    $fileh->seek(0,0);

    # Extract and decode each part to the extent possible

    for (my $i = 1; $i <= $MAXLEVELS; $i++) {
	my $current = 0;

	if ($i == $MAXLEVELS) {
	    do_log(0,"Maximum recursion depth ($MAXLEVELS) exceeded - requeue");
	    do_exit($REGERR,__LINE__);
	}

	opendir(PARTSDIR, "$TEMPDIR/parts")
	    or die "Can't open directory $TEMPDIR/parts: $!";
	my @parts = grep { !/^\.\.?$/ } readdir(PARTSDIR);
	closedir(PARTSDIR);

	# Determine number of parts
	$current = scalar(@parts);

	do_log(4,"Level: $i, parts: $current");
	do_log(4,"Archive nesting depth: $warn_compression");

	# Attempt to prevent DoS attacks with recursive archives
	# If the number of extracted parts is $threshold times greater
	# than the number of parts at the previous level, set $warn_files
	# If this occurs a second time ($warn_files == 2), refer the message
	# back to the mail system and log the deferral
	# We also quit if the maximum archive nesting depth is reached
	# Both measures are probaby not enough in the case of a small
	# number of highly compressed files

	# Triggers at $warn_files == 2
	if ($warn_files > 1 || ($warn_compression >= $MAX_ARCHIVE_NESTING)) {
	    log_msg_id(0);
	    die "Possible DoS detected - requeue";
	}

	# must delay by one level
	if (($previous > 0) && ($current / $previous >= $threshold)) {
	    $warn_files++;
	}
	$previous = $current;

	my $found = 0;
	foreach (@parts) {
	    my $save = $_;
	    unless (defined $atomic{$_} || defined $selfextract{$_}) {
		my $rv = decompose_part($_);

		if ($rv == 1) {
		    $found = 1;
		} elsif ($rv == 2) {
		    do_log(4,"$save is executable");
		    $selfextract{$save} = 1;
		    $found = 1;
		} else {
		    do_log(4,"$save is atomic");
		    $atomic{$save} = 1;
		}
	    }
	}
	last if ($found == 0);

	# must come after calling decompose_part
	if ($some_compression) {
	    $warn_compression++;
	    $some_compression = 0;
	}
    }
}

# Decompose the parts
sub decompose_part($) {
    my $part = shift;

    # $part should be safe because we generated the filenames ourselves
    # but let's be extra paranoid (and make taint happy)
    if ($part =~ /^([\w\d\-.]+)$/) {
	$part = $1;
    } else {
	die "Unsafe partname: $part";
    }

    my ($filetype) = qx($file $TEMPDIR/parts/$part) =~ /:\s*(\S.*)$/;

    do_log(4,"File-type of $part: $filetype");

    # possible return values for eval:
    # 0 - unknown or unarchiver failure; consider atomic
    # 1 - some archiver format, successfully unpacked
    # 2 - self-extracting archive, successfully unpacked
    my($sts) = eval {
	$_ = $filetype;
	/^(?:ASCII|text|uuencoded|xxencoded|binhex)/i && return do_ascii($part);
	/^gzip compressed/i    && return do_gunzip($part);
	/^compress'd/i         && return do_uncompress($part);
	/^bzip2 compressed/i   && return do_bzip2($part);
	/^(?:GNU |POSIX )?tar archive/i && return do_tar($part);
	/^Zip archive/i        && return do_unzip($part,0);
	/^RAR archive/i        && return do_unrar($part,0);
	/^LHA.*archive/i       && return do_lha($part,0);
	/^ARC archive/i        && return do_arc($part);
	/^ARJ archive/i        && return do_unarj($part);
	/^Zoo archive/i        && return do_zoo($part);
	/^(?:Transport Neutral Encapsulation Format|TNEF)/i && return do_tnef($part);
	/executable/i          && return do_executable($part);

	# Falling through - no match
	return 0;
    };

    if ($@ ne '') {
	chomp($@);
	do_log(0,"Decoding of $part ($filetype) failed, ".
		 "leaving it unpacked: $@");
    }

    return $sts;
}

# Generate unique filenames
{
    # Persistent and private
    my $filecount = 0;

    sub getfilename(@) {
	if ($filecount > $MAXFILES) {
	    do_log(0,"Maximum number of files ($MAXFILES) exceeded - requeue");
	    do_exit($REGERR,__LINE__);
	}
	return sprintf("part-%05d", ++$filecount);
    }
}

# copy (binary) command output to a file handle
# args: filehandle to print to, command, command args ...
sub fh_copy(@) {
    my $fileh = shift;
    my $blksize = (stat $fileh)[11] || 16384;
    my $pid = open(FDATA, "-|");  # fork
    defined($pid) or die "Can't fork: $!";
    if (!$pid) {  # child
	exec(@_)
	  or die "Can't exec program: $!";  # this will end up in parent's $?
	# NOTREACHED
    } else {
	my ($len, $buf, $offset, $written);
	while ($len = sysread FDATA, $buf, $blksize) {
	    $offset = 0;
	    while ($len > 0) { # Handle partial writes.
		$written = syswrite $fileh, $buf, $len, $offset;
		defined($written) or die "System write error: $!";
		$len -= $written; $offset += $written;
	    }
	}
	close(FDATA);
	return $?;
    }
}

#
# Uncompression/unarchiving routines
# Possible return codes:
# 0 - cannot extract/unpack further (treat as atomic)
# 1 - decoded/extracted from $part  (continue recursive extraction)
# 2 - $part is self-extracting executable (atomic AND continue extraction)

# if ASCII text, try multiple decoding methods as provided by UUlib
# (includes uuencoding, xxencoding, Base64 and BinHex)
sub do_ascii(@) {
    my $part = shift;
    my ($retval, $count) = LoadFile("$TEMPDIR/parts/$part");
    if ($count > 0) {
	do_log(4,"Decoding part $part");

	SetOption (OPT_SAVEPATH, "$TEMPDIR/parts/");
	my $uuerror = 0;
	for (my $i = 0; my $uu = GetFileListItem($i); $i++) {
	    if ($uu->state & FILE_OK) {
		my $newpart = "$TEMPDIR/parts/" . getfilename();
		$uu->decode($newpart);
		$uuerror = 1 if (!$uu->state || !FILE_OK || -z $newpart);
	    }
	}
	return 0 if ($uuerror == 1);

	unlink("$TEMPDIR/parts/$part")
	  or die "Can't unlink $TEMPDIR/parts/$part: $!";
	return 1;
    }
    return 0;
}

# use Archive-Zip
sub do_unzip(@) {
    my $part = shift;
    my $exec = shift;
    my $ziperr;
    my $zip = Archive::Zip->new();

    # Need to set up a temporary minimal error handler
    # because we now test inside do_zip whether the $part
    # in question is a zip archive
    Archive::Zip::setErrorHandler(sub{return 5});
    $ziperr = $zip->read("$TEMPDIR/parts/$part");
    Archive::Zip::setErrorHandler(sub{die @_});

    return 0 if ($ziperr != AZ_OK);
    do_log(4,"Unzipping $part");

    $some_compression++;

    my $compmeth = '';
    foreach ($zip->members()) {
	$compmeth = $_->compressionMethod;
	if ($compmeth == COMPRESSION_DEFLATED ||
	    $compmeth == COMPRESSION_STORED) {
	    my $newpart = "$TEMPDIR/parts/" . getfilename();
	    $zip->extractMember($_,$newpart) unless ($_->isDirectory);
	} else {
	    # FIXME note: per member
	    do_log(0,"$part: unsupported compression method: $compmeth");
	}
    }

    if (!$exec) {
	unlink("$TEMPDIR/parts/$part")
	  or die "Can't unlink $TEMPDIR/parts/$part: $!";
    }
    return 1;
}

# use external bzip program
# there *is* a perl module for bzip2, but it is not ready for prime time
sub do_bzip2(@) {
    my $part = shift;

    return 0 if (!$bunzip);
    do_log(4,"Expanding bzip2 archive $part");

    $some_compression++;

    my $newpart = "$TEMPDIR/parts/" . getfilename();

    system("$bunzip < $TEMPDIR/parts/$part > $newpart");
    if ($?) {
	unlink("$newpart") or die "Can't unlink $newpart: $!";
	return 0;
    }

    unlink("$TEMPDIR/parts/$part")
      or die "Can't unlink $TEMPDIR/parts/$part: $!";
    return 1;
}

# untar any tar archives with Archive-Tar
# extract each file individually
sub do_tar(@) {
    my $part = shift;

    # Work around bug in Archive-Tar
    my $tar = eval { Archive::Tar->new("$TEMPDIR/parts/$part") };

    unless (defined($tar)) {
	do_log(4,"Faulty archive $part");
	return 0;
    }

    do_log(4,"Untarring $part");

    my @list = $tar->list_files();

    foreach (@list) {
	unless (/\/$/) {		# Ignore directories
	    # this is bad (reads whole file into scalar)
	    # need some error handling, too
	    my $data = $tar->get_content($_);
	    my $newpart = "$TEMPDIR/parts/" . getfilename();
	    open(OUTPART, ">$newpart") or die "Can't write to $newpart: $!";
	    print(OUTPART $data);
	    close(OUTPART) or die "Can't close $newpart: $!";
	}
    }
    unlink("$TEMPDIR/parts/$part")
      or die "Can't unlink $TEMPDIR/parts/$part: $!";
    return 1;
}

# use Zlib to inflate
sub do_gunzip(@) {
    my $part = shift;
    my $buffer;
    my $newpart = "$TEMPDIR/parts/" . getfilename();

    do_log(4,"Inflating gzip archive $part");

    $some_compression++;

    my $gz = gzopen("$TEMPDIR/parts/$part", "rb")
		or die "Error opening $TEMPDIR/parts/$part: $!";
    open(OUTPART, ">$newpart") or die "Can't write to $newpart: $!";

    while ($gz->gzread($buffer) > 0) {
	print(OUTPART $buffer);
    }
    close(OUTPART) or die "Can't close $newpart: $!";

    if ($gzerrno != Z_STREAM_END) {
	unlink("$newpart") or die "Can't unlink $newpart: $!";
	return 0;
    }
    unlink("$TEMPDIR/parts/$part")
      or die "Can't unlink $TEMPDIR/parts/$part: $!";
    return 1;
}

# use external "uncompress" program
sub do_uncompress(@) {
    my $part = shift;

    return 0 if (!$uncompress);
    do_log(4,"Uncompressing $part");

    $some_compression++;

    my $newpart = "$TEMPDIR/parts/" . getfilename();

    system("$uncompress < $TEMPDIR/parts/$part > $newpart");
    if ($?) {
	unlink("$newpart") or die "Can't unlink $newpart: $!";
	return 0;
    }
    unlink("$TEMPDIR/parts/$part")
      or die "Can't unlink $TEMPDIR/parts/$part: $!";
    return 1;
}

# use external program to expand RAR archives
sub do_unrar(@) {
    my $part = shift;
    my $exec = shift;

    return 0 if (!$unrar);

    # Check whether we can really unrar it
    my $rv1 = system($unrar, 't', '-p-', '-inul', "$TEMPDIR/parts/$part");
    do_log(4, sprintf("unrar 't' returned status %d (signal %d), command: %s",
		      $rv1>>8, $rv1&255, $unrar)) if $rv1;
    return 0 unless grep {$_ == ($rv1>>8)} (0,1,3);  # SUCCESS, WARNING, CRC_ERROR

    do_log(4,"Expanding RAR archive $part");

    $some_compression++;

    my @list = ();

    # We have to jump through hoops because there is no simple way to
    # just list all the files

    open(INPART, "$unrar v $TEMPDIR/parts/$part|") or die "Can't run unrar: $!";

    my $hypcount = 0;
    my $encryptedcount = 0;
    while(<INPART>) {
	chop;
	if (/^unexpected end of archive/) {
	    last;
	} elsif (/^------/) {
	    $hypcount++;
	    last if ($hypcount == 2);
	} elsif ($hypcount == 1) {
	    if (/^\s{3}/) {
		# skip information lines
	    } elsif (/^\*/) {
		# discard password-protected files - makes no sense extracting
		$encryptedcount++;
	    } elsif (/\/$/) {
		# discard directories (???not that there are any)
	    } else {
		s/^.//;  # discard first character (space or an asterisk)
		push(@list, $_);
	    }
	}
    }
    close(INPART) or die "Can't get a list of archive members from unrar: $?";

    if (!@list && $encryptedcount > 0) {
	do_log(0, sprintf("unrar: all %d members are encrypted, AV checks skipped",
			  $encryptedcount));
    }
    my $rv = store_mgr(\@list, "$TEMPDIR/parts/$part", $unrar, 'p', '-p-', '-inul');
    do_log(0, sprintf("unrar returned status %d (signal %d)",
		      $rv>>8, $rv&255)) if $rv;

    if (!$exec) {
	unlink("$TEMPDIR/parts/$part")
	  or die "Can't unlink $TEMPDIR/parts/$part: $!";
    }
    return 1;
}

# use external program to expand LHA archives
sub do_lha(@) {
    my $part = shift;
    my $exec = shift;
    my $checkerr = undef;

    return 0 if (!$lha);

    # Check whether we can really lha it
    open(LHA, "$lha lq $TEMPDIR/parts/$part 2>&1 |")
      or die "Can't run LHA: $!";
    while(<LHA>) {
	$checkerr = 1 if (/Checksum error/i);
    }
    close(LHA) or die "Error running LHA: $?";
    return 0 if ($? || $checkerr);

    do_log(4,"Expanding LHA archive $part");

    $some_compression++;

    my @list = ();

    open(INPART, "$lha lq $TEMPDIR/parts/$part|");
    while(chop($_=<INPART>)) {
	next if /\/$/o;
	push(@list, (split(/\s+/))[-1]);
    }
    close(INPART);

    my $rv = store_mgr(\@list, "$TEMPDIR/parts/$part", $lha, 'pq');
    do_log(0, sprintf("lha returned status %d (signal %d)",
		      $rv>>8, $rv&255)) if $rv;

    if (!$exec) {
	unlink("$TEMPDIR/parts/$part")
	  or die "Can't unlink $TEMPDIR/parts/$part: $!";
    }
    return 1;
}

# use external program to expand ARC archives
sub do_arc(@) {
    my $part = shift;

    return 0 if (!$arc);
    do_log(4,"Unarcing $part");

    $some_compression++;

    # may need to add error handling
    my @list = qx($arc ln $TEMPDIR/parts/$part);
    chop (@list);

    my $rv = store_mgr(\@list, "$TEMPDIR/parts/$part", $arc, 'p');
    do_log(0, sprintf("arc returned status %d (signal %d)",
		      $rv>>8, $rv&255)) if $rv;

    unlink("$TEMPDIR/parts/$part")
      or die "Can't unlink $TEMPDIR/parts/$part: $!";
    return 1;
}

# use external program to expand ZOO archives
sub do_zoo(@) {
    my $part = shift;

    return 0 if (!$zoo);
    do_log(4,"Expanding ZOO archive $part");

    # Zoo needs extension of .zoo!
    symlink("$TEMPDIR/parts/$part", "$TEMPDIR/parts/$part.zoo");

    $some_compression++;

    my @list = qx($zoo lf1q $TEMPDIR/parts/$part);
    chop (@list);

    my $rv = store_mgr(\@list, "$TEMPDIR/parts/$part", $zoo, 'xpqqq:');
    do_log(0, sprintf("zoo returned status %d (signal %d)",
		      $rv>>8, $rv&255)) if $rv;

    unlink("$TEMPDIR/parts/$part.zoo")
      or die "Can't unlink $TEMPDIR/parts/$part.zoo: $!";
    unlink("$TEMPDIR/parts/$part")
      or die "Can't unlink $TEMPDIR/parts/$part: $!";
    return 1;
}

# use external program to expand ARJ archives
sub do_unarj(@) {
    my $part = shift;

    return 0 if (!$unarj);
    do_log(4,"Expanding ARJ archive $part");

    # unarj needs extension of .arj!
    symlink("$TEMPDIR/parts/$part", "$TEMPDIR/parts/$part.arj")
	or die "Can't symlink $TEMPDIR/parts/$part $TEMPDIR/parts/$part.arj: $!";

    $some_compression++;

    # unarj has very limited extraction options!  This may not be secure!
    mkdir("$TEMPDIR/arj", 0700) or die "Can't mkdir $TEMPDIR/arj: $!";
    chdir("$TEMPDIR/arj") or die "Can't chdir to $TEMPDIR/arj: $!";

    my($rv) = system("$unarj e $TEMPDIR/parts/$part > /dev/null");

    # nonzero exit status does not mean no files were extracted!
    # (example: status 1 may indicate one of the members has a bad CRC)

    my $f;
    opendir(ARJDIR, "$TEMPDIR/arj")
	or die "Can't open directory $TEMPDIR/arj: $!";
    while (defined($f = readdir(ARJDIR))) { 
	next if ($f =~ /^\.\.?$/) && -d("$TEMPDIR/arj/$f");
	my $newpart = "$TEMPDIR/parts/" . getfilename();
	$f = $1  if $f =~ /^(.*)$/;   # fool the taint checker
	move ("$TEMPDIR/arj/$f", $newpart)
	    or die "Can't move $TEMPDIR/arj/$f to $newpart: $!";
    }
    closedir(ARJDIR) or die "Can't close directory: $!";
    chdir("$TEMPBASE") or die "Can't chdir to $TEMPBASE: $!";
    rmdir_flat("$TEMPDIR/arj") if -d "$TEMPDIR/arj";

    unlink("$TEMPDIR/parts/$part.arj")
	or die "Can't unlink $TEMPDIR/parts/$part.arj: $!";
    unlink("$TEMPDIR/parts/$part")
	or die "Can't unlink $TEMPDIR/parts/$part: $!";

    do_log(0, sprintf("unarj returned status %d (signal %d)",
		      $rv>>8, $rv&255)) if $rv;
    die "Command $unarj failed: $!"  if $rv == 0xff00;
    die "$unarj failed, status 127"  if $rv == 0x7f00;
    return 1;
}

# use Convert-TNEF
sub do_tnef(@) {
    my $part = shift;

    do_log(4,"Extracting TNEF attachment $part");

    chdir("$TEMPDIR/parts") or die "Can't chdir to $TEMPDIR/parts: $!";
    my $tnef = Convert::TNEF->read_in("$TEMPDIR/parts/$part",{ignore_checksum=>"true"});

    if ($tnef) {
	for ($tnef->attachments) {
	    if (my $handle = $_->datahandle) {
		my $newpart = "$TEMPDIR/parts/" . getfilename();

		open(OUTPART, ">$newpart")
		  or die "Can't write to $newpart: $!";
		if (defined(my $file = $handle->path)) {
		    copy($file, \*OUTPART);
		} else {
		    print OUTPART $handle->as_string;
		}
		close(OUTPART) or die "Can't close $newpart: $!";
	    }
	}

	$tnef->purge;

	unlink("$TEMPDIR/parts/$part")
	  or die "Can't unlink $TEMPDIR/parts/$part: $!";
    } else {
	# Not TNEF - treat as atomic
	return 0;
    }

    chdir("$TEMPBASE") or die "Can't chdir to $TEMPBASE: $!";
    return 1;
}

# Check for self-extracting archives.  Note that we don't rely on
# file magic here since it's not reliable.  Instead we will try each
# archiver.
sub do_executable(@) {
    my $part = shift;

    do_log(4,"Check whether $part is a self-extracting archive");

    # ZIP?
    return 2 if eval{do_unzip($part,1)};
    chomp($@);
    do_log(0,"do_executable/do_unzip failed, ignoring: $@") if $@;

    # RAR?
    return 2 if eval{do_unrar($part,1)};
    chomp($@);
    do_log(0,"do_executable/do_unrar failed, ignoring: $@") if $@;

    # LHA?
    return 2 if eval{do_lha($part,1)};
    chomp($@);
    do_log(0,"do_executable/do_unlha failed, ignoring: $@") if $@;

    return 0;
}

#
# Utility routines

# extract listed files from archive and store in new file
sub store_mgr(@) {
    my ($list, $archive, $cmd, @args) = @_;
    my $newpart = '';
    my @rv;

    for (@$list) {
	next if (/\/$/);		# Ignore directories
	$newpart = "$TEMPDIR/parts/" . getfilename();

	my $rv;
	open(FH, ">$newpart") or die "Can't create $newpart: $!";
	$rv = fh_copy(\*FH, $cmd, @args, $archive, $_);
#	do_log(4, sprintf('extracting %s to file %s, status %d (signal %d)',
#		  sanitize_str($_), $newpart, $rv>>8, $rv&255));
	push(@rv,$rv);
	close(FH) or die "Can't close $newpart: $!";
    }
    @rv = grep {$_ != 0} @rv;
    return (@rv>0 ? $rv[0] : 0);	# just return the first
					# nonzero status (if any), or 0
}

#
# Locking/logging/exiting

#
sub setup_logging() {
    if ($DO_SYSLOG eq "yes") {
	($FACILITY = $SYSLOG_LEVEL) =~ s/(\w+)\.(\w+)/LOG_\U$1/;
	($PRIORITY = $SYSLOG_LEVEL) =~ s/(\w+)\.(\w+)/LOG_\U$2/;
	openlog("amavis", LOG_PID, eval "$FACILITY");
    } else {
	$log = new IO::File;
	$log->open(">>$LOGDIR/$LOGFILE") || die "Failed to open log file: $!";
    }
}

# Log either to syslog or a file
sub do_log(@) {
    my $level = shift;
    my $errmsg = shift;

    return unless ($errmsg);

    # create syslog-alike
    my $logline = strftime("%b %e %H:%M:%S ", localtime) . (uname)[1] . " $myname\[$$\]: $errmsg\n";

    if ($DEBUG eq "no") {
	if ($level <= $log_level) {
	    if ($DO_SYSLOG eq "yes") {
		syslog(eval "$PRIORITY", "%s", $errmsg);
	    } else {
		lock($log);
		print($log $logline);
		unlock($log);
	    }
	}
    } else {
	# Log everything, regardless of level
	print STDERR $logline;
    }
}

# Log (Resent-)Message-ID header
sub log_msg_id(@) {
    my $level = shift;
    my $msgid = $entity->head->get("Resent-Message-ID");
    my $resent = "resent-";

    unless ($msgid) {
	$msgid = $entity->head->get("Message-ID");
	$resent = "";
    }

    chomp ($msgid);
    do_log($level,"$resent" . "message-id=$msgid");
}

#
# Produce syntactically correct local part of an e-mail address
# using quoted-string form if needed, as per rfc2821.
sub rfc2821_mailbox_addr {
    my($mailbox) = @_;
    # atext: any character except controls, SP, and specials (rfc2821/rfc2822)
    my($atext) = "a-zA-Z0-9!#\$%&'*/=?^_`{|}~+-";
    # my($specials) = '()<>\[\]\\\\@:;,."';
    my($localpart,$domain);
    if ($mailbox =~ /^(.*)(\@[^@]*)$/o) {
	($localpart,$domain) = ($1,$2)  
    } else {
	($localpart,$domain) = ($mailbox,'');
    }
    if ($localpart !~ /^[$atext]+(\.[$atext]+)*$/o) {  # not dot-atom
	$localpart =~ s/(["\\])/\\$1/g;       # quoted-pair
	$localpart = '"' . $localpart . '"';  # make a qcontent out of it
    }
    $localpart . $domain;
}

#
# Removes a directory, along with its contents
sub rmdir_recursively(@) {
    my $dir = shift;
    my $f;
    local *DIR;
    opendir(DIR, $dir) or die "Can't open directory $dir: $!";
    while (defined($f = readdir(DIR))) { 
	next if $f !~ /^(.+)$/;
	$f = $1;  # untaint
	if (-d "$dir/$f") {
	    rmdir_recursively("$dir/$f")  unless $f =~ /^\.\.?$/;
	} else {
	    unlink("$dir/$f") or die "Can't remove file $dir/$f: $!";
	}
    }
    closedir(DIR) or die "Can't close directory $dir: $!";
    rmdir($dir) or die "Can't remove directory $dir: $!";
    1;
}

#
# Removes a directory, along with its contents
# Does not do it recursively - refuses to delete any subdirectories
sub rmdir_flat($) {
    my $dir = shift;
    my $f;
    opendir(DIR, $dir) or die "Can't open directory $dir: $!";
    while (defined($f = readdir(DIR))) { 
	next if $f !~ /^(.+)$/;
	$f = $1;  # untaint
	if (-d "$dir/$f") {
	    die "Refused to unlink a subdirectory $dir/$f" unless $f =~ /^\.\.?$/;
	} else {
	    unlink("$dir/$f") or die "Can't remove file $dir/$f: $!";
	}
    }
    closedir(DIR) or die "Can't close directory $dir: $!";
    rmdir($dir) or die "Can't remove directory $dir: $!";
    1;
}

#
sub lock(@) {
    my $file = shift;
    flock($file, LOCK_EX) or die "Can't lock $file: $!";
    seek($file, 0, 2) or die "Can't position $file to its tail: $!";
}

#
sub unlock(@) {
    my $file = shift;
    flock($file, LOCK_UN) or die "Can't unlock $file: $!";
}

#
sub retcode($) {
    my $code = shift;

    return WEXITSTATUS($code) if WIFEXITED($code);
    return 128+WTERMSIG($code) if WIFSIGNALED($code);
    return 255;
}

#
sub do_exit(@) {
    my $code = shift;
    my $line = shift;

    do_log(($code==0?1:0), "do_exit:$line - ending execution with $code");

    $fh->close() if ($fh);

    rmdir_recursively("$TEMPDIR") if ($TEMPDIR && -d $TEMPDIR);

    if (\&Client) {
	send Client, "$code", 0;
	shutdown Client, 2; # shutdown socket completely
	Client->close();
	do_log(3,"socket shut down");
    }

    # if \&Server ?
    if ($$ == $parentpid) {
	unlink("$TEMPBASE/amavisd.pid");
	do_log(3,"removed pid file");
	unlink("$socketname");
	do_log(3,"removed socket");
    }

    ($DO_SYSLOG eq "yes") ? closelog() : $log->close();

    exit($REGERR) unless ($code == 0);
    exit(0);
}

#
# Convert nonprintable characters in the argument
# to \[rnftbe], or \octal code, and '\' to '\\',
# returning the sanitized string.
sub sanitize_str {
	my($str) = @_;
	my(%map) = ("\r"=>'\r', "\n"=>'\n', "\f"=>'\f', "\t"=>'\t',
		    "\b"=>'\b', "\e"=>'\e', "\\"=>'\\\\');
	$str =~ s/([\000-\037\177\200-\237\377\134])/
		 exists($map{$1}) ? $map{$1} : sprintf("\\%03o",ord($1))/eg;
	$str;
}

#
# Main program starts here
#

# Set path explictly.  Don't trust environment
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

# detach thyself from the controlling terminal
daemonize() if ($DEBUG eq "no");

# save pid into file
# FIXME: do it in perl; exit if already exists
$parentpid = $$;
system("echo $parentpid >$TEMPBASE/amavisd.pid");

# Read config file
read_config();

# Be paranoid
umask(0077);

# Avoid taint bug in some versions of Perl (likely in 5.004, 5.005).
# The 5.6.1 is fine. To test, run this one-liner:
#   perl -Te '"$0 $$"; $r=$$; print eval{kill(0,$$);1}?"OK\n":"BUG\n"'
basename($0) =~ /^(.*)$/; $myname = $1;

setup_logging();

do_log(0,"starting.  $myname snapshot-20020531 Fri Jul 11 06:07:34 EDT 2003");

setup_socket() || die "socket setup failure: $!";

main_loop();

# Safeguard - shouldn't get here
do_exit(0, __LINE__);

