#!/usr/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;
my $prefix = "/usr";

#
# Configurable constants
#

# Config file
my $config_file = "/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/";

#
# 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 $fsav $inocucmd
  $mks $nod32 $nod32cli $oav $panda $rav $sophos $sophos_ide_path $cscmdline
  $scs_host $scs_port $uvscan $vbengcl $vscan $vfind $sophie_sockname
  $trophie_sockname );

use vars qw ( $QUARANTINEDIR $VIRUSFILE $viruslist @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 = "${prefix}/../var/lib/amavis";
use vars '$TEMPDIR';

#
# Client/server/daemon related

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

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

#
# MTA init section
#

# postfix

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

# don't run suid

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

# End postfix
#
# 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: $!";
    setsid                    or die "Can't start a new session: $!";
    if ($pid) {
      $log = new IO::File;
      $log->open(">/var/run/amavisd.pid");
      print($log $pid."\n");
      $log->close();
      exit;
    }

    my @user = getpwnam("amavis") or die "Can't getpwnam amavis: $!";
    $( = $) = $user[3];
    $< = $> = $user[2];
    $> = $) = 0;
    $( = $( = 0;
    ($>!=0) && ($)!=0) or die "Cannot drop privs: $!";
    ($<!=0) && ($(!=0) or die "Cannot drop privs: $!";
    open STDERR, '>&STDOUT'   or die "Can't dup stdout: $!";
}

#
# Set up signal handling

# 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;
}

# 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;



	# 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 = "<>" if (!$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
	    # Note: to get the qmail config working again, we now read the
	    # actual message (STDIN) before the envelope information (STDOUT)

	    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;\n  " . $@);
	    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!
    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.
    #


#
# OpenAntiVirus ScannerDaemon
#
use IO::Socket;
 
if ($oav) {
    do_log(2,"Using $oav");
    my $sock = IO::Socket::INET->new('127.0.0.1:8127');
    if (defined $sock) {
# Not required! Lars
#	$sock->connect('');
	$sock->print("SCAN $TEMPDIR/parts\n");
	$sock->flush;
	chomp($output = $sock->getline);
	$sock->close;
	$scanner_errors = 0;
	do_log(2,$output);
	if ($output =~ /^FOUND: /) {
	    @virusname = ($output =~ /FOUND: (.+);/g);
	    do_virus();
	}
   } else {
	$scanner_errors &= 1;
	do_log(0,"Virus scanner failure: ScannerDaemon - can't connect to daemon");
   }
}


#
# KasperskyLab AVP
#

if ($avp) {
    do_log(2,"Using $avp");
    chdir($AVPDIR) || do_exit($REGERR, __LINE__);
    chop($output = `$avp -* -P -B -Y -O- $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    chdir($TEMPBASE);
    do_log(2,$output);
    if ($errval) {
	if ($errval == 4) {
	    @virusname = ($output =~ /infected: (.+)/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $avp (error code: $errval)");
	}
    }
}

#
# KasperskyLab AVPDaemonClient
#

if ($avpdc) {
    do_log(2,"Using $avpdc");
    chop($output = `$avpdc $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 4) {
	    @virusname = ($output =~ /infected: (.+)/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $avpdc (error code: $errval)");
	}
    }
}

#
# CAI InoculateIT
#

if ($inocucmd) {
    do_log(2,"Using $inocucmd");
    chop($output = `$inocucmd -sec -nex $TEMPDIR/parts/*`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 100) {
	    @virusname = ($output =~ /was infected by virus (.+)/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $inocucmd (error code: $errval)");
	}
    }
}

#
# Command AntiVirus for Linux
#

if ($csav) {
    do_log(2,"Using $csav");
    chop($output = `$csav -all -archive -packed $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval != 50) {
	if ($errval >= 51 || $errval <= 53) {
	    @virusname = ($output =~ /Infection: (.+)/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $csav (error code: $errval)");
	}
    }
}

#
# CyberSoft VFind
#

if ($vfind) {
    do_log(2,"Using $vfind");
    chop($output = `$vfind -vexit $TEMPDIR/parts/*`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 23) {
	    @virusname = ($output =~ /##==>>>> VIRUS ID: CVDL (.+)/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $vfind (error code: $errval)");
	}
    }
}

#
# 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($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 1) {
	    @virusname = ($output =~ /infected with (.+)/g);
	    do_virus($output);
	} else {
	    do_log(0,"Virus scanner failure: $drweb (error code: $errval)");
	}
    }
}

#
# F-Prot Antivirus/Linux
#

if ($fprot) {
    do_log(2,"Using $fprot");
    chop($output = `$fprot -DUMB -ARCHIVE $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 3) {
	    @virusname = ($output =~ /Infection: (.+)/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $fprot (error code: $errval)");
	}
    }
}

#
# F-Secure Antivirus/Linux
#

if ($fsav) {
    do_log(2,"Using $fsav");
    chop($output = `$fsav --dumb --archive $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 3 || $errval == 8) {
	    @virusname = ($output =~ /infection: (.+)/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $fsav (error code: $errval)");
	}
    }
}

#
# H+B EDV AntiVir
#

if ($antivir) {
    do_log(2,"Using $antivir");
    chop($output = `$antivir -allfiles -noboot -s -z $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 1) {
	    @virusname = ($output =~ /VIRUS: .* virus (.+)/ig);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $antivir (error code: $errval)");
	}
    }
}

#
# MkS_Vir for Linux (beta)
#

if ($mks) {
    do_log(2,"Using $mks");
    chop($output = `$mks -e -c $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 1) {
	    @virusname = ($output =~ /-- (.+)/g);
	    do_virus($output);
	} else {
	    do_log(0,"Virus scanner failure: $mks (error code: $errval)");
	}
    }
}

#
# McAfee
# 

if ($uvscan) {
    do_log(2,"Using $uvscan");
    chop($output = `$uvscan --secure -rv --summary --noboot $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 13) {
	    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);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $uvscan (error code: $errval)");
	}
    }
}

#
# ESET Software NOD32
# preliminary support - may not work at all!
# untested! 

if ($nod32) {
    do_log(2,"Using $nod32");
    chop($output = `$nod32 -subdir+ $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 1) {
	    @virusname = "(unspecified)";
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $nod32 (error code: $errval)");
	}
    }
}

# List of Return Codes
#define NOD32_EXIT_CODE_OK               0
#define NOD32_EXIT_CODE_VIRUS            1
#define NOD32_EXIT_CODE_CLEANED          2
#define NOD32_EXIT_INTERNAL_ERROR        10


#
# ESET Software NOD32 - Client/Server Version
#

if ($nod32cli) {
    do_log(2,"Using $nod32cli");
    chop($output = `$nod32cli -a -r -d recurse --heur standard $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 10) {
	    @virusname = ($output =~ /.* infected: (.+)/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $nod32cli (error code: $errval)");
	}
    }
}

# List of Return Codes
#define NOD32_EXIT_CODE_OK             0
#define NOD32_EXIT_CODE_NO_SERVER      1
#define NOD32_EXIT_CODE_INTERNAL_ERROR 2
#define NOD32_EXIT_CODE_VIRUS          10
#define NOD32_EXIT_CODE_CLEANED        11
#define NOD32_EXIT_CODE_SCANNING_ERROR 12


#
# Panda
#

if ($panda) {
    do_log(2,"Using $panda");
    $ENV{TERM} = "vt100";
    chop($output = `$panda $TEMPDIR/parts -aut -eng -heu -nso -aex -nor -cmp < /dev/null`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    # Clean the output file of control chars
    # Clean the escape sequences
    $output =~ s/\e\133(..)G/\n/g;
    $output =~ s/\e(.*?)[A-Z,a-z,>]//g;
    # Clean ^O
    $output =~ s/\017//g;
    # Clean ^H
    $output =~ s/\010(\010+?)\010/\010/g;
    $output =~ s/\010/\n/g;
    # Clean ^M
    $output =~ s/\015//g;
    do_log(2,$output);

    if ($errval) {
	my $loutput = $output;
	my @numVirus = ($loutput =~ /Number of files infected............:(.+)/gm);
	if($numVirus[0] > 0) {
	    @virusname = ($output =~ /Found virus :(.+)/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $panda (error code: $errval)");
	}
    }
}


#
# GeCAD RAV AntiVirus 8
#
# NOTE: the command line switches changed with scan engine 8.5 !
#

if ($rav) {
    do_log(2,"Using $rav");
    chop($output = `$rav --all --archive --mail $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval && $errval > 1) {
	if ($errval == 2 || $errval == 3) {
	    @virusname = ($output =~ /Infected: (.+)/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $rav (error code: $errval)");
	}
    }
}

# List of Return Codes
#FILE_OK              1
#FILE_INFECTED        2
#FILE_SUSPICIOUS      3
#FILE_CLEANED         4
#FILE_CLEAN_FAIL      5
#FILE_DELETED         6
#FILE_DELETE_FAIL     7
#FILE_COPIED          8
#FILE_COPY_FAIL       9
#FILE_MOVED           10
#FILE_MOVE_FAIL       11
#FILE_RENAMED         12
#FILE_RENAMED_FAIL    13

#NO_FILES             20

#ENG_ERROR            30
#SINTAX_ERR           31
#HELP_MSG             32
#VIR_LIST             33


#
# Sophos Anti Virus via Sophie
#
use IO::Socket;
$|=1;


if ($sophie_sockname) {
    do_log(2,"Using Sophie");
    socket(\*sock, AF_UNIX, SOCK_STREAM, 0) || do_exit($REGERR, __LINE__);
    connect(\*sock, pack_sockaddr_un $sophie_sockname) || do_exit($REGERR, __LINE__);

    my $chkdir = "$TEMPDIR/parts/\n";
    defined syswrite(\*sock, $chkdir, length($chkdir))
	or die "syswrite to Sophie failed: $!";
    defined sysread(\*sock, $output, 256)
	or die "sysread from Sophie failed: $!";

    chomp($output);
    $output =~ s/[^\w\d\-._:\/]+//g;
    do_log(2,$output);

    close(\*sock) or die "Sophie socket close failed: $!";

    $scanner_errors = 0;

    if ($output =~ m/^1/) {
	if ($output =~ m/^1:.*$/) {
	    @virusname = ($output =~ m/^1:'?(.*)'?$/g);
	}
	do_virus();
    } elsif ($output == -1) {
	$scanner_errors &= 1;
	do_log(0,"Virus scanner failure: Sophie - UNKNOWN STATUS (error code: $output)");
    } elsif ( ($output != 1) && ($output != 0) && ($output != -1) ) {
	$scanner_errors &= 1;
	do_log(0,"Virus scanner failure: Sophie - OOOPS (error code: $output)");
    }
}

#
# Sophos Anti Virus
#

if ($sophos) {
    do_log(2,"Using $sophos");
    $ENV{SAV_IDE} = $sophos_ide_path if ($sophos_ide_path);
    chop($output = `$sophos -nb -f -all -rec -ss -sc -archive $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 3) {
	    my $loutput = $output;
	    $loutput =~ s/Virus fragment/Virus/g;
	    @virusname = ($loutput =~ /Virus (.+) found/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $sophos (error code: $errval)");
	}
    }
}

#
# Symantec CarrierScan via Symantec CommandLineScanner
# TODO: avoid using CommandLineScanner by writing an own perl client
#

if ($cscmdline) {
    do_log(2, "Using $cscmdline");
    chop($output = `$cscmdline -a scan -i 1 -v -s $scs_host:$scs_port $TEMPDIR/parts`);
    do_log(2,$output);
    $scanner_errors = 0;
    if ($output =~ /\nInfected: /) {
        @virusname = ($output =~ /Info:\s+(.+)/g);
	do_virus();        
    } elsif ($output =~ /\n\*+ ERROR!/) {
        $scanner_errors &= 1;
        my @error_reason = ($output =~ /\n\*+ ERROR!\s+ (.+)/g);
	do_log(0, "Virus scanner failure: Symantec Carrier Scan - " . shift @error_reason); 
    }
}	

#
# Trend Micro FileScan API via Trophie
#
use IO::Socket;
$|=1;


if ($trophie_sockname) {
    do_log(2,"Using Trophie");
    socket(\*sock, AF_UNIX, SOCK_STREAM, 0) || do_exit($REGERR, __LINE__);
    connect(\*sock, pack_sockaddr_un $trophie_sockname) || do_exit($REGERR, __LINE__);

    opendir(DIR, "$TEMPDIR/parts/") || do_exit($REGERR, __LINE__);
    my @files = grep { -f "$TEMPDIR/parts/$_" } readdir(DIR);             	
    chomp(@files);
    foreach my $file (@files) {
	if ($file =~ /^([\w\d\-.]+)$/) {
	    $file = $1;
       	} else {
	    do_log(0,"Unsafe partname $file");
	    do_exit($REGERR, __LINE__); 
	}
	# needed "\n", otherwise it won't work
	$file = "$TEMPDIR/parts/$file\n";
	
	syswrite(\*sock, $file, length($file))
	  or die "syswrite to Trophie failed: $!";
	sysread(\*sock, $output, 256)
	  or die "sysread from Trophie failed: $!";

	chomp($output);
	$output =~ s/[^\w\d\-._:\/]+//g;
	do_log(2,"Trophie: $file - $output");
	last if ($output =~ m/^1/); 
    }
#    $errval = ($? >> 8);
#    do_log(2,$output);

    close(\*sock) or die "Trophie socket close failed: $!";

    $scanner_errors = 0;

    if ($output =~ m/^1/) {
	if ($output =~ m/^1:.*$/) {
	    @virusname = ($output =~ m/^1:(.*)$/g);
	}
	do_virus();
    } elsif ($output == -1) {
	$scanner_errors &= 1;
	do_log(0,"Virus scanner failure: Trophie - UNKNOWN STATUS (error code: $output)");
    } elsif ( ($output != 1) && ($output != 0) && ($output != -1) ) {
	$scanner_errors &= 1;
	do_log(0,"Virus scanner failure: Trophie - OOOPS (error code: $output)");
    }
}

#
# Trend FileScanner/Linux
#

if ($vscan) {
    do_log(2,"Using $vscan");
    chop($output = `$vscan -a $TEMPDIR/parts/*`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 1 || $errval == 2) {
	    @virusname = ($output =~ /Found virus (.+) in/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $vscan (error code: $errval)");
	}
    }
}

#
# VirusBuster (Client + Daemon)
#

if ($vbengcl) {
    do_log(2,"Using $vbengcl");
    chop($output = `$vbengcl -f -log scandir $TEMPDIR/parts 2>&1`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	# HINT: for an infected file it returns always 3,
	# although the man-page tells me a different story ...
	if ($errval == 3) {
	    # needs to be FIXED
	    @virusname = ($output =~ /Virus found = (.*);/g);
	    do_virus();
	} else {
	    do_log(0,"Virus scanner failure: $vbengcl (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, SMTP version
    # mail is piped back to postfix through a specific port
    # all SMTP methods return true (1) on success

    use Net::SMTP;
    my $SMTP_HANDLE = Net::SMTP->new("$localhost_ip:$smtp_port",
				Hello => "$localhost_name",
				Timeout => 30,
				Debug => 0
				);
    defined($SMTP_HANDLE) or die "Failure to connect to local SMTP port: $!";
    my($sender) = "<" . rfc2821_mailbox_addr($SENDER) . ">";
    if (!$SMTP_HANDLE->mail($sender)) {
	my($smtp_status) = $SMTP_HANDLE->status;
	my($smtp_msg) = $SMTP_HANDLE->code ." ". $SMTP_HANDLE->message();
	$SMTP_HANDLE->quit;
	if ($smtp_status == 5) {
	    do_log(0,"Rejected by MTA: $smtp_msg"); do_exit(1, __LINE__);
	} else {
            die ( ($smtp_status == 4 ? "Temporary reject by MTA: "
				   : "Retry later, MTA said: ") . $smtp_msg);
	}
    }
    # The rfc2821_mailbox_addr() cleanup is necessary because addresses
    # we get from MTA are raw, with stripped-off quoting. To re-insert
    # them back via SMTP, the local-part needs to be quoted again
    # if it contains reserved characters or otherwise does not obey
    # the dot-atom syntax, as required per rfc2821. Failing to do that
    # gets us into trouble: amavis accepts message from MTA,
    # but is unable to hand it back to MTA after checking,
    # receiving '501 Bad address syntax' with every attempt.
    #
    my(@recips_2821) = map { "<".rfc2821_mailbox_addr($_).">" } @RECIPS;
    if (!$SMTP_HANDLE->recipient(@recips_2821)) {
	my($smtp_status) = $SMTP_HANDLE->status;
	my($smtp_msg) = $SMTP_HANDLE->code ." ". $SMTP_HANDLE->message();
	$SMTP_HANDLE->quit;
	if ($smtp_status == 5) {
	    do_log(0,"Rejected by MTA: $smtp_msg"); do_exit(1, __LINE__);
	} else {
            die ( ($smtp_status == 4 ? "Temporary reject by MTA: "
				   : "Retry later, MTA said: ") . $smtp_msg);
	}
    }
    if (!$SMTP_HANDLE->data()) {
	my($smtp_status) = $SMTP_HANDLE->status;
	my($smtp_msg) = $SMTP_HANDLE->code ." ". $SMTP_HANDLE->message();
	$SMTP_HANDLE->quit;
	if ($smtp_status == 5) {
	    do_log(0,"Rejected by MTA: $smtp_msg"); do_exit(1, __LINE__);
	} else {
            die ( ($smtp_status == 4 ? "Temporary reject by MTA: "
				   : "Retry later, MTA said: ") . $smtp_msg);
	}
    }
    my($skip_header_continuation) = 0;
    $fh->seek(0,0) or die "Can't rewind mail file: $!";
    while (<$fh>) {
	last if /^\r?\n$/;  # end-of-header reached
	if ($skip_header_continuation && /^[ \t]/) {
	    # discard
	} else {
	    $skip_header_continuation = 0;
	    $SMTP_HANDLE->datasend($_)
		or die "Net::SMTP::datasend failed: ".
			$SMTP_HANDLE->code() ." ". $SMTP_HANDLE->message();
	}
    }
    $_ = "";
    $_ .= "$X_HEADER_TAG: $X_HEADER_LINE\n" if $X_HEADER_LINE and
					       $X_HEADER_TAG =~ /^[!-9;-\176]+$/;
    $_ .= "\n";
    $SMTP_HANDLE->datasend($_)
	or die "Net::SMTP::datasend failed: ".
		$SMTP_HANDLE->code() ." ". $SMTP_HANDLE->message();
    for (;;) {
	$fh->read($_,16384);  # using fixed-size reads instead of line-by-line
			      # approach by <$fh>, makes feeding mail back to
	last if $_ eq '';     # Postfix more than twice as fast for larger mail
        if (!$SMTP_HANDLE->datasend($_)) {
	    my($smtp_status) = $SMTP_HANDLE->status;
	    my($smtp_msg) = $SMTP_HANDLE->code ." ". $SMTP_HANDLE->message();
	    $SMTP_HANDLE->quit;
	    if ($smtp_status == 5) {
		do_log(0,"Rejected by MTA: $smtp_msg"); do_exit(1, __LINE__);
	    } else {
		die ( ($smtp_status == 4 ? "Temporary reject by MTA: "
				       : "Retry later, MTA said: ") . $smtp_msg);
	    }
	}
    }
    if (!$SMTP_HANDLE->dataend()) {
	my($smtp_status) = $SMTP_HANDLE->status;
	my($smtp_msg) = $SMTP_HANDLE->code ." ". $SMTP_HANDLE->message();
	$SMTP_HANDLE->quit;
	if ($smtp_status == 5) {
	    do_log(0,"Rejected by MTA: $smtp_msg"); do_exit(1, __LINE__);
	} else {
	    die ( ($smtp_status == 4 ? "Temporary reject by MTA: "
				   : "Retry later, MTA said: ") . $smtp_msg);
	}
    }
    if (!$SMTP_HANDLE->quit) {
	my($smtp_status) = $SMTP_HANDLE->status;
	my($smtp_msg) = $SMTP_HANDLE->code ." ". $SMTP_HANDLE->message();
	if ($smtp_status == 5) {
	    do_log(0,"Rejected by MTA: $smtp_msg"); do_exit(1, __LINE__);
	} else {
	    die (($smtp_status == 4 ? "Temporary reject by MTA: "
				   : "Retry later, MTA said: ") . $smtp_msg);
	}
    }
    return 0;

# End postfix
    } 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");

    $viruslist = join("\n\t",@virusname);

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

    log_msg_id(1);

    # 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/io);

    open(MAIL, "|$sendmail_wrapper $sendmail_wrapper_args -f$mailfrom") ||
      do_exit($REGERR, __LINE__);
	my $amavis_url = &amavisCredits();
	print 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$viruslist

virus(es) in your email to the following recipient(s):

EOF
	foreach (@RECIPS) {
		print MAIL "-> $_\n";
	}
	print 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 headers from your email:

------------------------- BEGIN HEADERS -----------------------------
EOF
	$entity->print_header(\*MAIL);
	print MAIL <<"EOF";
-------------------------- END HEADERS ------------------------------

EOF
    close(MAIL);
}

# Notify admin
sub warn_admin() {
    open(MAIL, "|$sendmail_wrapper $sendmail_wrapper_args -f$mailfrom") ||
      do_exit($REGERR, __LINE__);
	$SENDER = "(empty address)" if ($SENDER eq "<>");
	print MAIL <<"EOF";
From: $mailfrom
To: $mailto
Subject: FOUND VIRUS IN MAIL from $SENDER

A virus was found in an email from:

$SENDER

The message was addressed to: 

EOF
	foreach (@RECIPS) {
		print MAIL "-> $_\n";
	}

	if ($QUARANTINEDIR) {
		print MAIL <<"EOF";

The message has been quarantined as:

$QUARANTINEDIR/$VIRUSFILE
EOF
	}
	print MAIL <<"EOF";

Here is the output of the scanner:

$output

Here are the headers:

------------------------- BEGIN HEADERS -----------------------------
EOF
	$entity->print_header(\*MAIL);
	print MAIL <<"EOF";
-------------------------- END HEADERS ------------------------------

EOF
    close(MAIL);
}

# 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{$_} = 1 }
    # hashes are faster than arrays
    foreach (@RECIPS) {
	my $rcpt_is_local = undef;
	$rcpt_is_local = 1 if ($local_domains{(split(/>/,(split(/@/))[-1]))[0]});

	# This is a bit inefficient: we open one file per recipient
	if ($rcpt_is_local || $warn_offsite eq "yes") {
	    open(MAIL, "|$sendmail_wrapper $sendmail_wrapper_args -f$mailfrom") ||
	      do_exit($REGERR, __LINE__);
		my $amavis_url = &amavisCredits();
		$SENDER = "(empty address)" if ($SENDER eq "<>");
		print MAIL <<"EOF";
From: $mailfrom
To: $_
Subject: VIRUS IN MAIL FOR YOU FROM $SENDER

                           V I R U S  A L E R T

Our viruschecker found the

\t$viruslist

virus(es) in an email to you from:

$SENDER

Delivery of the email was stopped!

Please contact your system administrator for details.

EOF
		if ($QUARANTINEDIR) {
			print MAIL <<"EOF";
The ID of your quarantined message is:

$VIRUSFILE

EOF
		}
		print MAIL <<"EOF";
$amavis_url
EOF
	    close(MAIL);
	}
    }
}

# 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 {
	do_log(0,"Unsafe partname $part");
	do_exit($REGERR, __LINE__);
    }

    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 { foreach ($filetype) {
	local($_) = $_;  # prevent $filetype (alias $_) from being modified
	/^(ASCII|text|uuencoded|xxencoded|binhex)/io && return do_ascii($part);
	/^gzip compressed/io    && return do_gunzip($part);
	/^compress'd/io         && return do_uncompress($part);
	/^bzip2 compressed/io   && return do_bzip2($part);
	/^(GNU |POSIX )?tar archive/io && return do_tar($part);
	/^Zip archive/io        && return do_unzip($part,0);
	/^RAR archive/io        && return do_unrar($part,0);
	/^LHA.*archive/io       && return do_lha($part,0);
	/^ARC archive/io        && return do_arc($part);
	/^ARJ archive/io        && return do_unarj($part);
	/^Zoo archive/io        && return do_zoo($part);

	# file 3.32+ has an entry for TNEF
	/^(Transport Neutral Encapsulation Format|TNEF)/io && return do_tnef($part);

	# older versions of file report tnef files as data
	/^data$/o               && return do_tnef($part);

	/executable/io          && return do_executable($part);

	# Falling through - no match
	return 0;
    }; };

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

    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(DATA, "-|");  # 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 DATA, $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(DATA);
	return $?;
    }
}

# minimal local error handler for Archive-Zip read()
sub myziperr {
    return 5;
}

# minimal local error handler for Archive-Zip extractMember()
sub myzipextracterr {
    # flesh it out later
    return 5;
}

#
# 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");
	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(\&myziperr);
    $ziperr = $zip->read("$TEMPDIR/parts/" . "$part");
    Archive::Zip::setErrorHandler(\&Carp::croak);
    $Carp::CarpLevel++;

    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");
	}
    }

    unlink("$TEMPDIR/parts/$part") unless $exec;
    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");
	return 0;
    }

    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 (/.*\/$/o) {		# 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") || do_exit($REGERR, __LINE__);
	    print(OUTPART $data);
	    close(OUTPART);
	}
    }
    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") || do_exit($REGERR, __LINE__);
    open(OUTPART, ">$newpart") || do_exit($REGERR, __LINE__);

    while ($gz->gzread($buffer) > 0) {
	print(OUTPART $buffer);
    }
    close(OUTPART);

    if ($gzerrno != Z_STREAM_END) {
	unlink("$newpart");
	return 0;
    }
    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");
	return 0;
    }
    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;

    unlink("$TEMPDIR/parts/$part") unless $exec;
    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 |") || do_exit($REGERR, __LINE__);
    while(<LHA>) {
	$checkerr = 1 if (/Checksum error/io);
    }
    close(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;

    unlink("$TEMPDIR/parts/$part") unless $exec;
    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");
    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");
    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", oct('700')) 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");

    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") || do_exit($REGERR, __LINE__);
		if (defined(my $file = $handle->path)) {
		    copy($file, \*OUTPART);
		} else {
		    print OUTPART $handle->as_string;
		}
		close(OUTPART);
	    }
	}

	$tnef->purge;

	unlink("$TEMPDIR/parts/$part");
    } else {
	# Not TNEF - treat as atomic
	return 0;
    }

    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)};
    do_log(0,"do_executable/do_unzip failed, ignoring:\n".$@) if $@;

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

    # LHA?
    return 2 if eval{do_lha($part,1)};
    do_log(0,"do_executable/do_unlha failed, ignoring:\n".$@) 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 open $newpart for writing: $!";
	$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) || do_exit($REGERR, __LINE__);
    seek($file, 0, 2) || do_exit($REGERR, __LINE__);
}

#
sub unlock(@) {
    my $file = shift;
    flock($file, LOCK_UN) || do_exit($REGERR, __LINE__);
}

#
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);
}

#
# 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-20020222 Sat Apr  6 16:49:39 UTC 2002");

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

main_loop();

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

