mimedefang 2.83-1 / usr / bin / mimedefang.pl

#!/usr/bin/perl
# -*- Perl -*-
#***********************************************************************
#
# mimedefang.pl
#
# Perl scanner which parses MIME messages and filters or removes
# objectionable attachments.
#
# Copyright (C) 2000-2005 Roaring Penguin Software Inc.
#
# This program may be distributed under the terms of the GNU General
# Public License, Version 2, or (at your option) any later version.
#
# This program was derived from the sample program "mimeexplode"
# in the MIME-Tools Perl module distribution.
#
#***********************************************************************

use warnings;
use strict;

# Move site library directory ahead of default library directory in @INC.
# That's so we can sanely package our own version of MIME::Base64 that
# won't conflict with the built-in one on RPM-based platforms.
use lib '/usr/local/share/perl/5.26.1';

require 5.008;
package main;

# My deepest apologies for this mess of globals...
use vars qw($AddWarningsInline @StatusTags
	    $Action $Administrator $AdminName $AdminAddress $DoStatusTags
	    $Changed $CSSHost $DaemonAddress $DaemonName
	    $DefangCounter $Domain $EntireMessageQuarantined
	    $MessageID $Rebuild $QuarantineCount
	    $QuarantineSubdir $QueueID $MsgID $MIMEDefangID
	    $RelayAddr $WasResent $RelayHostname
	    $RealRelayAddr $RealRelayHostname
	    $ReplacementEntity $Sender $ServerMode $Subject $SubjectCount
	    $ClamdSock $SophieSock $TrophieSock
	    $SuspiciousCharsInHeaders
	    $SuspiciousCharsInBody $Helo @ESMTPArgs
	    @SenderESMTPArgs %RecipientESMTPArgs
	    $TerminateAndDiscard $URL $VirusName
	    $CurrentVirusScannerMessage @AddedParts
	    $VirusScannerMessages $WarningLocation $WasMultiPart
	    $CWD $FprotdHost $Fprotd6Host
	    $NotifySenderSubject $NotifyAdministratorSubject
	    $ValidateIPHeader
	    $QuarantineSubject $SALocalTestsOnly $NotifyNoPreamble
	    %Actions %Stupidity @FlatParts @Recipients @Warnings %Features
	    $SyslogFacility $GraphDefangSyslogFacility
	    $MaxMIMEParts $InMessageContext $InFilterContext $PrivateMyHostName
	    $EnumerateRecipients $InFilterEnd $FilterEndReplacementEntity
	    $AddApparentlyToForSpamAssassin $WarningCounter
	    @VirusScannerMessageRoutines @VirusScannerEntityRoutines
	    $VirusScannerRoutinesInitialized
	    %SendmailMacros %RecipientMailers $CachedTimezone $InFilterWrapUp );

use vars qw($GeneralWarning);
use vars qw($HTMLFoundEndBody $HTMLBoilerplate $SASpamTester);

use Socket;
use IO::Socket;
use IO::Select;
use IO::Handle;
use IO::File;
use MIME::Tools 5.410 ();
use MIME::Words qw(:all);
use Digest::SHA;
use Time::Local;
use MIME::Parser;
use Sys::Hostname;
use File::Spec qw ();

# Detect these Perl modules at run-time.  Can explicitly prevent
# loading of these modules by setting $Features{"xxx"} = 0;
#
# You can turn off ALL auto-detection by setting
# $Features{"AutoDetectPerlModules"} = 0;

sub detect_and_load_perl_modules {
    if (!defined($Features{"AutoDetectPerlModules"}) or
	$Features{"AutoDetectPerlModules"}) {
	if (!defined($Features{"SpamAssassin"})) {
	    (eval 'use Mail::SpamAssassin (); $Features{"SpamAssassin"} = 1;')
		or $Features{"SpamAssassin"} = 0;
	}
	if (!defined($Features{"HTML::Parser"})) {
	    (eval 'use HTML::Parser; $Features{"HTML::Parser"} = 1;')
		or $Features{"HTML::Parser"} = 0;
	}
	if (!defined($Features{"Archive::Zip"})) {
	    (eval 'use Archive::Zip qw(:ERROR_CODES); $Features{"Archive::Zip"} = 1;')
		or $Features{"Archive::Zip"} = 0;
	}
	if (!defined($Features{"Net::DNS"})) {
	    (eval 'use Net::DNS; $Features{"Net::DNS"} = 1;')
		or $Features{"Net::DNS"} = 0;
	}
    }
}

undef $SASpamTester;
undef $PrivateMyHostName;
undef @VirusScannerMessageRoutines;
undef @VirusScannerEntityRoutines;
$VirusScannerRoutinesInitialized = 0;

$SALocalTestsOnly = 1;
$DoStatusTags = 0;

$Features{'Virus:AVP'}      = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:AVP5'}      = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:KAVSCANNER'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:CLAMAV'}   = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:CLAMD'}    = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:FPROT'}    = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:FPSCAN'}    = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:FSAV'}     = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:HBEDV'}    = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:VEXIRA'}   = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:NAI'}      = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:BDC'}      = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:NVCC'}     = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:SymantecCSS'} = 0; # Ditto
$Features{'Virus:FPROTD'}   = 0;
$Features{'Virus:FPROTD6'}   = 0;
$Features{'Virus:SOPHIE'}   = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:SOPHOS'}   = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:SAVSCAN'}   = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:TREND'}    = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:TROPHIE'}  = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:CSAV'}     = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:NOD32'}    = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);

$Features{'Path:SENDMAIL'}  = '/usr/sbin/sendmail';
$Features{'Path:QUARANTINEDIR'} = '/var/spool/MIMEDefang';
$Features{'Path:SPOOLDIR'}  = '/var/spool/MIMEDefang';
$Features{'Path:CONFDIR'}   = '/etc';

# Not in server mode by default
$ServerMode = 0;

# Don't add Apparently-To: header for SpamAssassin
$AddApparentlyToForSpamAssassin = 0;

# Don't add warnings inline (add a MIME part instead)
$AddWarningsInline = 0;

# M$ Exchange or Outlook cannot display multiple Inline: parts
$Stupidity{"NoMultipleInlines"} = 0;

# Warning goes at beginning
$WarningLocation = 0;

# No limit to complexity of MIME messages
$MaxMIMEParts = -1;

# Cache the timzone calculation
$CachedTimezone = "";

# Syslog facility is "mail"
$SyslogFacility = "mail";
undef $GraphDefangSyslogFacility;

$URL = 'http://www.roaringpenguin.com/mimedefang/enduser.php3';
$CSSHost    = "127.0.0.1:7777:local";
$FprotdHost = "127.0.0.1:10200";
$Fprotd6Host = "127.0.0.1:10200";

$SophieSock = '/var/spool/MIMEDefang/sophie';
$ClamdSock  = '/var/spool/MIMEDefang/clamd.sock';
$TrophieSock = '/var/spool/MIMEDefang/trophie';

require "/etc/mail/mimedefang.pl.conf";

#***********************************************************************
# %PROCEDURE: expand_ipv6_address
# %ARGUMENTS:
#  addr -- an IPv6 address
# %RETURNS:
#  An IPv6 address with all zero fields explicitly expanded, and
#  any field shorter than 4 hex digits padded out with zeros.
#***********************************************************************
sub expand_ipv6_address
{
    my ($addr) = @_;

    return '0000:0000:0000:0000:0000:0000:0000:0000' if ($addr eq '::');
    if ($addr =~ /::/) {
	# Do nothing if more than one pair of colons
	return $addr if ($addr =~ /::.*::/);

	# Make sure we don't begin or end with ::
	$addr = "0000$addr" if $addr =~ /^::/;
	$addr .= '0000' if $addr =~ /::$/;

	# Count number of colons
	my $colons = ($addr =~ tr/:/:/);
	if ($colons < 8) {
	    my $missing = ':' . ('0000:' x (8 - $colons));
	    $addr =~ s/::/$missing/;
	}
    }

    # Pad short fields
    return join(':', map { (length($_) < 4 ? ('0' x (4-length($_)) . $_) : $_) } (split(/:/, $addr)));
}

#***********************************************************************
# %PROCEDURE: reverse_ip_address_for_rbl
# %ARGUMENTS:
#  addr -- an IPv4 or IPv6 address
# %RETURNS:
#  The appropriately-reversed address for RBL lookups.
#***********************************************************************
sub reverse_ip_address_for_rbl
{
    my ($addr) = @_;
    if ($addr =~ /:/) {
	$addr = expand_ipv6_address($addr);
	$addr =~ s/://g;
	return join('.', reverse(split(//, $addr)));
    }

    return join('.', reverse(split(/\./, $addr)));
}


#***********************************************************************
# %PROCEDURE: in_message_context
# %ARGUMENTS:
#  name -- a string to syslog if we are not in a message context
# %RETURNS:
#  1 if we are processing a message; 0 otherwise.  Returns 0 if
#  we're in filter_relay, filter_sender or filter_recipient
#***********************************************************************
sub in_message_context {
    my($name) = @_;
    return 1 if ($InMessageContext);
    md_syslog('warning', "$name called outside of message context");
    return 0;
}

#***********************************************************************
# %PROCEDURE: in_filter_wrapup
# %ARGUMENTS:
#  name -- a string to syslog if we are in filter wrapup
# %RETURNS:
#  1 if we are not in filter wrapup; 0 otherwise. 
#***********************************************************************
sub in_filter_wrapup {
    my($name) = @_;
    if ($InFilterWrapUp) {
	    md_syslog('warning', "$name called inside filter_wrapup context");
	    return 1;
    }
    return 0;
}

#***********************************************************************
# %PROCEDURE: in_filter_context
# %ARGUMENTS:
#  name -- a string to syslog if we are not in a filter context
# %RETURNS:
#  1 if we are inside filter or filter_multipart, 0 otherwise.
#***********************************************************************
sub in_filter_context {
    my($name) = @_;
    return 1 if ($InFilterContext);
    md_syslog('warning', "$name called outside of filter context");
    return 0;
}

#***********************************************************************
# %PROCEDURE: in_filter_end
# %ARGUMENTS:
#  name -- a string to syslog if we are not in filter_end
# %RETURNS:
#  1 if we are inside filter_end 0 otherwise.
#***********************************************************************
sub in_filter_end {
    my($name) = @_;
    return 1 if ($InFilterEnd);
    md_syslog('warning', "$name called outside of filter_end");
    return 0;
}

#***********************************************************************
# %PROCEDURE: copy_or_link
# %ARGUMENTS:
#  src -- source filename
#  dest -- destination filename
# %RETURNS:
#  1 on success; 0 on failure.
# %DESCRIPTION:
#  Copies a file: First, attempts to make a hard link.  If that fails,
#  reads the file and copies the data.
#***********************************************************************
sub copy_or_link {
    my($src, $dst) = @_;
    return 1 if link($src, $dst);

    # Link failed; do it the hard way
    open(IN, "<$src") or return 0;
    if (!open(OUT, ">$dst")) {
	close(IN);
	return 0;
    }
    my($n, $string);
    while (($n = read(IN, $string, 4096)) > 0) {
	print OUT $string;
    }
    close(IN);
    close(OUT);
    return 1;
}

#***********************************************************************
# %PROCEDURE: md_copy_orig_msg_to_work_dir
# %ARGUMENTS:
#  None
# %DESCRIPTION:
#  Copies original INPUTMSG file into work directory for virus-scanning
# %RETURNS:
#  1 on success, 0 on failure.
#***********************************************************************
sub md_copy_orig_msg_to_work_dir {
    return if (!in_message_context("md_copy_orig_msg_to_work_dir"));
    return copy_or_link("INPUTMSG", "Work/INPUTMSG");
}

#***********************************************************************
# %PROCEDURE: md_copy_orig_msg_to_work_dir_as_mbox_file
# %ARGUMENTS:
#  None
# %DESCRIPTION:
#  Copies original INPUTMSG file into work directory for virus-scanning
#  as a valid mbox file (adds the "From $Sender mumble..." stuff.)
# %RETURNS:
#  1 on success, 0 on failure.
#***********************************************************************
sub md_copy_orig_msg_to_work_dir_as_mbox_file {
    return if (!in_message_context("md_copy_orig_msg_to_work_dir_as_mbox_file"));
    open(IN, "<INPUTMSG") or return 0;
    unless (open(OUT, ">Work/INPUTMBOX")) {
	close(IN);
	return 0;
    }

    # Remove angle-brackets for From_ line
    my $s = $Sender;
    $s =~ s/^<//;
    $s =~ s/>$//;

    print OUT "From $s " . rfc2822_date() . "\n";
    my($n, $string);
    while (($n = read(IN, $string, 4096)) > 0) {
	print OUT $string;
    }
    close(IN);
    close(OUT);
    return 1;
}

#***********************************************************************
# %PROCEDURE: percent_encode
# %ARGUMENTS:
#  str -- a string, possibly with newlines and control characters
# %RETURNS:
#  A string with unsafe chars encoded as "%XY" where X and Y are hex
#  digits.  For example:
#  "foo\r\nbar\tbl%t" ==> "foo%0D%0Abar%09bl%25t"
#***********************************************************************
sub percent_encode {
    my($str) = @_;
    $str =~ s/([^\x21-\x7e]|[%\\'"])/sprintf("%%%02X", unpack("C", $1))/ge;
    #" Fix emacs highlighting...
    return $str;
}

#***********************************************************************
# %PROCEDURE: percent_encode_for_graphdefang
# %ARGUMENTS:
#  str -- a string, possibly with newlines and control characters
# %RETURNS:
#  A string with unsafe chars encoded as "%XY" where X and Y are hex
#  digits.  For example:
#  "foo\r\nbar\tbl%t" ==> "foo%0D%0Abar%09bl%25t"
# This differs slightly from percent_encode because we don't encode
# quotes or spaces, but we do encode commas.
#***********************************************************************
sub percent_encode_for_graphdefang {
    my($str) = @_;
    $str =~ s/([^\x20-\x7e]|[%\\,])/sprintf("%%%02X", unpack("C", $1))/ge;
    #" Fix emacs highlighting...
    return $str;
}

#***********************************************************************
# %PROCEDURE: push_status_tag
# %ARGUMENTS:
#  tag -- tag describing current status
# %DESCRIPTION:
#  Updates status tag inside multiplexor and pushes onto stack.
# %RETURNS:
#  Nothing
#***********************************************************************
sub push_status_tag
{
	return unless $DoStatusTags;

	my ($tag) = @_;
	push(@StatusTags, $tag);
	if($tag ne '') {
		$tag = "> $tag";
	}
	set_status_tag(scalar(@StatusTags), $tag);
}

#***********************************************************************
# %PROCEDURE: pop_status_tag
# %ARGUMENTS:
#  None
# %DESCRIPTION:
#  Pops previous status of stack and sets tag in multiplexor.
# %RETURNS:
#  Nothing
#***********************************************************************
sub pop_status_tag
{
	return unless $DoStatusTags;

	pop @StatusTags;

	my $tag = $StatusTags[0] || 'no_tag';

	set_status_tag(scalar(@StatusTags), "< $tag");
}

#***********************************************************************
# %PROCEDURE: set_status_tag
# %ARGUMENTS:
#  nest_depth -- nesting depth
#  tag -- status tag
# %DESCRIPTION:
#  Sets the status tag for this worker inside the multiplexor.
# %RETURNS:
#  Nothing
#***********************************************************************
sub set_status_tag
{
	return unless $DoStatusTags;

	my ($depth, $tag) = @_;
	$tag ||= '';

	if($tag eq '') {
		print STATUS_HANDLE "\n";
		return;
	}
	$tag =~ s/[^[:graph:]]/ /g;

	if(defined($MsgID) and ($MsgID ne "NOQUEUE")) {
		print STATUS_HANDLE percent_encode("$depth: $tag $MsgID") . "\n";
	} else {
		print STATUS_HANDLE percent_encode("$depth: $tag") . "\n";
	}
}

# Try to open the status descriptor
sub init_status_tag
{
	return unless $DoStatusTags;

	if(open(STATUS_HANDLE, ">&=3")) {
		STATUS_HANDLE->autoflush(1);
	} else {
		$DoStatusTags = 0;
	}
}

#***********************************************************************
# %PROCEDURE: percent_decode
# %ARGUMENTS:
#  str -- a string encoded by percent_encode
# %RETURNS:
#  The decoded string.  For example:
#  "foo%0D%0Abar%09bl%25t" ==> "foo\r\nbar\tbl%t"
#***********************************************************************
sub percent_decode {
    my($str) = @_;
    $str =~ s/%([0-9A-Fa-f]{2})/pack("C", hex($1))/ge;
    return $str;
}

my $results_fh;

=pod

=head2 write_result_line ( $cmd, @args )

Writes a result line to the RESULTS file.

$cmd should be a one-letter command for the RESULTS file

@args are the arguments for $cmd, if any.  They will be percent_encode()'ed
before being written to the file.

Returns nothing.

=cut

sub write_result_line
{
	my $cmd = shift;

	# Do nothing if we don't yet have a dedicated working directory
	if ($CWD eq $Features{'Path:SPOOLDIR'}) {
		md_syslog('warning', "write_result_line called before working directory established");
		return;
	}

	my $line = $cmd . join ' ', map { percent_encode($_) } @_;

	if (!$results_fh) {
		$results_fh = IO::File->new('>>RESULTS');
		if (!$results_fh) {
			die("Could not open RESULTS file: $!");
		}
	}

	# We have an 8kb limit on the length of lines in RESULTS, including
	# trailing newline and null used in the milter.  So, we limit $cmd +
	# $args to 8190 bytes.
	if( length $line > 8190 ) {
		md_syslog( 'warning',  "Cannot write line over 8190 bytes long to RESULTS file; truncating.  Original line began with: " . substr $line, 0, 40);
		$line = substr $line, 0, 8190;
	}

	print $results_fh "$line\n" or die "Could not write RESULTS line: $!";

	return;
}

#***********************************************************************
# %PROCEDURE: time_str
# %ARGUMENTS:
#  None
# %RETURNS:
#  The current time in the form: "YYYY-MM-DD-HH:mm:ss"
# %DESCRIPTION:
#  Returns a string representing the current time.
#***********************************************************************
sub time_str {
    my($sec, $min, $hour, $mday, $mon, $year, $junk);
    ($sec, $min, $hour, $mday, $mon, $year, $junk) = localtime(time());
    return sprintf("%04d-%02d-%02d-%02d.%02d.%02d",
		   $year + 1900, $mon+1, $mday, $hour, $min, $sec);
}

sub hour_str {
    my($sec, $min, $hour, $mday, $mon, $year, $junk);
    ($sec, $min, $hour, $mday, $mon, $year, $junk) = localtime(time());
    return sprintf('%04d-%02d-%02d-%02d', $year+1900, $min+1, $mday, $hour);
}

{
	# Reworked detection/usage of Sys::Syslog or Unix::Syslog as
	# appropriate is mostly borrowed from Log::Syslog::Abstract, to which
	# I'd love to convert at some point.
	my $_syslogsub = undef;
	my $_openlogsub = undef;
	my $_fac_map   = undef;

	#***********************************************************************
	# %PROCEDURE: md_openlog
	# %ARGUMENTS:
	#  tag -- syslog tag ("mimedefang.pl")
	#  facility -- Syslog facility as a string
	# %RETURNS:
	#  Nothing
	# %DESCRIPTION:
	#  Opens a log using either Unix::Syslog or Sys::Syslog
	#***********************************************************************
	sub md_openlog
	{
		my ($tag, $facility) = @_;

		if( ! defined $_openlogsub ) {
			# Try Unix::Syslog first, then Sys::Syslog
			eval qq{use Unix::Syslog qw( :macros ); };
			if(!$@) {
				($_openlogsub, $_syslogsub) = _wrap_for_unix_syslog();
			} else {
				eval qq{use Sys::Syslog ();};
				if(!$@) {
					($_openlogsub, $_syslogsub) = _wrap_for_sys_syslog();
				} else {
					die q{Unable to detect either Unix::Syslog or Sys::Syslog};
				}
			}
		}

		return $_openlogsub->($tag, 'pid,ndelay', $facility);
	}

	#***********************************************************************
	# %PROCEDURE: md_syslog
	# %ARGUMENTS:
	#  facility -- Syslog facility as a string
	#  msg -- message to log
	# %RETURNS:
	#  Nothing
	# %DESCRIPTION:
	#  Calls syslog, either in Sys::Syslog or Unix::Syslog package
	#***********************************************************************
	sub md_syslog
	{
		my ($facility, $msg) = @_;

		if(!$_syslogsub) {
			md_openlog('mimedefang.pl', $SyslogFacility);
		}

		if (defined $MsgID && $MsgID ne 'NOQUEUE') {
			return $_syslogsub->($facility, '%s', $MsgID . ': ' . $msg);
		} else {
			return $_syslogsub->($facility, '%s', $msg);
		}
	}

	sub _wrap_for_unix_syslog
	{

		my $openlog = sub {
			my ($id, $flags, $facility) = @_;

			die q{first argument must be an identifier string} unless defined $id;
			die q{second argument must be flag string} unless defined $flags;
			die q{third argument must be a facility string} unless defined $facility;

			return Unix::Syslog::openlog( $id, _convert_flags( $flags ), _convert_facility( $facility ) );
		};

		my $syslog = sub {
			my $facility = shift;
			return Unix::Syslog::syslog( _convert_facility( $facility ), @_);
		};

		return ($openlog, $syslog);
	}

	sub _wrap_for_sys_syslog
	{

		my $openlog  = sub {
			# Debian Stretch version is 0.33_01...dammit!
			my $ver = $Sys::Syslog::VERSION;
			$ver =~ s/_.*//;
			if( $ver < 0.16 ) {
				# Older Sys::Syslog versions still need
				# setlogsock().  RHEL5 still ships with 0.13 :(
				Sys::Syslog::setlogsock([ 'unix', 'tcp', 'udp' ]);
			}
			return Sys::Syslog::openlog(@_);
		};
		my $syslog   = sub {
			return Sys::Syslog::syslog(@_);
		};

		return ($openlog, $syslog);
	}

	sub _convert_flags
	{
		my($flags) = @_;

		my $flag_map = {
			pid     => Unix::Syslog::LOG_PID(),
			ndelay  => Unix::Syslog::LOG_NDELAY(),
		};

		my $num = 0;
		foreach my $thing (split(/,/, $flags)) {
			next unless exists $flag_map->{$thing};
			$num |= $flag_map->{$thing};
		}
		return $num;
	}


	sub _convert_facility
	{
		my($facility) = @_;

		my $num = 0;
		foreach my $thing (split(/\|/, $facility)) {
			if (!defined($_fac_map) ||
			    !exists($_fac_map->{$thing})) {
				$_fac_map->{$thing} = _fac_to_num($thing);
			}
			next unless defined $_fac_map->{$thing};
			$num |= $_fac_map->{$thing};
		}
		return $num;
	}

	my %special = (
		error => 'err',
		panic => 'emerg',
	);

	# Some of the Unix::Syslog 'macros' tag exports aren't
	# constants, so we need to ignore them if found.
	my %blacklisted = map { $_ => 1 } qw(mask upto pri makepri fac);

        sub _fac_to_num
	{
		my ($thing) = @_;
		return undef if exists $blacklisted{$thing};
		$thing = $special{$thing} if exists $special{$thing};
		$thing = 'LOG_' . uc($thing);
		return undef unless grep { $_ eq $thing } @ {$Unix::Syslog::EXPORT_TAGS{macros} };
		return eval "Unix::Syslog::$thing()";
	}
}

#***********************************************************************
# %PROCEDURE: fatal
# %ARGUMENTS:
#  msg -- message
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Logs an error and (if we are not in server mode) exits.
#***********************************************************************
sub fatal {
    my($msg) = @_;
    md_syslog('err', "$msg");
    if (!$ServerMode) {
	die($msg);
    } else {
	print_and_flush("error: $msg");
    }
}

#***********************************************************************
# %PROCEDURE: synthesize_received_header
# %ARGUMENTS:
#  None
# %RETURNS:
#  A "Received:" header for current message
# %DESCRIPTION:
#  Synthesizes a valid Received: header to reflect re-mailing.
#***********************************************************************
sub synthesize_received_header {
    my($hdr);
    
    my($hn) = $SendmailMacros{"if_name"};

    my $strdate = rfc2822_date();

    $hn = get_host_name() unless (defined($hn) and ($hn ne ""));
    if ($RealRelayHostname ne "[$RealRelayAddr]") {
	$hdr = "Received: from $Helo ($RealRelayHostname [$RealRelayAddr])\n";
    } else {
	$hdr = "Received: from $Helo ([$RealRelayAddr])\n";
    }
    $hdr .= "\tby $hn (envelope-sender $Sender) (MIMEDefang) with ESMTP id $MsgID";
    if ($#Recipients != 0) {
	$hdr .= "; ";
    } else {
	$hdr .= "\n\tfor " . $Recipients[0] . "; ";
    }

    $hdr .= $strdate . "\n";
    return $hdr;
}

#***********************************************************************
# %PROCEDURE: rebuild_entity
# %ARGUMENTS:
#  out -- output entity to hold rebuilt message
#  in -- input message
# %RETURNS:
#  Nothing useful
# %DESCRIPTION:
#  Descends through input entity and rebuilds an output entity.  The
#  various parts of the input entity may be modified (or even deleted)
#***********************************************************************
sub rebuild_entity {
    my($out, $in) = @_;
    my @parts = $in->parts;
    my($type) = $in->mime_type;
    $type =~ tr/A-Z/a-z/;
    my($body) = $in->bodyhandle;
    my($fname) = takeStabAtFilename($in);
    $fname = "" unless defined($fname);
    my $extension = "";
    $extension = $1 if $fname =~ /(\.[^.]*)$/;

    # If no Content-Type: header, add one
    if (!$in->head->mime_attr('content-type')) {
	$in->head->mime_attr('Content-Type', $type);
    }

    if (!defined($body)) {
	$Action = "accept";
	if (defined(&filter_multipart)) {
	    push_status_tag("In filter_multipart routine");
	    filter_multipart($in, $fname, $extension, $type);
	    pop_status_tag();
	}
	if ($Action eq "drop") {
	    $Changed = 1;
	    return 0;
	}

	if ($Action eq "replace") {
	    $Changed = 1;
	    $out->add_part($ReplacementEntity);
	    return 0;
	}

	my($subentity);
	$subentity = $in->dup;
	$subentity->parts([]);
	$out->add_part($subentity);
	map { rebuild_entity($subentity, $_) } @parts;
    } else {
	# This is where we call out to the user filter.  Get some useful
	# info to pass to the filter

	# Default action is to accept the part
	$Action = "accept";

	if (defined(&filter)) {
	    push_status_tag("In filter routine");
	    filter($in, $fname, $extension, $type);
	    pop_status_tag();
	}

	# If action is "drop", just drop it silently;
	if ($Action eq "drop") {
	    $Changed = 1;
	    return 0;
	}

	# If action is "replace", replace it with $ReplacementEntity;
	if ($Action eq "replace") {
	    $Changed = 1;
	    $out->add_part($ReplacementEntity);
	    return 0;
	}

	# Otherwise, accept it
	$out->add_part($in);
    }
}

#***********************************************************************
# %PROCEDURE: collect_parts
# %ARGUMENTS:
#  entity -- root entity to rebuild
#  skip_pgp_mime -- If true, skip multipart/signed and multipart/encrypted
#                   parts
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Adds parts to the array @FlatParts for flattening.
#***********************************************************************
sub collect_parts {
    my($entity, $skip_pgp_mime) = @_;
    my(@parts) = $entity->parts;
    my($part);
    if ($#parts >= 0) {
	if (! $skip_pgp_mime ||
	    (lc($entity->head->mime_type) ne "multipart/signed" and
	     lc($entity->head->mime_type) ne "multipart/encrypted")) {
	    foreach $part (@parts) {
		collect_parts($part, $skip_pgp_mime);
	    }
	}
    } else {
	push(@FlatParts, $entity);
    }
}

#***********************************************************************
# %PROCEDURE: make_defanged_name
# %ARGUMENTS:
#  None
# %RETURNS:
#  A unique name of the form "defang-$n.binary"
#***********************************************************************
sub make_defanged_name {
    $DefangCounter++;
    return "defang-$DefangCounter.binary";
}

#***********************************************************************
# %PROCEDURE: action_rebuild
# %ARGUMENTS:
#  None
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Sets a flag telling MIMEDefang to rebuild message even if it is
#  unchanged.
#***********************************************************************
sub action_rebuild {
    return undef unless (in_message_context("action_rebuild") && !in_filter_wrapup("action_rebuild"));
    $Rebuild = 1;
}

#***********************************************************************
# %PROCEDURE: action_add_entity
# %ARGUMENTS:
#  entity -- the mime entity to add (must be pre-built)
#  location -- (optional) location at which to add part (default -1 = end)
# %RETURNS:
#  The entity object for the new part
# %DESCRIPTION:
#  Makes a note to add a part to the message.  Parts are *actually* added
#  at the end, which lets us correctly handle non-multipart messages or
#  multipart/foo where "foo" != "mixed".  Sets the rebuild flag.
#***********************************************************************
sub action_add_entity
{
	my($entity, $offset) = @_;

	return undef unless (in_message_context("action_add_part") && !in_filter_wrapup("action_add_part"));
	$offset = -1 unless defined($offset);
	push(@AddedParts, [$entity, $offset]);
	action_rebuild();
	return $entity;
}

#***********************************************************************
# %PROCEDURE: action_add_part
# %ARGUMENTS:
#  entity -- the mime entity
#  type -- the mime type
#  encoding -- see MIME::Entity(8)
#  data -- the data for the part
#  fname -- file name
#  disposition -- content-disposition header
#  location -- (optional) location at which to add part (default -1 = end)
# %RETURNS:
#  The entity object for the new part
# %DESCRIPTION:
#  Makes a note to add a part to the message.  Parts are *actually* added
#  at the end, which lets us correctly handle non-multipart messages or
#  multipart/foo where "foo" != "mixed".  Sets the rebuild flag.
#***********************************************************************
sub action_add_part {
    my ($entity)      = shift;
    my ($type)        = shift;
    my ($encoding)    = shift;
    my ($data)        = shift;
    my ($fname)       = shift;
    my ($disposition) = shift;
    my ($offset)      = shift;

    return undef unless (in_message_context("action_add_part") && !in_filter_wrapup("action_add_part"));

    $offset = -1 unless defined($offset);

    my ($part);

    $part = MIME::Entity->build(Type => $type,
				Top => 0,
				'X-Mailer' => undef,
				Encoding => $encoding,
				Data => ["$data"]);
    defined ($fname) && $part->head->mime_attr("Content-Type.name" => $fname);
    defined ($disposition) && $part->head->mime_attr("Content-Disposition" => $disposition);
    defined ($fname) && $part->head->mime_attr("Content-Disposition.filename" => $fname);

    return action_add_entity($part, $offset);
}

#***********************************************************************
# %PROCEDURE: process_added_parts
# %ARGUMENTS:
#  rebuilt -- rebuilt entity
# %RETURNS:
#  A new entity with parts added
# %DESCRIPTION:
#  Actually adds requested parts to entity.  Ensures that entity is
#  of type multipart/mixed
#***********************************************************************
sub process_added_parts {
    my($rebuilt) = @_;
    my($entity);

    # If no parts to add, do nothing
    return $rebuilt if ($#AddedParts < 0);

    # Make sure we have a multipart/mixed container
    if (lc($rebuilt->head->mime_type) ne "multipart/mixed") {
	$entity = MIME::Entity->build(Type => "multipart/mixed",
				      'X-Mailer' => undef);
	$entity->add_part($rebuilt);
    } else {
	$entity = $rebuilt;
    }
    my $thing;
    foreach $thing (@AddedParts) {
	$entity->add_part($thing->[0], $thing->[1]);
    }
    return $entity;
}

#***********************************************************************
# %PROCEDURE: action_insert_header
# %ARGUMENTS:
#  header -- header name (eg: X-My-Header)
#  value -- header value (eg: any text goes here)
#  position -- where to place it (eg: 0 [default] to make it first)
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note for milter to insert a header in the message in the
#  specified position.  May not be supported on all versions of Sendmail;
#  on unsupported versions, the C milter falls back to action_add_header.
#***********************************************************************
sub action_insert_header {
    my($header, $value, $pos) = @_;
    $pos = 0 unless defined($pos);
    write_result_line('N', $header, $pos, $value);
}

#***********************************************************************
# %PROCEDURE: action_add_header
# %ARGUMENTS:
#  header -- header name (eg: X-My-Header)
#  value -- header value (eg: any text goes here)
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note for milter to add a header to the message.
#***********************************************************************
sub action_add_header {
    my($header, $value) = @_;
    write_result_line('H', $header, $value);
}


#***********************************************************************
# %PROCEDURE: action_change_header
# %ARGUMENTS:
#  header -- header name (eg: X-My-Header)
#  value -- header value (eg: any text goes here)
#  index -- index of header to change (default 1)
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note for milter to change a header in the message.
#***********************************************************************
sub action_change_header {
    my($header, $value, $idx) = @_;
    return if (!in_message_context("action_change_header"));
    $idx = 1 unless defined($idx);

    write_result_line('I', $header, $idx, $value);
}

#***********************************************************************
# %PROCEDURE: action_delete_header
# %ARGUMENTS:
#  header -- header name (eg: X-My-Header)
#  index -- index of header to delete (default 1)
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note for milter to delete a header in the message.
#***********************************************************************
sub action_delete_header {
    my($header, $idx) = @_;
    return if (!in_message_context("action_delete_header"));
    $idx = 1 unless defined($idx);

    write_result_line('J', $header, $idx);
}

#***********************************************************************
# %PROCEDURE: action_delete_all_headers
# %ARGUMENTS:
#  header -- header name (eg: X-My-Header)
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note for milter to delete all instances of header.
#***********************************************************************
sub action_delete_all_headers {
    my($header) = @_;
    return 0 if (!in_message_context("action_delete_all_headers"));
    my($count, $len, $orig_header);

    $orig_header = $header;
    $len = length($header) + 1;
    $header .= ":";
    $header = lc($header);

    return undef unless(open(HDRS, "<HEADERS"));

    $count = 0;
    while(<HDRS>) {
	if (lc(substr($_, 0, $len)) eq $header) {
	    $count++;
	}
    }
    close(HDRS);

    # Delete in REVERSE order, in case Sendmail updates
    # its count as headers are deleted... paranoid but safe.
    while ($count > 0) {
	action_delete_header($orig_header, $count);
	$count--;
    }
    return 1;
}

#***********************************************************************
# %PROCEDURE: action_accept
# %ARGUMENTS:
#  Ignored
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note to accept the current part.
#***********************************************************************
sub action_accept {
    return 0 if (!in_filter_context("action_accept"));
    $Action = "accept";
    return 1;
}

#***********************************************************************
# %PROCEDURE: action_accept_with_warning
# %ARGUMENTS:
#  msg -- warning message
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note to accept the current part, but add a warning to the
#  message.
#***********************************************************************
sub action_accept_with_warning {
    my($msg) = @_;
    return 0 if (!in_filter_context("action_accept_with_warning"));
    $Actions{'accept_with_warning'}++;
    $Action = "accept";
    push(@Warnings, "$msg\n");
    return 1;
}

#***********************************************************************
# %PROCEDURE: message_rejected
# %ARGUMENTS:
#  None
# %RETURNS:
#  True if message has been rejected (with action_bounce or action_tempfail);
#  false otherwise.
#***********************************************************************
sub message_rejected {
    return 0 if (!in_message_context("message_rejected"));
    return (defined($Actions{'tempfail'}) ||
	    defined($Actions{'bounce'})   ||
	    defined($Actions{'discard'}));
}

#***********************************************************************
# %PROCEDURE: action_drop
# %ARGUMENTS:
#  Ignored
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note to drop the current part without any warning.
#***********************************************************************
sub action_drop {
    return 0 if (!in_filter_context("action_drop"));
    $Actions{'drop'}++;
    $Action = "drop";
    return 1;
}

#***********************************************************************
# %PROCEDURE: action_drop_with_warning
# %ARGUMENTS:
#  msg -- warning message
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note to drop the current part and add a warning to the message
#***********************************************************************
sub action_drop_with_warning {
    my($msg) = @_;
    return 0 if (!in_filter_context("action_drop_with_warning"));
    $Actions{'drop_with_warning'}++;
    $Action = "drop";
    push(@Warnings, "$msg\n");
    return 1;
}

#***********************************************************************
# %PROCEDURE: action_replace_with_warning
# %ARGUMENTS:
#  msg -- warning message
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note to drop the current part and replace it with a warning
#***********************************************************************
sub action_replace_with_warning {
    my($msg) = @_;
    return 0 if (!in_filter_context("action_replace_with_warning"));
    $Actions{'replace_with_warning'}++;
    $Action = "replace";
    $WarningCounter++;
    $ReplacementEntity = MIME::Entity->build(Top => 0,
					     Type => "text/plain",
 					     Encoding => "-suggest",
					     Disposition => "inline",
					     Filename => "warning$WarningCounter.txt",
					     'X-Mailer' => undef,
 					     Data => [ "$msg\n" ]);
    return 1;
}

#***********************************************************************
# %PROCEDURE: action_defang
# %ARGUMENTS:
#  entity -- current part
#  name -- suggested name for defanged part
#  fname -- suggested filename for defanged part
#  type -- suggested MIME type for defanged part
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note to defang the current part by changing its name, filename
#  and possibly MIME type.
#***********************************************************************
sub action_defang {
    $Changed = 1;
    my($entity, $name, $fname, $type) = @_;
    return 0 if (!in_filter_context("action_defang"));

    $name = "" unless defined($name);
    $fname = "" unless defined($fname);
    $type = "application/octet-stream" unless defined($type);

    $Actions{'defang'}++;
    my($head) = $entity->head;
    my($oldfname) = takeStabAtFilename($entity);

    my($defang);
    if ($name eq "" || $fname eq "") {
	$defang = make_defanged_name();
    }
    $name = $defang if ($name eq "");
    $fname = $defang if ($fname eq "");

    my($warning);
    if (defined(&defang_warning)) {
	$warning = defang_warning($oldfname, $fname);
    } else {
	$warning = "An attachment named '$oldfname'";
	$warning .= " was converted to '$fname'.\n";
	$warning .= "To recover the file, click on the attachment and Save As\n'$oldfname' in order to access it.\n";
    }

    $entity->effective_type($type);
    $head->replace("Content-Type", $type);
    $head->mime_attr("Content-Type.name" => $name);
    $head->mime_attr("Content-Disposition.filename" => $fname);
    $head->mime_attr("Content-Description" => $fname);

    action_accept_with_warning("$warning");
    return 1;
}

#***********************************************************************
# %PROCEDURE: action_external_filter
# %ARGUMENTS:
#  entity -- current part
#  cmd -- UNIX command to run
# %RETURNS:
#  1 on success, 0 otherwise.
# %DESCRIPTION:
#  Pipes the part through the UNIX command $cmd, and replaces the
#  part with the result of running the filter.
#***********************************************************************
sub action_external_filter {
    my($entity, $cmd) = @_;

    return 0 if (!in_filter_context("action_external_filter"));
    # Copy the file
    my($body) = $entity->bodyhandle;
    if (!defined($body)) {
	return 0;
    }

    if (!defined($body->path)) {
	return 0;
    }

    unless(copy_or_link($body->path, "FILTERINPUT")) {
	md_syslog('err', "Could not open FILTERINPUT: $!");
	return(0);
    }

    # Run the filter
    my($status) = system($cmd);

    # Filter failed if non-zero exit
    if ($status % 255) {
	md_syslog('err', "External filter exited with non-zero status $status");
	return 0;
    }

    # If filter didn't produce FILTEROUTPUT, do nothing
    return 1 if (! -r "FILTEROUTPUT");

    # Rename FILTEROUTPUT over original path
    unless (rename("FILTEROUTPUT", $body->path)) {
	md_syslog('err', "Could not rename FILTEROUTPUT to path: $!");
	return(0);
    }
    $Changed = 1;
    $Actions{'external_filter'}++;
    return 1;
}

#***********************************************************************
# %PROCEDURE: action_quarantine
# %ARGUMENTS:
#  entity -- current part
#  msg -- warning message
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Similar to action_drop_with_warning, but e-mails the MIMEDefang
#  administrator a notification, and quarantines the part in the
#  quarantine directory.
#***********************************************************************
sub action_quarantine {
    my($entity, $msg) = @_;

    return 0 if (!in_filter_context("action_quarantine"));
    $Action = "drop";
    push(@Warnings, "$msg\n");

    # Can't handle path-less bodies
    my($body) = $entity->bodyhandle;
    if (!defined($body)) {
	return 0;
    }

    if (!defined($body->path)) {
	return 0;
    }

    get_quarantine_dir();
    if ($QuarantineSubdir eq "") {
	# Could not create quarantine directory
	return 0;
    }

    $Actions{'quarantine'}++;
    $QuarantineCount++;

    # Save the part
    copy_or_link($body->path, "$QuarantineSubdir/PART.$QuarantineCount.BODY");

    # Save the part's headers
    if (open(OUT, ">$QuarantineSubdir/PART.$QuarantineCount.HEADERS")) {
	$entity->head->print(\*OUT);
	close(OUT);
    }

    # Save the messages
    if (open(OUT, ">$QuarantineSubdir/MSG.$QuarantineCount")) {
	print OUT "$msg\n";
	close(OUT);
    }
    return 1;
}

#***********************************************************************
# %PROCEDURE: action_sm_quarantine
# %ARGUMENTS:
#  reason -- reason for quarantine
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Asks Sendmail to quarantine message in mqueue using Sendmail's
#  smfi_quarantine facility.
#***********************************************************************
sub action_sm_quarantine {
    my($reason) = @_;
    return if (!in_message_context("action_sm_quarantine"));

    $Actions{'sm_quarantine'} = 1;
    write_result_line("Q", $reason);
}

sub get_quarantine_dir {

    # If quarantine dir has already been made, return it.
    if ($QuarantineSubdir ne "") {
	return $QuarantineSubdir;
    }

    my($counter) = 0;
    my($tries);
    my($success) = 0;
    my($tm);
    $tm = time_str();
    my $hour = hour_str();
    my $hour_dir = sprintf("%s/%s", $Features{'Path:QUARANTINEDIR'}, $hour);
    mkdir($hour_dir, 0750);
    if (! -d $hour_dir) {
	    return "";
    }
    do {
	$counter++;
	$QuarantineSubdir = sprintf("%s/%s/qdir-%s-%03d",
				    $Features{'Path:QUARANTINEDIR'}, $hour, $tm, $counter);
	if (mkdir($QuarantineSubdir, 0750)) {
	    $success = 1;
	}
    } while(!$success && ($tries++ < 1000));
    if (!$success) {
	$QuarantineSubdir = "";
	return "";
    }

    # Write the sender and recipient info
    if (open(OUT, ">$QuarantineSubdir/SENDER")) {
	print OUT "$Sender\n";
	close(OUT);
    }
    if (open(OUT, ">$QuarantineSubdir/SENDMAIL-QID")) {
	print OUT "$QueueID\n";
	close(OUT);
    }

    if (open(OUT, ">$QuarantineSubdir/RECIPIENTS")) {
	my($s);
	foreach $s (@Recipients) {
	    print OUT "$s\n";
	}
	close(OUT);
    }

    # Copy message headers
    if (open(OUT, ">$QuarantineSubdir/HEADERS")) {
	if (open(IN, "<HEADERS")) {
	    while(<IN>) {
		print OUT;
	    }
	    close(IN);
	}
	close(OUT);
    }

    return $QuarantineSubdir;
}

#***********************************************************************
# %PROCEDURE: action_quarantine_entire_message
# %ARGUMENTS:
#  msg -- quarantine message (optional)
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Puts a copy of the entire message in the quarantine directory.
#***********************************************************************
sub action_quarantine_entire_message {
    my($msg) = @_;
    return 0 if (!in_message_context("action_quarantine_entire_message"));
    # If no parts have yet been quarantined, create the quarantine subdirectory
    # and write useful info there
    get_quarantine_dir();
    if ($QuarantineSubdir eq "") {
	# Could not create quarantine directory
	return 0;
    }

    # Don't copy message twice
    if ($EntireMessageQuarantined) {
	return 1;
    }

    $Actions{'quarantine_entire_message'}++;
    if (defined($msg) && ($msg ne "")) {
	if (open(OUT, ">$QuarantineSubdir/MSG.0")) {
	    print OUT "$msg\n";
	    close(OUT);
	}
    }

    $EntireMessageQuarantined = 1;

    copy_or_link("INPUTMSG", "$QuarantineSubdir/ENTIRE_MESSAGE");

    return 1;
}

#***********************************************************************
# %PROCEDURE: action_bounce
# %ARGUMENTS:
#  reply -- SMTP reply text (eg: "Not allowed, sorry")
#  code -- SMTP reply code (eg: 554)
#  DSN -- DSN code (eg: 5.7.1)
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Causes the SMTP transaction to fail with an SMTP 554 failure code and the
#  specified reply text.  If code or DSN are omitted or invalid,
#  use 554 and 5.7.1.
#***********************************************************************
sub action_bounce {
    my($reply, $code, $dsn) = @_;
    return 0 if (!in_message_context("action_bounce"));

    $reply = "Forbidden for policy reasons" unless (defined($reply) and ($reply ne ""));
    $code = 554 unless (defined($code) and $code =~ /^5\d\d$/);
    $dsn = "5.7.1" unless (defined($dsn) and $dsn =~ /^5\.\d{1,3}\.\d{1,3}$/);

    write_result_line('B', $code, $dsn, $reply);
    $Actions{'bounce'}++;
    return 1;
}

#***********************************************************************
# %PROCEDURE: action_discard
# %ARGUMENTS:
#  None
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Causes the entire message to be silently discarded without without
#  notifying anyone.
#***********************************************************************
sub action_discard {
    return 0 if (!in_message_context("action_discard"));
    write_result_line("D", "");
    $Actions{'discard'}++;
    return 1;
}

#***********************************************************************
# %PROCEDURE: action_notify_sender
# %ARGUMENTS:
#  msg -- a message to send
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Causes an e-mail to be sent to the sender containing $msg
#***********************************************************************
sub action_notify_sender {
    my($msg) = @_;
    return 0 if (!in_message_context("action_notify_sender"));
    if ($Sender eq '<>') {
	md_syslog('err', "Skipped action_notify_sender: Sender = <>");
	return 0;
    }

    if ($VirusName ne "") {
	md_syslog('err', "action_notify_sender disabled when virus is detected");
	return 0;
    }

    if (open(FILE, ">>NOTIFICATION")) {
	print FILE $msg;
	close(FILE);
	$Actions{'notify_sender'}++;
	return 1;
    }
    md_syslog('err', "Could not create NOTIFICATION file: $!");
    return 0;
}

#***********************************************************************
# %PROCEDURE: action_notify_administrator
# %ARGUMENTS:
#  msg -- a message to send
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Causes an e-mail to be sent to the MIMEDefang administrator
#  containing $msg
#***********************************************************************
sub action_notify_administrator {
    my($msg) = @_;
    if (!$InMessageContext) {
	send_admin_mail($NotifyAdministratorSubject, $msg);
	return 1;
    }
    if (open(FILE, ">>ADMIN_NOTIFICATION")) {
	print FILE $msg;
	close(FILE);
	$Actions{'notify_administrator'}++;
	return 1;
    }
    md_syslog('err', "Could not create ADMIN_NOTIFICATION file: $!");
    return 0;
}

#***********************************************************************
# %PROCEDURE: relay_is_blacklisted
# %ARGUMENTS:
#  addr -- IP address of relay host.
#  domain -- domain of blacklist server (eg: inputs.orbz.org)
# %RETURNS:
#  The result of the lookup (eg 127.0.0.2)
#***********************************************************************
sub relay_is_blacklisted {
    my($addr, $domain) = @_;
    $addr = reverse_ip_address_for_rbl($addr) . ".$domain";

    my $hn;
    $hn = gethostbyname($addr);
    return 0 unless defined($hn);
    return $hn if ($hn);

    # Hostname is defined, but false -- return 1 instead.
    return 1;
}

#***********************************************************************
# %PROCEDURE: relay_is_blacklisted_multi
# %ARGUMENTS:
#  addr -- IP address of relay host.
#  timeout -- number of seconds after which to time out
#  answers_wanted -- if positive, return as soon as this many positive answers
#                    have been received.
#  domains -- an array of domains to check
#  res (optional) -- A Net::DNS::Resolver object.  If you don't pass
#                    one in, we'll generate one and use it.
# %RETURNS:
#  A hash table with one entry per original domain.  Entries in hash
#  will be:
#  { $domain => $return }, where $return is one of SERVFAIL, NXDOMAIN or
#  a list of IP addresses as a dotted-quad.
#***********************************************************************
sub relay_is_blacklisted_multi {
    my($addr, $timeout, $answers_wanted, $domains, $res) = @_;
    my($domain, $sock);

    my $ans = {};
    my $positive_answers = 0;

    foreach $domain (@{$domains}) {
	$ans->{$domain} = 'SERVFAIL';
    }
    unless ($Features{"Net::DNS"}) {
	md_syslog('err', "Attempted to call relay_is_blacklisted_multi, but Perl module Net::DNS is not installed");
	return $ans;
    }

    push_status_tag("Doing RBL Lookup");
    my %sock_to_domain;

    # Reverse the address
    $addr = reverse_ip_address_for_rbl($addr);

    # If user did not pass in a Net::DNS::Resolver object, generate one.
    unless (defined($res and (UNIVERSAL::isa($res, "Net::DNS::Resolver")))) {
	$res = Net::DNS::Resolver->new;
	$res->defnames(0);
    }

    my $sel = IO::Select->new();

    # Send out the queries
    foreach $domain (@{$domains}) {
	$sock = $res->bgsend("$addr.$domain", 'A');
	$sock_to_domain{$sock} = $domain;
	$sel->add($sock);
    }

    # Now wait for them to come back.
    my $terminate = time() + $timeout;
    while (time() <= $terminate) {
	my $expire = $terminate - time();
	# Avoid fractional wait for select which gets truncated.
	# So we may end up timing out after 1 extra second... no big deal
	$expire = 1 if ($expire < 1);
	my @ready;
	@ready = $sel->can_read($expire);
	foreach $sock (@ready) {
	    my $pack = $res->bgread($sock);
	    $sel->remove($sock);
	    $domain = $sock_to_domain{$sock};
	    undef($sock);
	    my($rr, $rcode);
	    $rcode = $pack->header->rcode;
	    if ($rcode eq "SERVFAIL" or $rcode eq "NXDOMAIN") {
		$ans->{$domain} = $rcode;
		next;
	    }
	    my $got_one = 0;
	    foreach $rr ($pack->answer) {
		if ($rr->type eq 'A') {
		    $got_one = 1;
		    if ($ans->{$domain} eq "SERVFAIL") {
			$ans->{$domain} = ();
		    }
		    push(@{$ans->{$domain}}, $rr->address);
		}
	    }
	    $positive_answers++ if ($got_one);
	}
	last if ($sel->count() == 0 or
		 ($answers_wanted > 0 and $positive_answers >= $answers_wanted));
    }
    pop_status_tag();
    return $ans;
}

#***********************************************************************
# %PROCEDURE: relay_is_blacklisted_multi_count
# %ARGUMENTS:
#  addr -- IP address of relay host.
#  timeout -- number of seconds after which to time out
#  answers_wanted -- if positive, return as soon as this many positive answers
#                    have been received.
#  domains -- an array of domains to check
#  res (optional) -- A Net::DNS::Resolver object.  If you don't pass
#                    one in, we'll generate one and use it.
# %RETURNS:
#  A number indicating how many RBLs the host was blacklisted in.
#***********************************************************************
sub relay_is_blacklisted_multi_count {
    my($addr, $timeout, $answers_wanted, $domains, $res) = @_;
    my $ans = relay_is_blacklisted_multi($addr,
					 $timeout,
					 $answers_wanted,
					 $domains,
					 $res);
    my $count = 0;
    my $domain;
    foreach $domain (keys(%$ans)) {
	my $r = $ans->{$domain};
	if (ref($r) eq "ARRAY" and $#{$r} >= 0) {
	    $count++;
	}
    }
    return $count;
}

#***********************************************************************
# %PROCEDURE: relay_is_blacklisted_multi_list
# %ARGUMENTS:
#  addr -- IP address of relay host.
#  timeout -- number of seconds after which to time out
#  answers_wanted -- if positive, return as soon as this many positive answers
#                    have been received.
#  domains -- an array of domains to check
#  res (optional) -- A Net::DNS::Resolver object.  If you don't pass
#                    one in, we'll generate one and use it.
# %RETURNS:
#  An array indicating the domains in which the relay is blacklisted.
#***********************************************************************
sub relay_is_blacklisted_multi_list {
    my($addr, $timeout, $answers_wanted, $domains, $res) = @_;
    my $ans = relay_is_blacklisted_multi($addr,
					 $timeout,
					 $answers_wanted,
					 $domains,
					 $res);
    my $result = [];
    my $domain;
    foreach $domain (keys(%$ans)) {
	my $r = $ans->{$domain};
	if (ref($r) eq "ARRAY" and $#{$r} >= 0) {
	    push @$result, $domain;
	}
    }

    # If in list context, return the array.  Otherwise, return
    # array reference.
    return (wantarray ? @$result : $result);
}

#***********************************************************************
# %PROCEDURE: signal_unchanged
# %ARGUMENTS:
#  None
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Tells mimedefang C program message has not been altered (does nothing...)
#***********************************************************************
sub signal_unchanged {
}

#***********************************************************************
# %PROCEDURE: signal_changed
# %ARGUMENTS:
#  None
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Tells mimedefang C program message has been altered.
#***********************************************************************
sub signal_changed {
    write_result_line("C", "");
}

#***********************************************************************
# %PROCEDURE: get_host_name
# %ARGUMENTS:
#  None
# %RETURNS:
#  Local host name, if it could be determined.
#***********************************************************************
sub get_host_name {
    # Use cached value if we have it
    return $PrivateMyHostName if defined($PrivateMyHostName);

    # Otherwise execute "hostname"
    $PrivateMyHostName = hostname;

    $PrivateMyHostName = "localhost" unless defined($PrivateMyHostName);

    # Now make it FQDN
    my($fqdn) = gethostbyname($PrivateMyHostName);
    $PrivateMyHostName = $fqdn if (defined $fqdn) and length($fqdn) > length($PrivateMyHostName);

    return $PrivateMyHostName;
}

#***********************************************************************
# %PROCEDURE: gen_date_msgid_headers
# %ARGUMENTS:
#  None
# %RETURNS:
#  A string like this: "Date: <rfc2822-date>\nMessage-ID: <message@id.com>\n"
# %DESCRIPTION:
#  Generates RFC2822-compliant Date and Message-ID headers.
#***********************************************************************
sub gen_date_msgid_headers {
    return "Date: " . rfc2822_date() . "\n" . gen_msgid_header();
}

sub rfc2822_date
{
	my $now = time();
	my ($ss, $mm, $hh, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($now);
	return sprintf("%s, %02d %s %04d %02d:%02d:%02d %s",
		(qw( Sun Mon Tue Wed Thu Fri Sat ))[$wday],
		$mday,
		(qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec ))[$mon],
		$year + 1900,
		$hh,
		$mm,
		$ss,
		header_timezone($now)
	);
}

sub header_timezone
{
    return $CachedTimezone if ($CachedTimezone ne "");

    my($now) = @_;

    my($sec, $min, $hr, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($now);
    my $a = timelocal($sec, $min, $hr, $mday, $mon, $year);
    my $b = timegm($sec, $min, $hr, $mday, $mon, $year);
    my $c = ($b - $a) / 60;
    $hr = int(abs($c) / 60);
    $min = abs($c) - 60 * $hr;

    if ($c >= 0) {
	$CachedTimezone = sprintf("+%02d%02d", $hr, $min);
    } else {
	$CachedTimezone = sprintf("-%02d%02d", $hr, $min);
    }
    return $CachedTimezone;
}

#***********************************************************************
# %PROCEDURE: gen_msgid_header
# %ARGUMENTS:
#  None
# %RETURNS:
#  A string like this: "Message-ID: <message@id.com>\n"
# %DESCRIPTION:
#  Generates RFC2822-compliant Message-ID headers.
#***********************************************************************
sub gen_msgid_header {
	my ($ss, $mm, $hh, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time);

	# Generate a "random" message ID that looks
	# similiar to sendmail's for SpamAssassin comparing
	# Received / MessageID QueueID
	return sprintf("Message-ID: <%04d%02d%02d%02d%02d.%s\@%s>\n",
		$year + 1900,
		$mon  + 1,
		$mday,
		$hh,
		$mm,
		($QueueID eq 'NOQUEUE' ? rand() : $QueueID),
		get_host_name()
	);
}

#***********************************************************************
# %PROCEDURE: send_quarantine_notifications
# %ARGUMENTS:
#  None
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Sends quarantine notification message, if anything was quarantined
#***********************************************************************
sub send_quarantine_notifications {
    # If there are quarantined parts, e-mail a report
    if ($QuarantineCount > 0 || $EntireMessageQuarantined) {
	my($body);
	$body = "From: $DaemonName <$DaemonAddress>\n";
	$body .= "To: \"$AdminName\" <$AdminAddress>\n";
	$body .= gen_date_msgid_headers();
	$body .= "Auto-Submitted: auto-generated\n";
	$body .= "MIME-Version: 1.0\nContent-Type: text/plain\n";
	$body .= "Precedence: bulk\n";
	$body .= "Subject: $QuarantineSubject\n\n";
	if ($QuarantineCount >= 1) {
	    $body .= "An e-mail had $QuarantineCount part";
	    $body .= "s" if ($QuarantineCount != 1);
	} else {
	    $body .= "An e-mail message was";
	}

	$body .= " quarantined in the directory\n";
	$body .= "$QuarantineSubdir on " . get_host_name() . ".\n\n";
	$body .= "The sender was '$Sender'.\n\n" if defined($Sender);
	$body .= "The Sendmail queue identifier was $QueueID.\n\n" if ($QueueID ne "NOQUEUE");
	$body .= "The relay machine was $RelayHostname ($RelayAddr).\n\n";
	if ($EntireMessageQuarantined) {
	    $body .= "The entire message was quarantined in $QuarantineSubdir/ENTIRE_MESSAGE\n\n";
	}

	my($recip);
	foreach $recip (@Recipients) {
	    $body .= "Recipient: $recip\n";
	}
	my $donemsg = 0;
	my $i;
	for ($i=0; $i<=$QuarantineCount; $i++) {
	    if (open(IN, "<$QuarantineSubdir/MSG.$i")) {
		if (!$donemsg) {
		    $body .= "Quarantine Messages:\n";
		    $donemsg = 1;
		}
		while(<IN>) {
		    $body .= $_;
		}
		close(IN);
	    }
	}
	if ($donemsg) {
	    $body .= "\n";
	}

	if (open(IN, "<$QuarantineSubdir/HEADERS")) {
	    $body .= "\n----------\nHere are the message headers:\n";
	    while(<IN>) {
		$body .= $_;
	    }
	    close(IN);
	}
	for ($i=1; $i<=$QuarantineCount; $i++) {
	    if (open(IN, "<$QuarantineSubdir/PART.$i.HEADERS")) {
		$body .= "\n----------\nHere are the headers for quarantined part $i:\n";
		while(<IN>) {
		    $body .= $_;
		}
		close(IN);
	    }
	}
	if ($#Warnings >= 0) {
	    $body .= "\n----------\nHere are the warning details:\n\n";
	    $body .= "@Warnings";
	}
	send_mail($DaemonAddress, $DaemonName, $AdminAddress, $body);
    }
}


#***********************************************************************
# %PROCEDURE: signal_complete
# %ARGUMENTS:
#  None
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Tells mimedefang C program Perl filter has finished successfully.
#  Also mails any quarantine notifications and sender notifications.
#***********************************************************************
sub signal_complete {
    # Send notification to sender, if required
    if ($Sender ne '<>' && -r "NOTIFICATION") {
	my($body);
	$body = "From: $DaemonName <$DaemonAddress>\n";
	$body .= "To: $Sender\n";
	$body .= gen_date_msgid_headers();
	$body .= "Auto-Submitted: auto-generated\n";
	$body .= "MIME-Version: 1.0\nContent-Type: text/plain\n";
	$body .= "Precedence: bulk\n";
	$body .= "Subject: $NotifySenderSubject\n\n";
	unless($NotifyNoPreamble) {
	    $body .= "An e-mail you sent with message-id $MessageID\n";
	    $body .= "was modified by our mail scanning software.\n\n";
	    $body .= "The recipients were:";
	    my($recip);
	    foreach $recip (@Recipients) {
		$body .= " $recip";
	    }
	    $body .= "\n\n";
	}
	if (open(FILE, "<NOTIFICATION")) {
	    unless($NotifyNoPreamble) {
		$body .= "Here are the details of the modification:\n\n";
	    }
	    while(<FILE>) {
		$body .= $_;
	    }
	    close(FILE);
	}
	send_mail($DaemonAddress, $DaemonName, $Sender, $body);
    }

    # Send notification to administrator, if required
    if (-r "ADMIN_NOTIFICATION") {
	my $body = "";
	if (open(FILE, "<ADMIN_NOTIFICATION")) {
	    $body .= join('', <FILE>);
	    close(FILE);
	    send_admin_mail($NotifyAdministratorSubject, $body);
	}
    }

    # Syslog some info if any actions were taken
    my($msg) = "";
    my($key, $num);
    foreach $key (sort keys(%Actions)) {
	$num = $Actions{$key};
	$msg .= " $key=$num";
    }
    if ($msg ne "") {
	md_syslog('debug', "filter: $msg");
    }
    write_result_line("F", "");
    if ($results_fh) {
	    $results_fh->close() or die("Could not close RESULTS file: $!");
	    undef $results_fh;
    }

    if ($ServerMode) {
	print_and_flush('ok');
    }
}

#***********************************************************************
# %PROCEDURE: send_mail
# %ARGUMENTS:
#  fromAddr -- address of sender
#  fromFull -- full name of sender
#  recipient -- address of recipient
#  body -- mail message (including headers) newline-terminated
#  deliverymode -- optional sendmail delivery mode arg (default "-odd")
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Sends a mail message using Sendmail.  Invokes Sendmail without involving
#  the shell, so that shell metacharacters won't cause security problems.
#***********************************************************************
sub send_mail {
    my($fromAddr, $fromFull, $recipient, $body, $deliverymode) = @_;

    $deliverymode = "-odd" unless defined($deliverymode);
    if ($deliverymode ne "-odb" &&
	$deliverymode ne "-odq" &&
	$deliverymode ne "-odd" &&
	$deliverymode ne "-odi") {
	$deliverymode = "-odd";
    }

    my($pid);

    # Fork and exec for safety instead of involving shell
    $pid = open(CHILD, "|-");
    if (!defined($pid)) {
	md_syslog('err', "Cannot fork to run sendmail");
	return;
    }

    if ($pid) {   # In the parent -- pipe mail message to the child
	print CHILD $body;
	close(CHILD);
	return;
    }

    # In the child -- invoke Sendmail

    # Direct stdout to stderr, or we will screw up communication with
    # the multiplexor..
    open(STDOUT, ">&STDERR");

    my(@cmd);
    if ($fromAddr ne "") {
	push(@cmd, "-f$fromAddr");
    } else {
	push(@cmd, "-f<>");
    }
    if ($fromFull ne "") {
	push(@cmd, "-F$fromFull");
    }
    push(@cmd, $deliverymode);
    push(@cmd, "-Ac");
    push(@cmd, "-oi");
    push(@cmd, "--");
    push(@cmd, $recipient);

    # In curlies to silence Perl warning...
    my $sm;
    $sm = $Features{'Path:SENDMAIL'};
    { exec($sm, @cmd); }

    # exec failed!
    md_syslog('err', "Could not exec $sm: $!");
    exit(1);
    # NOTREACHED
}

#***********************************************************************
# %PROCEDURE: resend_message_one_recipient
# %ARGUMENTS:
#  recip -- a single recipient
#  deliverymode -- optional sendmail delivery mode arg (default "-odd")
# %RETURNS:
#  True on success; false on failure.
# %DESCRIPTION:
#  Re-sends the message (as if it came from original sender) to
#  a single recipient.
#***********************************************************************
sub resend_message_one_recipient {
	my($recip, $deliverymode) = @_;
	return resend_message_specifying_mode($deliverymode, [ $recip ]);
}

#***********************************************************************
# %PROCEDURE: send_admin_mail
# %ARGUMENTS:
#  subject -- mail subject
#  body -- mail message (without headers) newline-terminated
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Sends a mail message to the administrator
#***********************************************************************
sub send_admin_mail {

    my ($subject, $body) = @_;

    my $mail;
    $mail = "From: $DaemonName <$DaemonAddress>\n";
    $mail .= "To: \"$AdminName\" <$AdminAddress>\n";
    $mail .= gen_date_msgid_headers();
    $mail .= "Auto-Submitted: auto-generated\n";
    $mail .= "MIME-Version: 1.0\nContent-Type: text/plain\n";
    $mail .= "Precedence: bulk\n";
    $mail .= "Subject: $subject\n\n";
    $mail .= $body;

    send_mail($DaemonAddress, $DaemonName, $AdminAddress, $mail);
}

#***********************************************************************
# %PROCEDURE: resend_message_specifying_mode
# %ARGUMENTS:
#  deliverymode -- delivery mode
#  recipients -- reference to list of recipients to resend message to.
# %RETURNS:
#  True on success; false on failure.
# %DESCRIPTION:
#  Re-sends the message (as if it came from original sender) to
#  a list of recipients.
#***********************************************************************
sub resend_message_specifying_mode {
    my($deliverymode, $recips) = @_;
    return 0 if (!in_message_context("resend_message_specifying_mode"));

    $deliverymode = "-odd" unless defined($deliverymode);
    if ($deliverymode ne "-odb" &&
	$deliverymode ne "-odq" &&
	$deliverymode ne "-odd" &&
	$deliverymode ne "-odi") {
	$deliverymode = "-odd";
    }

    # Fork and exec for safety instead of involving shell
    my $pid = open(CHILD, "|-");
    if (!defined($pid)) {
	md_syslog('err', "Cannot fork to resend message");
	return 0;
    }

    if ($pid) {   # In the parent -- pipe mail message to the child
	unless (open(IN, "<INPUTMSG")) {
	    md_syslog('err', "Could not open INPUTMSG in resend_message: $!");
	    return 0;
	}

	# Preserve relay's IP address if possible...
	if ($ValidateIPHeader =~ /^X-MIMEDefang-Relay/) {
	    print CHILD "$ValidateIPHeader: $RelayAddr\n"
	}

	# Synthesize a Received: header
	print CHILD synthesize_received_header();

	# Copy message over
	while(<IN>) {
	    print CHILD;
	}
	close(IN);
	if (!close(CHILD)) {
	    if ($!) {
		md_syslog('err', "sendmail failure in resend_message: $!");
	    } else {
		md_syslog('err', "sendmail non-zero exit status in resend_message: $?");
	    }
	    return 0;
	}
	return 1;
    }

    # In the child -- invoke Sendmail

    # Direct stdout to stderr, or we will screw up communication with
    # the multiplexor..
    open(STDOUT, ">&STDERR");

    my(@cmd);
    if ($Sender eq "") {
	push(@cmd, "-f<>");
    } else {
	push(@cmd, "-f$Sender");
    }
    push(@cmd, $deliverymode);
    push(@cmd, "-Ac");
    push(@cmd, "-oi");
    push(@cmd, "--");
    push @cmd, @$recips;

    # In curlies to silence Perl warning...
    my $sm;
    $sm = $Features{'Path:SENDMAIL'};
    { exec($sm, @cmd); }

    # exec failed!
    md_syslog('err', "Could not exec $sm: $!");
    exit(1);
    # NOTREACHED
}

#***********************************************************************
# %PROCEDURE: resend_message
# %ARGUMENTS:
#  recipients -- list of recipients to resend message to.
# %RETURNS:
#  True on success; false on failure.
# %DESCRIPTION:
#  Re-sends the message (as if it came from original sender) to
#  a list of recipients.
#***********************************************************************
sub resend_message {
    return 0 if (!in_message_context("resend_message"));
    my(@recips);
    @recips = @_;
    return resend_message_specifying_mode("-odd", \@recips);
}

#***********************************************************************
# %PROCEDURE: stream_by_recipient
# %ARGUMENTS:
#  None
# %RETURNS:
#  True if message was resent; false if it was for only a single user
# %DESCRIPTION:
#  If there is more than one recipient, re-send the message once per
#  recipient.
#  MAKE SURE your sendmail is set up to use
#  /etc/mail/submit.cf.
#
#  Use this
#  ONLY from filter_begin() and ONLY if you have Sendmail 8.12 or newer,
#  and ONLY if locally-submitted mail goes via SMTP.
#***********************************************************************
sub stream_by_recipient {
    return 0 if (!in_message_context("stream_by_recipient"));
    if ($#Recipients <= 0) {
	# Only one recipient (or none??)
	return 0;
    }

    my($recip);

    foreach $recip (@Recipients) {
	if (!resend_message_one_recipient($recip)) {
	    md_syslog('crit', 'stream_by_recipient: COULD NOT RESEND MESSAGE - PLEASE INVESTIGATE');
	    action_bounce("Unable to stream message");

	    # We return 1 to avoid rest of filter
	    return 1;
	}
    }
    $TerminateAndDiscard = 1;
    return 1;
}

#***********************************************************************
# %PROCEDURE: stream_by_domain
# %ARGUMENTS:
#  None
# %RETURNS:
#  True if message was resent; false if it was for only a single domain.
# %DESCRIPTION:
#  Checks each recipient.  If recipients are in more than one domain
#  (foo@abc.com, foo@xyz.com), the message is re-sent (once per domain),
#  action_discard() is called, and scanning terminates.  Use this
#  ONLY from filter_begin() and ONLY if you have Sendmail 8.12 or newer,
#  and ONLY if locally-submitted mail goes via SMTP.
#***********************************************************************
sub stream_by_domain {
    my(%Domains, $recip, $dom, $nkeys, $key);
    return 0 if (!in_message_context("stream_by_domain"));

    # Grab list of domains of recipients
    foreach $recip (@Recipients) {
	$dom = $recip;
	# Remove angle brackets
	$dom =~ s/[<>]//g;
	# Get domain
	$dom =~ s/.*\@//;
	if (!defined($Domains{$dom})) {
	    $Domains{$dom} = [ $recip ];
	} else {
	    push( @{ $Domains{$dom} }, $recip);
	}
	$Domain = $dom;
    }

    $nkeys = keys(%Domains);
    if ($nkeys > 1) {
	# More than one domain.  Cancel and resend
	foreach $key (keys %Domains) {
	    if (!resend_message(@{$Domains{$key}})) {
		md_syslog('crit', 'stream_by_domain: COULD NOT RESEND MESSAGE - PLEASE INVESTIGATE');
		action_bounce("Unable to stream message");

		# We return 1 to avoid rest of filter
		return 1;
	    }
	}
	$TerminateAndDiscard = 1;
	return 1;
    }

    return 0;
}

=pod 

=head2  takeStabAtFilename ( $entity )

Makes a guess at a filename for the attachment.  Calls MIME::Head's
recommended_filename() method, which tries 'Content-Disposition.filename'and if
not found, 'Content-Type.name'.

Returns a MIME-decoded filename, or a blank string if none found.

=cut

sub takeStabAtFilename
{
	my ($entity) = @_;

	my $guess = $entity->head->recommended_filename();

	if( defined $guess ) {
		return scalar( decode_mimewords( $guess ) );
	}

	return '';
}

#***********************************************************************
# %PROCEDURE: re_match
# %ARGUMENTS:
#  entity -- a MIME entity
#  regexp -- a regular expression
# %RETURNS:
#  1 if either of Content-Disposition.filename or Content-Type.name
#  matches regexp; 0 otherwise.  Matching is
#  case-insensitive
# %DESCRIPTION:
#  A helper function for filter.
#***********************************************************************
sub re_match {
    my($entity, $regexp) = @_;
    my($head) = $entity->head;

    my($guess) = $head->mime_attr("Content-Disposition.filename");
    if (defined($guess)) {
	$guess = decode_mimewords($guess);
	return 1 if $guess =~ /$regexp/i;
    }

    $guess = $head->mime_attr("Content-Type.name");
    if (defined($guess)) {
	$guess = decode_mimewords($guess);
	return 1 if $guess =~ /$regexp/i;
    }

    return 0;
}

#***********************************************************************
# %PROCEDURE: re_match_ext
# %ARGUMENTS:
#  entity -- a MIME entity
#  regexp -- a regular expression
# %RETURNS:
#  1 if the EXTENSION part of either of Content-Disposition.filename or
#  Content-Type.name matches regexp; 0 otherwise.
#  Matching is case-insensitive.
# %DESCRIPTION:
#  A helper function for filter.
#***********************************************************************
sub re_match_ext {
    my($entity, $regexp) = @_;
    my($ext);
    my($head) = $entity->head;

    my($guess) = $head->mime_attr("Content-Disposition.filename");
    if (defined($guess)) {
	$guess = decode_mimewords($guess);
	return 1 if (($guess =~ /(\.[^.]*)$/) && ($1 =~ /$regexp/i));
    }

    $guess = $head->mime_attr("Content-Type.name");
    if (defined($guess)) {
	$guess = decode_mimewords($guess);
	return 1 if (($guess =~ /(\.[^.]*)$/) && ($1 =~ /$regexp/i));
    }

    return 0;
}

#***********************************************************************
# %PROCEDURE: re_match_in_zip_directory
# %ARGUMENTS:
#  fname -- name of ZIP file
#  regexp -- a regular expression
# %RETURNS:
#  1 if the EXTENSION part of any file in the zip archive matches regexp
#  Matching is case-insensitive.
# %DESCRIPTION:
#  A helper function for filter.
#***********************************************************************
no strict 'subs';
sub dummy_zip_error_handler {} ;

sub re_match_in_zip_directory {
    my($zipname, $regexp) = @_;
    unless ($Features{"Archive::Zip"}) {
	md_syslog('err', "Attempted to use re_match_in_zip_directory, but Perl module Archive::Zip is not installed.");
	return 0;
    }
    my $zip = Archive::Zip->new();

    # Prevent carping about errors
    Archive::Zip::setErrorHandler(\&dummy_zip_error_handler);
    if ($zip->read($zipname) == AZ_OK()) {
	foreach my $member ($zip->members()) {
	    my $file = $member->fileName();
	    return 1 if ($file =~ /$regexp/i);
	}
    }

    return 0;
}
use strict 'subs';

#***********************************************************************
# %PROCEDURE: entity_contains_virus_nai
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by NAI uvscan; 0 otherwise.
# %DESCRIPTION:
#  Runs the NAI Virus Scan program on the entity. (http://www.nai.com)
#***********************************************************************
sub entity_contains_virus_nai {

    unless ($Features{'Virus:NAI'}) {
	md_syslog('err', "NAI Virus Scan not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;

    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run uvscan
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:NAI'} . " --mime --noboot --secure --allole $path 2>&1", "Found");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }

    # UVScan return codes
    return (wantarray ? interpret_nai_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_nai
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the NAI Virus Scan program on the working directory
#***********************************************************************
sub message_contains_virus_nai {

    unless ($Features{'Virus:NAI'}) {
	md_syslog('err', "NAI Virus Scan not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run uvscan
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:NAI'} . " --noboot --secure --mime --allole ./Work 2>&1", "Found");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    # UVScan return codes
    return (wantarray ? interpret_nai_code($code) : $code);
}

sub interpret_nai_code {
    # Info from Anthony Giggins
    my($code) = @_;
    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # Driver integrity check failed
    return ($code, 'swerr', 'tempfail') if ($code == 2);

    # "A general problem occurred" -- idiot Windoze programmers...
    return ($code, 'swerr', 'tempfail') if ($code == 6);

    # Could not find a driver
    return ($code, 'swerr', 'tempfail') if ($code == 8);

    # Scanner tried to clean a file, but it failed
    return ($code, 'swerr', 'tempfail') if ($code == 12);

    # Virus found
    if ($code == 13) {
	# Sigh... stupid NAI can't have a standard message.  Go through
	# hoops to get virus name.
	my $cm = $CurrentVirusScannerMessage;
	$cm =~ s/ !+//;
	$cm =~ s/!+//;
	if ($VirusName eq "") {
	    $VirusName = "EICAR-Test"
		if ($cm =~ m/Found: EICAR test file/i);
	}
	if ($VirusName eq "") {
	    $VirusName = $1
		if ($cm =~ m/^\s+Found the (\S+) .*virus/i);
	}
	if ($VirusName eq "") {
	    $VirusName = $1
		if ($cm =~ m/Found the (.*) trojan/i);
	}
	if ($VirusName eq "") {
	    $VirusName = $1
		if ($cm =~ m/Found .* or variant (.*)/i);
	}
	$VirusName = "unknown-NAI-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # Self-check failed
    return ($code, 'swerr', 'tempfail') if ($code == 19);

    # User quit using --exit-on-error
    return ($code, 'interrupted', 'tempfail') if ($code == 102);

    # Unknown exit code
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_bdc
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by Bitdefender; 0 otherwise.
# %DESCRIPTION:
#  Runs the Bitdefender program on the entity. (http://www.bitdefender.com)
#***********************************************************************
sub entity_contains_virus_bdc {

    unless($Features{'Virus:BDC'}) {
	md_syslog('err', "Bitdefender not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;
    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    if (! ($path =~ m+^/+)) {
	$path = $CWD . "/" . $path;
    }

    # Run bdc
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:BDC'} . " $path --mail 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_bdc_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_bdc
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the Bitdefender program on the working directory
#***********************************************************************
sub message_contains_virus_bdc {

    unless($Features{'Virus:BDC'}) {
	md_syslog('err', "Bitdefender not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run bdc
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:BDC'} . " $CWD/Work --mail --arc 2>&1");
    return (wantarray ? interpret_bdc_code($code) : $code);
}

sub interpret_bdc_code {
    my($code) = @_;

    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # If code is not 0 or 1, it's an internal error
    return ($code, 'swerr', 'tempfail') if ($code != 1);

    # Code is 1 -- virus found.
    $VirusName = $1 if ($CurrentVirusScannerMessage =~ m/(?:suspected|infected)\: (\S+)/);
    $VirusName = "unknown-BDC-virus" if $VirusName eq "";

    return ($code, 'virus', 'quarantine');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_csav
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by Command Anti-Virus
# %DESCRIPTION:
#  Runs the Command Anti-Virus program. (http://www.commandsoftware.com)
#***********************************************************************
sub entity_contains_virus_csav {

    unless($Features{'Virus:CSAV'}) {
	md_syslog('err', "Command Anti-Virus not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;

    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run csav
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:CSAV'} . " $path 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }

    # csav return codes
    return (wantarray ? interpret_csav_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_csav
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the Command Anti-Virus program on the working directory
#***********************************************************************
sub message_contains_virus_csav {

    unless($Features{'Virus:CSAV'}) {
	md_syslog('err', "Command Anti-Virus not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run csav
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:CSAV'} . " ./Work 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    # csav return codes
    return (wantarray ? interpret_csav_code($code) : $code);
}

sub interpret_csav_code {
    my($code) = @_;
    # OK
    return ($code, 'ok', 'ok') if ($code == 50);

    # Interrupted
    return ($code, 'interrupted', 'tempfail') if ($code == 5);

    # Out of memory
    return ($code, 'swerr', 'tempfail') if ($code == 101);

    # Suspicious files found
    if ($code == 52) {
	$VirusName = 'suspicious';
	return ($code, 'suspicious', 'quarantine');
    }

    # Found a virus
    if ($code == 51) {
	$VirusName = $1 if ($CurrentVirusScannerMessage =~ m/infec.*\: (\S+)/i);
	$VirusName = "unknown-CSAV-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # Found a virus and disinfected
    if ($code == 53) {
	$VirusName = "unknown-CSAV-virus disinfected";
	return ($code, 'virus', 'quarantine');
    }

    # Unknown exit code
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_fsav
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by F-Secure Anti-Virus
# %DESCRIPTION:
#  Runs the F-Secure Anti-Virus program. (http://www.f-secure.com)
#***********************************************************************
sub entity_contains_virus_fsav {

    unless($Features{'Virus:FSAV'}) {
	md_syslog('err', "F-Secure Anti-Virus not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;

    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run fsav
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:FSAV'} . " --dumb --mime $path 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }

    # fsav return codes
    return (wantarray ? interpret_fsav_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_fsav
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the F-Secure Anti-Virus program on the working directory
#***********************************************************************
sub message_contains_virus_fsav {

    unless($Features{'Virus:FSAV'}) {
	md_syslog('err', "F-Secure Anti-Virus not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run fsav
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:FSAV'} . " --dumb --mime ./Work 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    # fsav return codes
    return (wantarray ? interpret_fsav_code($code) : $code);
}

sub interpret_fsav_code {
    # Info from David Green
    my($code) = @_;
    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # Abnormal termination
    return ($code, 'swerr', 'tempfail') if ($code == 1);

    # Self-test failed
    return ($code, 'swerr', 'tempfail') if ($code == 2);

    # Found a virus
    if ($code == 3 or $code == 6) {
	$VirusName = $1
	    if ($CurrentVirusScannerMessage =~ m/infec.*\: (\S+)/i);
	$VirusName = "unknown-FSAV-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # Interrupted
    return ($code, 'interrupted', 'tempfail') if ($code == 5);

    # Out of memory
    return ($code, 'swerr', 'tempfail') if ($code == 7);

    # Suspicious files found
    if ($code == 8) {
	$VirusName = 'suspicious';
	return ($code, 'suspicious', 'quarantine');
    }

    # Unknown exit code
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: scan_file_using_fprotd_v6
# %ARGUMENTS:
#  fname -- name of file to scan
#  host -- host and port on which FPROTD version 6 is listening,
#          eg 127.0.0.1:7777
# %RETURNS:
#  A (code, category, action) triplet.  Sets VirusName if virus found.
# %DESCRIPTION:
#  Asks FPROTD version 6 to scan a file.
#***********************************************************************
sub scan_file_using_fprotd_v6
{
    my($fname, $hname) = @_;

    $hname ||= $Fprotd6Host;
    my($host, $port) = split(/:/, $hname);
    $host ||= '127.0.0.1';
    $port ||= 10200;

    my $connect_timeout = 10;
    my $read_timeout = 60;

    # Convert path to absolute
    if (! ($fname =~ m+^/+)) {
	my($cwd);
	chomp($cwd = `pwd`);
	$fname = $cwd . "/" . $fname;
    }

    my $sock = IO::Socket::INET->new(
	PeerAddr => $host,
	PeerPort => $port,
	Timeout => $connect_timeout);

    unless (defined $sock) {
	md_syslog('warning', "Could not connect to FPROTD6 on $host: $!");
	return (999, 'cannot-execute', 'tempfail');
    }

    if (!$sock->print("SCAN --scanlevel=2 --archive=2 --heurlevel=2 --adware --applications FILE $fname\n") || !$sock->flush()) {
	md_syslog('warning', "Error writing to FPROTD6 on $host: $!");
	$sock->close();
	return (999, 'cannot-execute', 'tempfail');
    }

    my $s = IO::Select->new($sock);
    if (!$s->can_read($read_timeout)) {
	$sock->close();
	md_syslog('warning', "Timeout reading from FPROTD6 daemon on $host");
	return (999, 'cannot-execute', 'tempfail');
    }

    my $resp = $sock->getline();
    $sock->close();
    if (!$resp) {
	md_syslog('warning', "Did not get response from FPROTD6 on $host while scanning $fname");
	return (999, 'cannot-execute', 'tempfail');
    }

    my ($code, $desc, $name);
    unless (($code, $desc, $name) = $resp =~ /\A(\d+)\s<(.*?)>\s(.*)\Z/) {
	md_syslog('warning', "Failed to parse response from FPROTD6 for $fname: $resp");
	return (999, 'cannot-execute', 'tempfail');

    }

    # Clean up $desc
    $desc =~ s/\A(?:contains infected objects|infected):\s//i;

    # Our output should contain:
    # 1) A code.  The code is a bitmask of:
    # bit num Meaning
    #  0   1  At least one virus-infected object was found (and remains).
    #  1   2  At least one suspicious (heuristic match) object was found (and remains).
    #  2   4  Interrupted by user. (SIGINT, SIGBREAK).
    #  3   8  Scan restriction caused scan to skip files (maxdepth directories, maxdepth archives, exclusion list, etc).
    #  4  16  Platform error (out of memory, real I/O errors, insufficient file permission etc.).
    #  5  32  Internal engine error (whatever the engine fails at)
    #  6  64  At least one object was not scanned (encrypted file, unsupported/unknown compression method, corrupted or invalid file).
    #  7 128  At least one object was disinfected (clean now) (treat same as virus for File::VirusScan)
    #
    # 2) The description, including virus name
    #
    # 3) The item name, incl. member of archive etc.  We ignore
    # this for now.

    if($code & (1 | 2 | 128)) {
	$VirusName = $desc;
	$VirusName ||= 'unknown-FPROTD6-virus';
	return ($code, 'virus', 'quarantine');
    } elsif($code & 4) {
	md_syslog('warning', 'FPROTD6 scanning interrupted by user');
	return ($code, 'interrupted', 'tempfail');
    } elsif($code & 16) {
	md_syslog('warning', 'FPROTD6 platform error');
	return ($code, 'swerr', 'tempfail');
    } elsif($code & 32) {
	md_syslog('warning', 'FPROTD6 internal engine error');
	return ($code, 'swerr', 'tempfail');
    }

    return(0, 'ok', 'ok');
}

#***********************************************************************
# %PROCEDURE: scan_file_using_carrier_scan
# %ARGUMENTS:
#  fname -- name of file to scan
#  host -- host and port on which Carrier Scan is listening, eg 127.0.0.1:7777
#          Can optionally have :local or :nonlocal appended to force
#          AVSCANLOCAL or AVSCAN
# %RETURNS:
#  A (code, category, action) triplet.  Sets VirusName if virus found.
# %DESCRIPTION:
#  Asks Symantec CarrierScan Server to scan a file.
#***********************************************************************
sub scan_file_using_carrier_scan {
    my($fname, $hname) = @_;

    my($host, $port, $local) = split(/:/, $hname);
    # If not specified, use local scanning for 127.0.0.1, remote for
    # any other.
    unless(defined($local)) {
	if ($host =~ /^127\.0\.0\.1/) {
	    $local = 1;
	} else {
	    $local = 0;
	}
    }

    # Convert from strings
    if ($local eq "local") {
	$local = 1;
    }
    if ($local eq "nonlocal") {
	$local = 0;
    }

    $port = 7777 unless defined($port);

    # Convert path to absolute
    if (! ($fname =~ m+^/+)) {
	my($cwd);
	chomp($cwd = `pwd`);
	$fname = $cwd . "/" . $fname;
    }
    my $sock = IO::Socket::INET->new("$host:$port");
    my ($line);
    unless (defined $sock) {
	md_syslog('warning', "Could not connect to CarrierScan Server on $host: $!");
	return (999, 'cannot-execute', 'tempfail');
    }

    # Read first line of reply from socket
    chomp($line = $sock->getline);
    $line =~ s/\r//g;
    unless ($line =~ /^220/) {
	md_syslog('warning', "Unexpected reply $line from CarrierScan Server");
	$sock->close;
	return (999, 'swerr', 'tempfail');
    }

    # Next line must be version
    chomp($line = $sock->getline);
    $line =~ s/\r//g;
    unless ($line eq "2") {
	md_syslog('warning', "Unexpected version $line from CarrierScan Server");
	$sock->close;
	return(999, 'swerr', 'tempfail');
    }

    # Cool; send our stuff!
    if ($local) {
	if (!$sock->print("Version 2\nAVSCANLOCAL\n$fname\n")) {
	    $sock->close;
	    return (999, 'swerr', 'tempfail');
	}
    } else {
	my ($size);
	my ($chunk);
	my ($chunksize, $nread);
	$size = (stat($fname))[7];
	unless(defined($size)) {
	    md_syslog('warning', "Cannot stat $fname: $!");
	    $sock->close;
	    return(999, 'swerr', 'tempfail');
	}
	if (!$sock->print("Version 2\nAVSCAN\n$fname\n$size\n")) {
	    $sock->close;
	    return (999, 'swerr', 'tempfail');
	}
	unless(open(IN, "<$fname")) {
	    md_syslog('warning', "Cannot open $fname: $!");
	    $sock->close;
	    return(999, 'swerr', 'tempfail');
	}
	while ($size > 0) {
	    if ($size < 8192) {
		$chunksize = $size;
	    } else {
		$chunksize = 8192;
	    }
	    $nread = read(IN, $chunk, $chunksize);
	    unless(defined($nread)) {
		md_syslog('warning', "Error reading $fname: $!");
		$sock->close;
		return(999, 'swerr', 'tempfail');
	    }
	    last if ($nread == 0);
	    if (!$sock->print($chunk)) {
		$sock->close;
		return (999, 'swerr', 'tempfail');
	    }
	    $size -= $nread;
	}
	if ($size > 0) {
	    md_syslog('warning', "Error reading $fname: $!");
	    $sock->close;
	    return(999, 'swerr', 'tempfail');
	}
    }
    if (!$sock->flush) {
	$sock->close;
	return (999, 'swerr', 'tempfail');
    }

    # Get reply from server
    chomp($line = $sock->getline);
    $line =~ s/\r//g;
    unless ($line =~ /^230/) {
	md_syslog('warning', "Unexpected response to AVSCAN or AVSCANLOCAL command: $line");
	$sock->close;
	return(999, 'swerr', 'tempfail');
    }
    # Get infection status
    chomp($line = $sock->getline);
    $line =~ s/\r//g;
    if ($line == 0) {
	$sock->close;
	return (0, 'ok', 'ok');
    }

    # Skip definition date and version, infection count and filename
    chomp($line = $sock->getline); # Definition date
    chomp($line = $sock->getline); # Definition version
    chomp($line = $sock->getline); # Infection count (==1)
    chomp($line = $sock->getline); # Filename

    # Get virus name
    chomp($line = $sock->getline);
    $line =~ s/\r//g;
    $sock->close;

    $VirusName = $line;
    return (1, 'virus', 'quarantine');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_carrier_scan
# %ARGUMENTS:
#  entity -- a MIME entity
#  host (optional) -- Symantec CarrierScan host:port
# %RETURNS:
#  Usual virus status
# %DESCRIPTION:
#  Scans the entity using Symantec CarrierScan
#***********************************************************************
sub entity_contains_virus_carrier_scan {
    my($entity) = shift;
    my($host) = $CSSHost;
    $host = shift if (@_ > 0);
    $host = '127.0.0.1:7777:local' if (!defined($host));
    if (!defined($entity->bodyhandle)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    if (!defined($entity->bodyhandle->path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }
    return scan_file_using_carrier_scan($entity->bodyhandle->path,
					$host);
}

sub entity_contains_virus_fprotd_v6
{
    my($entity, $host) = @_;
    $host ||= $Fprotd6Host;
    if (!defined($entity->bodyhandle)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    if (!defined($entity->bodyhandle->path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }
    return scan_file_using_fprotd_v6($entity->bodyhandle->path,
				     $host);
}

sub message_contains_virus_fprotd_v6
{
    my($host) = @_;
    $host ||= $Fprotd6Host;

    if (!opendir(DIR, "./Work")) {
	md_syslog('err', "message_contains_virus_fprotd_v6: Could not open ./Work directory: $!");
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Scan all files in Work
    my(@files);
    @files = grep { -f "./Work/$_" } readdir(DIR);
    closedir(DIR);

    my($file, $code, $category, $action);
    foreach $file (@files) {
	($code, $category, $action) =
	    scan_file_using_fprotd_v6("Work/$file", $host);
	if ($code != 0) {
	    return (wantarray ? ($code, $category, $action) : $code);
	}
    }
    return (0, 'ok', 'ok');
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_carrier_scan
# %ARGUMENTS:
#  host (optional) -- Symantec CarrierScan host:port
# %RETURNS:
#  Usual virus status
# %DESCRIPTION:
#  Scans the entity using Symantec CarrierScan
#***********************************************************************
sub message_contains_virus_carrier_scan {
    my($host) = $CSSHost;
    $host = shift if (@_ > 0);
    $host = '127.0.0.1:7777:local' if (!defined($host));

    if (!opendir(DIR, "./Work")) {
	md_syslog('err', "message_contains_virus_carrier_scan: Could not open ./Work directory: $!");
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Scan all files in Work
    my(@files);
    @files = grep { -f "./Work/$_" } readdir(DIR);
    closedir(DIR);

    my($file, $code, $category, $action);
    foreach $file (@files) {
	($code, $category, $action) =
	    scan_file_using_carrier_scan("Work/$file", $host);
	if ($code != 0) {
	    return (wantarray ? ($code, $category, $action) : $code);
	}
    }
    return (0, 'ok', 'ok');
}

#***********************************************************************
# %PROCEDURE: item_contains_virus_fprotd
# %ARGUMENTS:
#  item -- a file or directory
#  host (optional) -- Fprotd host and base port.
# %RETURNS:
#  Usual virus status
# %DESCRIPTION:
#  Scans the entity using Fprotd scanning daemon
#***********************************************************************
sub item_contains_virus_fprotd {
    my $item = shift;
    my ($host) = $FprotdHost;
    $host = shift if (@_ > 0);
    $host = '127.0.0.1' if (!defined($host));
    my $baseport = 10200;
    if($host =~ /(.*):(.*)/ ) {
	$host = $1;
	$baseport = $2;
    }

    md_syslog('info', "Scan '$item' via F-Protd \@$host:$baseport");
    # The F-Prot demon cannot scan directories, but files only
    # hence, we recurse any directories manually
    if(-d $item) {
	my @result;
	$host .= ":$baseport";
	foreach my $entry (glob("$item/*")) {
	    @result = &item_contains_virus_fprotd($entry, $host);
	    last if $result[0] != 0;
	}
	return (wantarray ? @result : $result[0]);
    }

    # Default error message when reaching end of function
    my $errmsg = "Could not connect to F-Prot Daemon at $host:$baseport";

    # Try 5 ports in order to find an active scanner; they may change the port
    # when they find and spawn an updated demon executable
SEARCH_DEMON: foreach my $port ($baseport..($baseport+4)) {
    my $sock = IO::Socket::INET->new(PeerAddr => $host, PeerPort => $port);
    if (defined $sock) {

	# The arguments (following the '?' sign in the HTTP request)
	# are the same as for the command line F-Prot, the additional
	# -remote-dtd suppresses the unuseful XML DTD prefix
	if (!$sock->print("GET $item?-dumb%20-archive%20-packed%20-remote-dtd HTTP/1.0\n\n")) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 999);
	}
	if (!$sock->flush) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 999);
	}

	# Fetch HTTP Header
	## Maybe dropped, if no validation checks are to be made
	while(my $output = $sock->getline) {
	    if($output =~ /^\s*$/) {
		last;	# break line for XML content
		#### Below here: Validating the protocol
		#### If the protocol is not recognized, it's assumed that the
		#### endpoint is not an F-Prot demon, hence,
		#### the next port is probed.
	    } elsif($output =~ /^HTTP(.*)/) {
		my $h = $1;
		next SEARCH_DEMON unless $h =~ m!/1\.0\s+200\s!;
	    } elsif($output =~ /^Server:\s*(\S*)/) {
		next SEARCH_DEMON if $1 !~ /^fprotd/;
	    }
	}

	# Parsing XML results
	my $xml = HTML::TokeParser->new($sock);
	my $t = $xml->get_tag('fprot-results');
	unless($t) {	# This is an essential tag --> assume a broken demon
	    $errmsg = 'Demon did not return <fprot-results> tag';
	    last SEARCH_DEMON;
	}

	if($t->[1]{'version'} ne '1.0') {
	    $errmsg = "Incompatible F-Protd results version: "
		. $t->[1]{'version'};
	    last SEARCH_DEMON;
	}

	my $curText;	# temporarily accumulated information
	my $virii = '';	# name(s) of virus(es) found
	my $code;	# overall exit code
	my $msg = '';	# accumulated message of virus scanner
	while( $t = $xml->get_token ) {
	    my $tag = $t->[1];
	    if($t->[0] eq 'S') {	# Start tag
		# Accumulate the information temporarily
		# into $curText until the </detected> tag is found
		my $text = $xml->get_trimmed_text;
		# $tag 'filename' of no use in MIMEDefang
		if($tag eq 'name') {
		    $virii .= (length $virii ? " " : "" ) . $text;
		    $curText .= "Found the virus: '$text'\n";
		} elsif($tag eq 'accuracy' || $tag eq 'disinfectable' ||
		        $tag eq 'message') {
		    $curText .= "\t$tag: $text\n";
		} elsif($tag eq 'error') {
		    $msg .= "\nError: $text\n";
		} elsif($tag eq 'summary') {
		    $code = $t->[2]{'code'}
		    if defined $t->[2]{'code'};
		}
	    } elsif($t->[0] eq 'E') {	# End tag
		if($tag eq 'detected') {
		    # move the cached information to the
		    # accumulated message
		    $msg .= "\n$curText" if $curText;
		    undef $curText;
		} elsif($tag eq 'fprot-results') {
		    last;	# security check
		}
	    }
	}
	$sock->close;

## Check the exit code (man f-protd)
## NOTE: These codes are different from the ones of the command line version!
#  0      Not scanned, unable to handle the object.
#  1      Not scanned due to an I/O error.
#  2      Not scanned, as the scanner ran out of memory.
#  3  X   The object is not of a type the scanner knows. This
#         may  either mean it was misidentified or that it is
#         corrupted.
#  4  X   The object was valid, but encrypted and  could  not
#         be scanned.
#  5      Scanning of the object was interrupted.
#  7  X   The  object was identified as an "innocent" object.
#  9  X   The object was successfully scanned and nothing was
#         found.
#  11     The object is infected.
#  13     The object was disinfected.
	unless(defined $code) {
	    $errmsg = "No summary code found";
	    last SEARCH_DEMON;
	}
	if($code < 3 # I/O error, unable to handle, out of mem
	   # any filesystem error less than zero
	   || $code == 5) { # interrupted
	    ## assume this a temporary failure
	    $errmsg = "Scan error #$code: $msg";
		last SEARCH_DEMON;
	}

	if($code > 10) { # infected; (disinfected: Should never happen!)
	    # Add the accumulated information
	    $VirusScannerMessages .= $msg;
	    if ( length $virii ) {
		$VirusName = $virii;
	    } elsif ( $msg =~ /^\tmessage:\s+(\S.*)/m ) {
		$VirusName = $1;
	    } else {
                # no virus name found, log message returned by fprot
                $msg =~ s/\s+/ /g;
                md_syslog('info',
                    qq[$MsgID: cannot extract virus name from f-prot: "$msg"]);
                $VirusName = "unknown";
            }
	    return (wantarray ? (1, 'virus', 'quarantine') : 1);
	}
###### These codes are left to be handled:
#  3  X   The object is not of a type the scanner knows. This
#         may  either mean it was misidentified or that it is
#         corrupted.
#  4  X   The object was valid, but encrypted and  could  not
#         be scanned.
#  7  X   The  object was identified as an "innocent" object.
#  9  X   The object was successfully scanned and nothing was

#	9 is trival; 7 is probably trival
#	4 & 3 we can't do anything really, because if the attachement
#	is some unknown archive format, the scanner wouldn't had known
#	this issue anyway, hence, I consider it "clean"

	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
}

    # Could not connect to daemon or some error occured during the
    # communication with it
    $errmsg =~ s/\s*\.*\s*\n+\s*/\. /g;
    md_syslog('err', "$errmsg");
    return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_fprotd
# %ARGUMENTS:
#  entity -- a MIME entity
#  host (optional) -- F-Prot Demon host:port
# %RETURNS:
#  1 if entity contains a virus as reported by F-Prot Demon
# %DESCRIPTION:
#  Invokes the F-Prot daemon (http://www.frisk.org/) on
#  the entity.
#***********************************************************************
sub entity_contains_virus_fprotd {
    my ($entity) = shift;

    if (!defined($entity->bodyhandle)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    if (!defined($entity->bodyhandle->path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    my $path = $entity->bodyhandle->path;
    # If path is not absolute, add cwd
    if (! ($path =~ m+^/+)) {
	$path = $CWD . "/" . $path;
    }
    return item_contains_virus_fprotd($path, $_[0]);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_fprotd
# %ARGUMENTS:
#  host (optional) -- F-Prot Demon host:port
# %RETURNS:
#  1 if entity contains a virus as reported by F-Prot Demon
# %DESCRIPTION:
#  Invokes the F-Prot daemon (http://www.frisk.org/) on
#  the entire message.
#***********************************************************************
sub message_contains_virus_fprotd {
    return item_contains_virus_fprotd ("$CWD/Work", $_[0]);
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_hbedv
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by H+BEDV Antivir; 0 otherwise.
# %DESCRIPTION:
#  Runs the H+BEDV Antivir program on the entity. (http://www.hbedv.com)
#***********************************************************************
sub entity_contains_virus_hbedv {

    unless($Features{'Virus:HBEDV'}) {
	md_syslog('err', "H+BEDV not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;
    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run antivir
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:HBEDV'} . " --allfiles -z -rs $path 2>&1", "!Virus!|>>>|VIRUS:|ALERT:");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_hbedv_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_hbedv
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the H+BEDV Antivir program on the working directory
#***********************************************************************
sub message_contains_virus_hbedv {

    unless($Features{'Virus:HBEDV'}) {
	md_syslog('err', "H+BEDV not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run antivir
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:HBEDV'} . " --allfiles -z -rs ./Work 2>&1", "!Virus!|>>>|VIRUS:|ALERT:");
    return (wantarray ? interpret_hbedv_code($code) : $code);
}

sub interpret_hbedv_code {
    # Based on info from Nels Lindquist, updated by
    # Thorsten Schlichting
    my($code) = @_;

    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # Virus or virus in memory
    if ($code == 1 || $code == 2 || $code == 3) {
	$VirusName = $1 if ($CurrentVirusScannerMessage =~ m/ALERT: \[(\S+)/ or
			    $CurrentVirusScannerMessage =~ /!Virus! \S+ (\S+)/ or
			    $CurrentVirusScannerMessage =~ m/VIRUS: file contains code of the virus '(\S+)'/);
	$VirusName = "unknown-HBEDV-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # All other codes should not happen
    md_syslog('err', "Unknown HBEDV Virus scanner return code: $code");
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_vexira
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by Vexira; 0 otherwise.
# %DESCRIPTION:
#  Runs the Vexira program on the entity. (http://www.centralcommand.com)
#***********************************************************************
sub entity_contains_virus_vexira {

    unless($Features{'Virus:VEXIRA'}) {
	md_syslog('err', "Vexira not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;
    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run vexira
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:VEXIRA'} . " -qqq --log=/dev/null --all-files -as $path 2>&1", ": (virus|iworm|macro|mutant|sequence|trojan) ");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_vexira_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_vexira
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the Vexira program on the working directory
#***********************************************************************
sub message_contains_virus_vexira {

    unless($Features{'Virus:VEXIRA'}) {
	md_syslog('err', "Vexira not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run vexira
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:VEXIRA'} . " -qqq --log=/dev/null --all-files -as ./Work 2>&1", ": (virus|iworm|macro|mutant|sequence|trojan) ");
    return (wantarray ? interpret_vexira_code($code) : $code);
}

sub interpret_vexira_code {
    # http://www.centralcommand.com/ts/dl/pdf/scanner_en_vexira.pdf
    my($code) = @_;

    # OK or new file type we don't understand
    return ($code, 'ok', 'ok') if ($code == 0 or $code == 9);

    # Password-protected ZIP or corrupted file
    if ($code == 3 or $code == 5) {
	$VirusName = 'vexira-password-protected-zip';
	return ($code, 'suspicious', 'quarantine');
    }

    # Virus
    if ($code == 1 or $code == 2) {
	$VirusName = $2 if ($CurrentVirusScannerMessage =~ m/: (virus|iworm|macro|mutant|sequence|trojan) (\S+)/);
	$VirusName = "unknown-Vexira-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # All other codes should not happen
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_sophos
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by Sophos Sweep
# %DESCRIPTION:
#  Runs the Sophos Sweep program on the entity.
#***********************************************************************
sub entity_contains_virus_sophos {

    unless($Features{'Virus:SOPHOS'}) {
	md_syslog('err', "Sophos Sweep not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;
    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run antivir
    my($code, $category, $action) = run_virus_scanner($Features{'Virus:SOPHOS'} . " -f -mime -all -archive -ss $path 2>&1", "(>>> Virus)|(Password)|(Could not check)");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_sweep_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_savscan
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by Sophos Savscan
# %DESCRIPTION:
#  Runs the Sophos Savscan program on the entity.
#***********************************************************************
sub entity_contains_virus_savscan {

    unless($Features{'Virus:SAVSCAN'}) {
	md_syslog('err', "Sophos Savscan not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;
    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run antivir
    my($code, $category, $action) = run_virus_scanner($Features{'Virus:SAVSCAN'} . " -f -mime -all -cab -oe -tnef -archive -ss $path 2>&1", "(>>> Virus)|(Password)|(Could not check)");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_savscan_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_sophos
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the Sophos Sweep program on the working directory
#***********************************************************************
sub message_contains_virus_sophos {

    unless($Features{'Virus:SOPHOS'}) {
	md_syslog('err', "Sophos Sweep not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run antivir
    my($code, $category, $action) = run_virus_scanner($Features{'Virus:SOPHOS'} . " -f -mime -all -archive -ss ./Work 2>&1", "(>>> Virus)|(Password)|(Could not check)");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_sweep_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_savscan
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the Sophos Savscan program on the working directory
#***********************************************************************
sub message_contains_virus_savscan {

    unless($Features{'Virus:SAVSCAN'}) {
	md_syslog('err', "Sophos Savscan not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run antivir
    my($code, $category, $action) = run_virus_scanner($Features{'Virus:SAVSCAN'} . " -f -mime -all -cab -oe -tnef -archive -ss ./Work 2>&1", "(>>> Virus)|(Password)|(Could not check)");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_savscan_code($code) : $code);
}

sub interpret_sweep_code {
    # Based on info from Nicholas Brealey
    my($code) = @_;

    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # Interrupted
    return ($code, 'interrupted', 'tempfail') if ($code == 1);

    # This is technically an error code, but Sophos chokes
    # on a lot of M$ docs with this code, so we let it through...
    return (0, 'ok', 'ok') if ($code == 2);

    # Virus
    if ($code == 3) {
	$VirusName = $1
	    if ($CurrentVirusScannerMessage =~ m/^\s*>>> Virus '(\S+)'/);
	$VirusName = "unknown-Sweep-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # Unknown code
    return ($code, 'swerr', 'tempfail');
}

sub interpret_savscan_code {
    # Based on info from Nicholas Brealey
    my($code) = @_;

    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # Interrupted
    return ($code, 'interrupted', 'tempfail') if ($code == 1);

    # This is technically an error code, but Sophos chokes
    # on a lot of M$ docs with this code, so we let it through...
    return (0, 'ok', 'ok') if ($code == 2);

    # Virus
    if ($code == 3) {
	$VirusName = $1
	    if ($CurrentVirusScannerMessage =~ m/^\s*>>> Virus '(\S+)'/);
	$VirusName = "unknown-Savscan-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # Unknown code
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_clamav
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by clamav
# %DESCRIPTION:
#  Runs the clamav program on the entity.
#***********************************************************************
sub entity_contains_virus_clamav {
    unless ($Features{'Virus:CLAMAV'}) {
	md_syslog('err', "clamav not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;

    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run clamscan
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:CLAMAV'} . " --stdout --no-summary --infected $path 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_clamav_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_clamav
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the clamscan program on the working directory
#***********************************************************************
sub message_contains_virus_clamav {
    unless ($Features{'Virus:CLAMAV'}) {
	md_syslog('err', "clamav not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run clamscan
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:CLAMAV'} . " -r --stdout --no-summary --infected ./Work 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_clamav_code($code) : $code);
}

sub interpret_clamav_code {
    my($code) = @_;
    # From info obtained from:
    # clamscan(1)

    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # virus found
    if ($code == 1) {
	$VirusName = $1 if ($CurrentVirusScannerMessage =~ m/: (.+) FOUND/);
	$VirusName = "unknown-Clamav-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # other codes
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_avp5
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by Kaspersky 5.x
# %DESCRIPTION:
#  Runs the Kaspersky 5.x aveclient program on the entity.
#***********************************************************************
sub entity_contains_virus_avp5 {
    unless ($Features{'Virus:AVP5'}) {
	md_syslog('err', "Kaspersky aveclient not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;

    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run aveclient
    my($code, $category, $action) = run_virus_scanner($Features{'Virus:AVP5'} . " -s -p /var/run/aveserver $path 2>&1","INFECTED");

    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_avp5_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_avp5
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the Kaspersky 5.x aveclient program on the working directory
#***********************************************************************
sub message_contains_virus_avp5 {
    unless ($Features{'Virus:AVP5'}) {
	md_syslog('err', "Kaspersky aveclient not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run aveclient
    my($code, $category, $action) = run_virus_scanner($Features{'Virus:AVP5'} . " -s -p /var/run/aveserver $CWD/Work/* 2>&1","INFECTED");

    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_avp5_code($code) : $code);
}

sub interpret_avp5_code {
    my($code) = @_;
    # From info obtained from:
    # man aveclient (/opt/kav/man/aveclient.8)

    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # Scan incomplete
    return ($code, 'interrupted', 'tempfail') if ($code == 1);

    # "modified or damaged virus" = 2; virus = 4
    if ($code == 2 or $code == 4) {
	$VirusName = $1
	    if ($CurrentVirusScannerMessage =~ m/INFECTED (\S+)/);
	$VirusName = "unknown-AVP5-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # "suspicious" object found
    if ($code == 3) {
	$VirusName = 'suspicious';
	return ($code, 'suspicious', 'quarantine');
    }

    # Disinfected ??
    return ($code, 'ok', 'ok') if ($code == 5);

    # Viruses deleted ??
    return ($code, 'ok', 'ok') if ($code == 6);

    # AVPLinux corrupt or infected
    return ($code, 'swerr', 'tempfail') if ($code == 7);

    # Corrupt objects found -- treat as suspicious
    if ($code == 8) {
	$VirusName = 'suspicious';
	return ($code, 'suspicious', 'quarantine');
    }

    # Anything else shouldn't happen
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_kavscanner
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by Kaspersky kavscanner
# %DESCRIPTION:
#  Runs the Kaspersky kavscanner program on the entity.
#***********************************************************************
sub entity_contains_virus_kavscanner {
    unless ($Features{'Virus:KAVSCANNER'}) {
	md_syslog('err', "Kaspersky kavscanner not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;

    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run kavscanner
    my($code, $category, $action) = run_virus_scanner($Features{'Virus:KAVSCANNER'} . " -e PASBME -o syslog -i0 $path 2>&1",
						      "INFECTED");

    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_kavscanner_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_kavscanner
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the Kaspersky 5.x aveclient program on the working directory
#***********************************************************************
sub message_contains_virus_kavscanner {
    unless ($Features{'Virus:KAVSCANNER'}) {
	md_syslog('err', "Kaspersky aveclient not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run kavscanner
    my($code, $category, $action) = run_virus_scanner($Features{'Virus:KAVSCANNER'} . " -e PASBME -o syslog -i0 $CWD/Work/* 2>&1",
						      "INFECTED");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_kavscanner_code($code) : $code);
}

sub interpret_kavscanner_code {
    my($code) = @_;
    # From info obtained from:
    # man kavscanner (/opt/kav/man/kavscanner.8)

    # OK
    return ($code, 'ok', 'ok') if ($code == 0 or $code == 5 or $code == 10);

    # Password-protected ZIP
    if ($code == 9) {
	    $VirusName = 'kavscanner-password-protected-zip';
	    return ($code, 'suspicious', 'quarantine');
    }

    # Virus or suspicious TODO: Set virus name
    if ($code == 20 or $code == 21 or $code == 25) {
	$VirusName = $1
	    if ($CurrentVirusScannerMessage =~ m/INFECTED (\S+)/);
	$VirusName = 'unknown-kavscanner-virus' if $VirusName eq "";
	if ($code == 20) {
	    return ($code, 'suspicious', 'quarantine');
	} else {
	    return ($code, 'virus', 'quarantine');
	}
    }

    # Something else
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_avp
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by AVP AvpLinux
# %DESCRIPTION:
#  Runs the AvpLinux program on the entity.
#***********************************************************************
sub entity_contains_virus_avp {

    unless ($Features{'Virus:AVP'}) {
	md_syslog('err', "AVP AvpLinux not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($is_daemon);
    $is_daemon = ($Features{'Virus:AVP'} =~ /kavdaemon$/);
    my($entity) = @_;
    my($body) = $entity->bodyhandle;

    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run antivir
    my($code, $category, $action);
    if ($is_daemon) {
	# If path is not absolute, add cwd
	if (! ($path =~ m+^/+)) {
	    $path = $CWD . "/" . $path;
	}
	($code, $category, $action) =
	    run_virus_scanner($Features{'Virus:AVP'} . " $CWD -o{$path} -dl -Y -O- -K -I0 -WU=$CWD/DAEMON.RPT 2>&1", "infected");
    } else {
	($code, $category, $action) =
	    run_virus_scanner($Features{'Virus:AVP'} . " -Y -O- -K -I0 $path 2>&1", "infected");
    }
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_avp_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_avp
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the AVP AvpLinux program on the working directory
#***********************************************************************
sub message_contains_virus_avp {

    unless ($Features{'Virus:AVP'}) {
	md_syslog('err', "AVP AvpLinux not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($is_daemon);
    $is_daemon = ($Features{'Virus:AVP'} =~ /kavdaemon$/);

    # Run antivir
    my($code, $category, $action);
    if ($is_daemon) {
	($code, $category, $action) =
	    run_virus_scanner($Features{'Virus:AVP'} . " $CWD -o{$CWD/Work} -dl -Y -O- -K -I0 -WU=$CWD/DAEMON.RPT 2>&1", "infected");
    } else {
	($code, $category, $action) =
	    run_virus_scanner($Features{'Virus:AVP'} . " -Y -O- -K -I0 ./Work 2>&1", "infected");
    }
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_avp_code($code) : $code);
}

sub interpret_avp_code {
    my($code) = @_;
    # From info obtained from:
    # http://sm.msk.ru/patches/violet-avp-sendmail-11.4.patch
    # and from Steve Ladendorf

    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # Scan incomplete
    return ($code, 'interrupted', 'tempfail') if ($code == 1);

    # "modified or damaged virus" = 2; virus = 4
    if ($code == 2 or $code == 4) {
	$VirusName = $1
	    if ($CurrentVirusScannerMessage =~ m/infected\: (\S+)/);
	$VirusName = "unknown-AVP-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # "suspicious" object found
    if ($code == 3) {
	$VirusName = 'suspicious';
	return ($code, 'suspicious', 'quarantine');
    }

    # Disinfected ??
    return ($code, 'ok', 'ok') if ($code == 5);

    # Viruses deleted ??
    return ($code, 'ok', 'ok') if ($code == 6);

    # AVPLinux corrupt or infected
    return ($code, 'swerr', 'tempfail') if ($code == 7);

    # Corrupt objects found -- treat as suspicious
    if ($code == 8) {
	$VirusName = 'suspicious';
	return ($code, 'suspicious', 'quarantine');
    }

    # Anything else shouldn't happen
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_fprot
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by FRISK F-Prot; 0 otherwise.
# %DESCRIPTION:
#  Runs the F-PROT program on the entity. (http://www.f-prot.com)
#***********************************************************************
sub entity_contains_virus_fprot {
    unless ($Features{'Virus:FPROT'}) {
	md_syslog('err', "F-RISK FPROT not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;

    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run f-prot
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:FPROT'} . " -DUMB -ARCHIVE -PACKED $path 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }

    # f-prot return codes
    return (wantarray ? interpret_fprot_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_fprot
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the F-RISK f-prot program on the working directory
#***********************************************************************
sub message_contains_virus_fprot {
    unless ($Features{'Virus:FPROT'}) {
	md_syslog('err', "F-RISK f-prot not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run f-prot
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:FPROT'} . " -DUMB -ARCHIVE -PACKED ./Work 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    # f-prot return codes
    return (wantarray ? interpret_fprot_code($code) : $code);
}

sub interpret_fprot_code {
    # Info from
    my($code) = @_;
    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # Unrecoverable error (Missing DAT, etc)
    return ($code, 'swerr', 'tempfail') if ($code == 1);

    # Driver integrity check failed
    return ($code, 'swerr', 'tempfail') if ($code == 2);

    # Virus found
    if ($code == 3) {
	$VirusName = $1
	    if ($CurrentVirusScannerMessage =~ m/Infection\: (\S+)/);
	$VirusName = "unknown-FPROT-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # Reserved for now. Treat as an error
    return ($code, 'swerr', 'tempfail') if ($code == 4);

    # Abnormal termination (scan didn't finish)
    return ($code, 'swerr', 'tempfail') if ($code == 5);

    # At least one virus removed - Should not happen as we aren't
    # requesting disinfection ( at least in this version).
    return ($code, 'swerr', 'tempfail') if ($code == 6);

    # Memory error
    return ($code, 'swerr', 'tempfail') if ($code == 7);

    # Something suspicious was found, but not recognized virus
    # ( uncomment the one your paranoia dictates :) ).
#    return ($code, 'virus', 'quarantine') if ($code == 8);
    return ($code, 'ok', 'ok') if ($code == 8);

    # Unknown exit code
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_fpscan
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by FRISK F-Prot; 0 otherwise.
# %DESCRIPTION:
#  Runs the F-PROT program on the entity. (http://www.f-prot.com)
#***********************************************************************
sub entity_contains_virus_fpscan {
    unless ($Features{'Virus:FPSCAN'}) {
        md_syslog('err', "F-RISK fpscan not installed on this system");
        return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;

    if (!defined($body)) {
        return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
        return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run f-prot
    my($code, $category, $action) =
        run_virus_scanner($Features{'Virus:FPSCAN'} . " --report --archive=5  --scanlevel=4 --heurlevel=3 $path 2>&1");
    if ($action ne 'proceed') {
        return (wantarray ? ($code, $category, $action) : $code);
    }

    # f-prot return codes
    return (wantarray ? interpret_fpscan_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_fpscan
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the F-RISK f-prot program on the working directory
#***********************************************************************
sub message_contains_virus_fpscan {
    unless ($Features{'Virus:FPSCAN'}) {
        md_syslog('err', "F-RISK fpscan not installed on this system");
        return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run f-prot
    my($code, $category, $action) =
        run_virus_scanner($Features{'Virus:FPSCAN'} . " --report --archive=5  --scanlevel=4 --heurlevel=3 ./Work 2>&1");
    if ($action ne 'proceed') {
        return (wantarray ? ($code, $category, $action) : $code);
    }
    # f-prot return codes
    return (wantarray ? interpret_fpscan_code($code) : $code);
}

sub interpret_fpscan_code {
    # Info from
    my($code) = @_;

    # Set to 1 to mark heuristic matches as a virus
    my $heuristic_virus = 0;
    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # bit 1 (1)   ==> At least one virus-infected object was found (and
    #                 remains).
    if ($code & 0b1) {
        $VirusName = $1
            if ($CurrentVirusScannerMessage =~ m/^\[Found\s+[^\]]*\]\s+<([^ \t\(>]*)/m);
        $VirusName = "unknown-FPSCAN-virus" if $VirusName eq "";
        return ($code, 'virus', 'quarantine');
    }

    if ($heuristic_virus and $code & 0b10) {
        return ($code, 'virus', 'quarantine');
    }

    # bit 3 (4)   ==> Interrupted by user (SIGINT, SIGBREAK).
    if ($code & 0b100) {
        return ($code, 'swerr', 'tempfail');
    }

    # bit 4 (8)   ==> Scan restriction caused scan to skip files
    #                 (maxdepth directories, maxdepth archives,
    #                 exclusion list, etc).

    if ($code & 0b1000) {
        return ($code, 'swerr', 'tempfail');
    }
    # bit 5 (16)  ==> Platform error (out of memory, real I/O errors,
    #                 insufficient file permission etc.)

    if ($code & 0b10000) {
        return ($code, 'swerr', 'tempfail');
    }

    # bit 6 (32)  ==> Internal engine error (whatever the engine fails
    #                 at)
    if ($code & 0b100000) {
        return ($code, 'swerr', 'tempfail');
    }

    # bit 7 (64)  ==> At least one object was not scanned (encrypted
    #                 file, unsupported/unknown compression method,
    #                 corrupted or invalid file).
    if ($code & 0b1000000) {
        return ($code, 'swerr', 'tempfail');
    }

    # bit 8 (128) ==> At least one object was disinfected (clean now).
    # Should not happen as we aren't requesting disinfection ( at least
    # in this version).
    if ($code & 0b10000000) {
        return ($code, 'swerr', 'tempfail');
    }

    # bit 2 (2)   ==> At least one suspicious (heuristic match) object
    #                 was found (and remains).
    if ($code & 0b10) {
    # ( uncomment the one your paranoia dictates :) ).
        return ($code, 'ok', 'ok');
    }

    # Unknown exit code, this should never happen
    return ($code, 'swerr', 'tempfail');
}


#***********************************************************************
# %PROCEDURE: entity_contains_virus_trend
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by Trend Micro vscan
# %DESCRIPTION:
#  Runs the vscan program on the entity.
#***********************************************************************
sub entity_contains_virus_trend {
    unless ($Features{'Virus:TREND'}) {
	md_syslog('err', "TREND vscan not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = @_;
    my($body) = $entity->bodyhandle;

    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run antivir
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:TREND'} . " -za -a $path 2>&1", "Found ");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_trend_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_trend
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the Trend vscan program on the working directory
#***********************************************************************
sub message_contains_virus_trend {
    unless ($Features{'Virus:TREND'}) {
	md_syslog('err', "TREND Filescanner or Interscan  not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run vscan
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:TREND'} . " -za -a ./Work/* 2>&1", "Found ");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_trend_code($code) : $code);
}

sub interpret_trend_code {
    my($code) = @_;
    # From info obtained from:
    # http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/amavis/amavis/README.scanners

    # OK
    return ($code, 'ok', 'ok') if ($code == 0);

    # virus found
    if ($code >= 1 and $code < 10) {
	$VirusName = $1
	    if ($CurrentVirusScannerMessage =~ m/^\*+ Found virus (\S+)/);
	$VirusName = "unknown-Trend-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # Anything else shouldn't happen
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_nvcc
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by Norman Virus Control(NVCC)
# %DESCRIPTION:
#  Runs the NVCC Anti-Virus program. (http://www.norman.no/)
#***********************************************************************
sub entity_contains_virus_nvcc {

    unless($Features{'Virus:NVCC'}) {
	md_syslog('err', "Norman Virus Control (NVCC) not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    my($entity) = shift;
    my($body) = $entity->bodyhandle;

    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Run nvcc
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:NVCC'} . " -u -c $path 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }

    # nvcc return codes
    return (wantarray ? interpret_nvcc_code($code) : ($code==1 || $code==2));
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_nvcc
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs the NVCC Anti-Virus program on the working directory.
#  (http://www.norman.no/)
#***********************************************************************
sub message_contains_virus_nvcc {

    unless($Features{'Virus:NVCC'}) {
	md_syslog('err', "Norman Virus Control (NVCC) not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run nvcc
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:NVCC'} . " -u -c -s ./Work 2>&1");

    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    # nvcc return codes
    return (wantarray ? interpret_nvcc_code($code) : ($code==1 || $code==2));
}

sub interpret_nvcc_code {

    my($code) = shift;

    # OK
    return (0, 'ok', 'ok') if ($code == 0);

    # Found a virus
    if ($code == 1 or $code == 2 or $code == 14) {
	$VirusName = $1
	    if ($CurrentVirusScannerMessage =~ m/Possible virus[^']*'(\S+)'$/);
        #' Emacs highlighting goes nuts with unbalanced single-quote...
	$VirusName = "unknown-NVCC-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }

    # Corrupt files/archives found -- treat as suspicious
    if ($code == 11) {
	$VirusName = 'NVCC-suspicious-code-11';
        return ($code, 'suspicious', 'quarantine');
    }

    # No scan area given or something went wrong
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_sophie
# %ARGUMENTS:
#  entity -- a MIME entity
#  sophie_sock (optional) -- Sophie socket path
# %RETURNS:
#  1 if entity contains a virus as reported by Sophie
# %DESCRIPTION:
#  Invokes the Sophie daemon (http://www.vanja.com/tools/sophie/)
#  on the entity.
#***********************************************************************
sub entity_contains_virus_sophie {
    my ($entity) = shift;
    my ($sophie_sock) = $SophieSock;
    $sophie_sock = shift if (@_ > 0);
    $sophie_sock = '/var/spool/MIMEDefang/sophie' if (!defined($sophie_sock));
    if (!defined($entity->bodyhandle)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    if (!defined($entity->bodyhandle->path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }
    my $sock = IO::Socket::UNIX->new(Peer => $sophie_sock);
    if (defined $sock) {
	my $path = $entity->bodyhandle->path;
	# If path is not absolute, add cwd
	if (! ($path =~ m+^/+)) {
	    $path = $CWD . "/" . $path;
	}
	if (!$sock->print("$path\n")) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	if (!$sock->flush) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	my($output);
	if (!$sock->sysread($output,256)) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	if (!$sock->close) {
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	if ($output =~ /^0/) { return (wantarray ? (0, 'ok', 'ok') : 0); }
	elsif ($output =~ /^1/) {
	    $VirusName = "Unknown-sophie-virus";
	    $VirusName = $1 if $output =~ /^1:(.*)$/;
	    $VirusScannerMessages .= "Sophie found the $VirusName virus.\n";
	    return (wantarray ? (1, 'virus', 'quarantine') : 1);
	}
	elsif ($output =~ /^-1/) {
	    my $errmsg = "unknown status";
	    $errmsg = "$1" if $output =~ /^-1:(.*)$/;
	    md_syslog('err', "entity_contains_virus_sophie: $errmsg ($path)");
	    $VirusScannerMessages .= "Sophie error: $errmsg\n";
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	else {
	    md_syslog('err', "entity_contains_virus_sophie: unknown response - $output ($path)");
	    $VirusScannerMessages .= "Sophie error: unknown response - $output\n";
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
    }
    # Could not connect to daemon
    md_syslog('err', "Could not connect to Sophie Daemon at $sophie_sock");
    return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_sophie
# %ARGUMENTS:
#  sophie_sock (optional) -- Sophie socket path
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Invokes the Sophie daemon (http://www.vanja.com/tools/sophie/)
#  on the entire message.
#***********************************************************************
sub message_contains_virus_sophie {
    my ($sophie_sock) = $SophieSock;
    $sophie_sock = shift if (@_ > 0);
    $sophie_sock = '/var/spool/MIMEDefang/sophie' if (!defined($sophie_sock));
    my $sock = IO::Socket::UNIX->new(Peer => $sophie_sock);
    if (defined $sock) {
	if (!$sock->print("$CWD/Work\n")) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	if (!$sock->flush) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	my($output, $ans);
	$ans = $sock->sysread($output, 256);
	if (!defined($ans)) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	if (!$sock->close) {
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	if ($output =~ /^0/) { return (wantarray ? (0, 'ok', 'ok') : 0); }
	elsif ($output =~ /^1/) {
	    $VirusName = "Unknown-sophie-virus";
	    $VirusName = $1 if $output =~ /^1:(.*)$/;
	    $VirusScannerMessages .= "Sophie found the $VirusName virus.\n";
	    return (wantarray ? (1, 'virus', 'quarantine') : 1);
	}
	elsif ($output =~ /^-1/) {
	    my $errmsg = "unknown status";
	    $errmsg = "$1" if $output =~ /^-1:(.*)$/;
	    md_syslog('err', "message_contains_virus_sophie: $errmsg ($CWD/Work)");
	    $VirusScannerMessages .= "Sophie error: $errmsg\n";
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	else {
	    md_syslog('err', "message_contains_virus_sophie: unknown response - $output ($CWD/Work)");
	    $VirusScannerMessages .= "Sophie error: unknown response - $output\n";
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
    }
    # Could not connect to daemon
    md_syslog('err', "Could not connect to Sophie Daemon at $sophie_sock");
    return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_clamd
# %ARGUMENTS:
#  entity -- a MIME entity
#  clamd_sock (optional) -- clamd socket path
# %RETURNS:
#  1 if entity contains a virus as reported by clamd
# %DESCRIPTION:
#  Invokes the clamd daemon (http://www.clamav.net/)
#  on the entity.
#***********************************************************************
sub entity_contains_virus_clamd {
    my ($entity) = shift;
    my ($clamd_sock) = $ClamdSock;
    $clamd_sock = shift if (@_ > 0);
    $clamd_sock = '/var/spool/MIMEDefang/clamd.sock' if (!defined($clamd_sock));
    if (!defined($entity->bodyhandle)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    if (!defined($entity->bodyhandle->path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }
    my $sock = IO::Socket::UNIX->new(Peer => $clamd_sock);
    if (defined $sock) {
	my $path = $entity->bodyhandle->path;
	# If path is not absolute, add cwd
	if (! ($path =~ m+^/+)) {
	    $path = $CWD . "/" . $path;
	}
	if (!$sock->print("SCAN $path\n")) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	if (!$sock->flush) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	my($output, $ans);
	$ans = $sock->sysread($output,256);
	$sock->close;
	if (!defined($ans) || !$ans) {
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	if ($output =~ /: (.+) FOUND/) {
	    $VirusScannerMessages .= "clamd found the $1 virus.\n";
	    $VirusName = $1;
	    return (wantarray ? (1, 'virus', 'quarantine') : 1);
	} elsif ($output =~ /: (.+) ERROR/) {
	    my $err_detail = $1;
	    md_syslog('err', "Clamd returned error: $err_detail");
	    # If it's a zip module failure, try falling back on clamscan.
	    # This is despicable, but it might work
	    if ($err_detail =~ /(?:zip module failure|not supported data format)/i &&
		$Features{'Virus:CLAMAV'}) {
		my ($code, $category, $action) =
		run_virus_scanner($Features{'Virus:CLAMAV'} . " -r --unzip --unrar --stdout --no-summary --infected $CWD/Work 2>&1");
		if ($action ne 'proceed') {
			return (wantarray ? ($code, $category, $action) : $code);
		}
		md_syslog('info', "Falling back on clamscan --unzip --unrar because of Zip module failure in clamd");
		return (wantarray ? interpret_clamav_code($code) : $code);
	    }
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    # Could not connect to daemon
    md_syslog('err', "Could not connect to clamd Daemon at $clamd_sock");
    return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_clamd
# %ARGUMENTS:
#  clamd_sock (optional) -- clamd socket path
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Invokes the clamd daemon (http://www.clamav.net/)
#  on the entire message.
#***********************************************************************
sub message_contains_virus_clamd {
    my ($clamd_sock) = $ClamdSock;
    $clamd_sock = shift if (@_ > 0);
    $clamd_sock = '/var/spool/MIMEDefang/clamd.sock' if (!defined($clamd_sock));
    my ($output,$sock);

    # PING/PONG test to make sure clamd is alive
    $sock = IO::Socket::UNIX->new(Peer => $clamd_sock);

    if (!defined($sock)) {
	md_syslog('err', "Could not connect to clamd daemon at $clamd_sock");
	return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
    }

    my $s = IO::Select->new();
    $s->add($sock);
    if (!$s->can_write(30)) {
	$sock->close;
	md_syslog('err', "Timeout writing to clamd daemon at $clamd_sock");
	return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
    }

    $sock->print("PING");
    $sock->flush;

    if (!$s->can_read(60)) {
	$sock->close;
	md_syslog('err', "Timeout reading from clamd daemon at $clamd_sock");
	return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
    }

    # Free up memory used by IO::Select object
    undef $s;

    $sock->sysread($output,256);
    $sock->close;
    chomp($output);
    if (! defined($output) || $output ne "PONG") {
	md_syslog('err', "clamd is not responding");
	return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
    }

    # open up a socket and scan each file in ./Work
    $sock = IO::Socket::UNIX->new(Peer => $clamd_sock);
    if (defined $sock) {
	if (!$sock->print("SCAN $CWD/Work\n")) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 999);
	}
	if (!$sock->flush) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 999);
	}
	my $ans;
	$ans = $sock->sysread($output,256);
	$sock->close;
	if (!defined($ans) || !$ans) {
	    return (wantarray ? (999, 'swerr', 'tempfail') : 999);
	}
	if ($output =~ /: (.+) FOUND/) {
	    $VirusScannerMessages .= "clamd found the $1 virus.\n";
	    $VirusName = $1;
	    return (wantarray ? (1, 'virus', 'quarantine') : 1);
	} elsif ($output =~ /: (.+) ERROR/) {
	    my $err_detail = $1;
	    md_syslog('err', "Clamd returned error: $err_detail");
	    # If it's a zip module failure, try falling back on clamscan.
	    # This is despicable, but it might work
	    if ($err_detail =~ /(?:zip module failure|not supported data format)/i &&
		$Features{'Virus:CLAMAV'}) {
		my ($code, $category, $action) =
		    run_virus_scanner($Features{'Virus:CLAMAV'} . " -r --unzip --unrar --stdout --no-summary --infected $CWD/Work 2>&1");
		if ($action ne 'proceed') {
			return (wantarray ? ($code, $category, $action) : $code);
		}
		md_syslog('info', "Falling back on clamscan --unzip --unrar because of Zip module failure in clamd");
		return (wantarray ? interpret_clamav_code($code) : $code);
	    }
	    return (wantarray ? (999, 'swerr', 'tempfail') : 999);
	}
    }
    else {
	# Could not connect to daemon
	md_syslog('err', "Could not connect to clamd daemon at $clamd_sock");
	return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
    }
    # No errors, no infected files were found
    return (wantarray ? (0, 'ok', 'ok') : 0);
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_trophie
# %ARGUMENTS:
#  entity -- a MIME entity
#  trophie_sock (optional) -- Trophie socket path
# %RETURNS:
#  1 if entity contains a virus as reported by Trophie
# %DESCRIPTION:
#  Invokes the Trophie daemon (http://www.vanja.com/tools/trophie/)
#  on the entity.
#***********************************************************************
sub entity_contains_virus_trophie {
    my ($entity) = shift;
    my ($trophie_sock) = $TrophieSock;
    $trophie_sock = shift if (@_ > 0);
    $trophie_sock = '/var/spool/MIMEDefang/trophie' if (!defined($trophie_sock));
    if (!defined($entity->bodyhandle)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    if (!defined($entity->bodyhandle->path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }
    my $sock = IO::Socket::UNIX->new(Peer => $trophie_sock);
    if (defined $sock) {
	my $path = $entity->bodyhandle->path;
	# If path is not absolute, add cwd
	if (! ($path =~ m+^/+)) {
	    $path = $CWD . "/" . $path;
	}
	if (!$sock->print("$path\n")) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 999);
	}
	if (!$sock->flush) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 999);
	}
	my($output);
	$sock->sysread($output, 256);
	$sock->close;
	if ($output =~ /^1:(.*)$/) {
	    $VirusScannerMessages .= "Trophie found the $1 virus.\n";
	    $VirusName = $1;
	    return (wantarray ? (1, 'virus', 'quarantine') : 1);
	}
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    # Could not connect to daemon
    md_syslog('err', "Could not connect to Trophie Daemon at $trophie_sock");
    return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_trophie
# %ARGUMENTS:
#  trophie_sock (optional) -- Trophie socket path
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Invokes the Trophie daemon (http://www.vanja.com/tools/trophie/)
#  on the entire message.
#***********************************************************************
sub message_contains_virus_trophie {
    my ($trophie_sock) = $TrophieSock;
    $trophie_sock = shift if (@_ > 0);
    $trophie_sock = '/var/spool/MIMEDefang/trophie' if (!defined($trophie_sock));
    my $sock = IO::Socket::UNIX->new(Peer => $trophie_sock);
    if (defined $sock) {
	if (!$sock->print("$CWD/Work\n")) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 999);
	}
	if (!$sock->flush) {
	    $sock->close;
	    return (wantarray ? (999, 'swerr', 'tempfail') : 999);
	}
	my($output);
	$sock->sysread($output, 256);
	$sock->close;
	if ($output =~ /^1:(.*)$/) {
	    $VirusScannerMessages .= "Trophie found the $1 virus.\n";
	    $VirusName = $1;
	    return (wantarray ? (1, 'virus', 'quarantine') : 1);
	}
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    # Could not connect to daemon
    md_syslog('err', "Could not connect to Trophie Daemon at $trophie_sock");
    return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_nod32
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by NOD32; 0 otherwise.
# %DESCRIPTION:
#  Runs Eset NOD32 program on the entity. (http://www.eset.com)
#***********************************************************************
sub entity_contains_virus_nod32 {
    unless($Features{'Virus:NOD32'}) {
	md_syslog('err', "NOD32 not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }
    my($entity) = @_;
    my($body) = $entity->bodyhandle;
    if (!defined($body)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    # Get filename
    my($path) = $body->path;
    if (!defined($path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }
    # Run NOD32
    my($code, $category, $action) = run_virus_scanner($Features{'Virus:NOD32'} . " --subdir $path 2>&1", "virus=\"([^\"]+)\"");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_nod32_code($code) : $code);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_nod32
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 or 2  if any file in the working directory contains a virus
# %DESCRIPTION:
#  Runs Eset NOD32 program on the working directory
#***********************************************************************
sub message_contains_virus_nod32 {
    unless($Features{'Virus:NOD32'}) {
	md_syslog('err', "NOD32 not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }
    # Run NOD32
    my($code, $category, $action) = run_virus_scanner($Features{'Virus:NOD32'} . " --subdir ./Work 2>&1", "virus=\"([^\"]+)\"");
    return (wantarray ? interpret_nod32_code($code) : $code);
}

sub interpret_nod32_code {
    my($code) = @_;
    # OK
    return ($code, 'ok', 'ok') if ($code == 0);
    # 1 or 2 -- virus found
    if ($code == 1 || $code == 2) {
	$VirusName = $1 if ($CurrentVirusScannerMessage =~ m/virus=\"([^"]*)/);
	$VirusName = "unknown-NOD32-virus" if $VirusName eq "";
	return ($code, 'virus', 'quarantine');
    }
    # error
    return ($code, 'swerr', 'tempfail');
}

#***********************************************************************
# %PROCEDURE: run_virus_scanner
# %ARGUMENTS:
#  cmdline -- command to run
#  match -- regular expression to match (default ".*")
# %RETURNS:
#  A three-element list: (exitcode, category, recommended_action)
#  exitcode is actual exit code from scanner
#  category is either "cannot-execute" or "ok"
#  recommended_action is either "tempfail" or "proceed"
# %DESCRIPTION:
#  Runs a virus scanner, collecting output in $VirusScannerMessages
#***********************************************************************
sub run_virus_scanner {
    my($cmd, $match) = @_;
    return (999, 'wrong-context', 'tempfail')
	if (!in_message_context("run_virus_scanner"));
    my($retcode);
    my($msg) = "";
    $CurrentVirusScannerMessage = "";

    $match = ".*" unless defined($match);
    unless (open(SCANNER, "$cmd |")) {
	$msg = "Unable to execute $cmd: $!";
	md_syslog('err', "run_virus_scanner: $msg");
	$VirusScannerMessages .= "$msg\n";
	$CurrentVirusScannerMessage = $msg;
	return (999, 'cannot-execute', 'tempfail');
    }
    while(<SCANNER>) {
	$msg .= $_ if /$match/i;
    }
    close(SCANNER);
    $retcode = $? / 256;

    # Some daemons are instructed to save output in a file
    if (open(REPORT, "DAEMON.RPT")) {
	while(<REPORT>) {
	    $msg .= $_ if /$match/i;
	}
	close(REPORT);
	unlink("DAEMON.RPT");
    }

    $VirusScannerMessages .= $msg;
    $CurrentVirusScannerMessage = $msg;
    return ($retcode, 'ok', 'proceed');
}

#***********************************************************************
# %PROCEDURE: action_tempfail
# %ARGUMENTS:
#  reply -- the text reply
#  code -- SMTP reply code (eg: 451)
#  DSN -- DSN code (eg: 4.3.0)
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Tempfails the message with a 4.x.x SMTP code.  If code or DSN are
#  omitted or invalid, use 451 and 4.3.0.
#***********************************************************************
sub action_tempfail {
    my($reply, $code, $dsn) = @_;
    return 0 if (!in_message_context("action_tempfail"));
    $reply = "Try again later" unless (defined($reply) and ($reply ne ""));
    $code = 451 unless (defined($code) and $code =~ /^4\d\d$/);
    $dsn = "4.3.0" unless (defined($dsn) and $dsn =~ /^4\.\d{1,3}\.\d{1,3}$/);

    write_result_line('T', $code, $dsn, $reply);
    $Actions{'tempfail'}++;
    return 1;
}

#***********************************************************************
# %PROCEDURE: pretty_print_mail
# %ARGUMENTS:
#  e -- a MIME::Entity object
#  size -- maximum size of value to return in characters
#  chunk -- optional; used in recursive calls only.  Do not supply as arg.
#  depth -- used in recursive calls only.  Do not supply as arg.
# %RETURNS:
#  A "pretty-printed" version of the e-mail body
# %DESCRIPTION:
#  Makes a pretty-printed version of the e-mail body no longer than size
#  characters.  This odd-looking function is used by CanIt...
#***********************************************************************

sub pretty_print_mail {
    my($e, $size, $chunk, $depth) = @_;
    $chunk = "" unless defined($chunk);
    $depth = 0 unless defined($depth);

    my(@parts) = $e->parts;
    my($type) = $e->mime_type;
    my($fname) = takeStabAtFilename($e);
    $fname = "; filename=$fname" if ($fname ne "");
    my($spaces) = "  " x $depth;
    $chunk .= "\n$spaces" . "[Part: ${type}${fname}]\n\n";
    if ($#parts >= 0) {
	my($part);
	foreach $part (@parts) {
	    $chunk = pretty_print_mail($part, $size, $chunk, $depth+1);
	    last if (length($chunk) >= $size);
	}
    } else {
	return $chunk unless ($type =~ m+^text/+);
	my($body) = $e->bodyhandle;
	return $chunk unless (defined($body));
	my($path) = $body->path;
	return $chunk unless (defined($path));
	return $chunk unless (open(IN, "<$path"));
	while (<IN>) {
	    $chunk .= $_;
	    last if (length($chunk) >= $size);
	}
	close(IN);
    }
    return $chunk;
}

#***********************************************************************
# %PROCEDURE: md_version
# %ARGUMENTS:
#  None
# %RETURNS:
#  MIMEDefang version
#***********************************************************************
sub md_version {
    return '2.83';
}

#***********************************************************************
# %PROCEDURE: main
# %ARGUMENTS:
#  workdir -- directory to "chdir" to and do all work in.
#  msg -- file containing MIME message
# %RETURNS:
#  0 if parse went well; non-zero otherwise.
# %DESCRIPTION:
#  Main program.  Splits the MIME message up and then reconstructs it.
#***********************************************************************
sub main {
    my($Filter);
    my($workdir);
    $Filter = '/etc/mail/mimedefang-filter';

    $DoStatusTags = 0;

    my($ip, $name, $sender, $recip, $firstRecip, $helo, $map, $key);
    # Check for "-f filter-file" option
    if ($#ARGV >= 2) {
	if ($ARGV[0] eq "-f") {
	    $Filter = $ARGV[1];
	    shift @ARGV;
	    shift @ARGV;
	}
    }
    if ($#ARGV != 0) {
	md_syslog('warning', "Usage: mimedefang.pl [-f filter] workdir | -server | -test | -features | -validate");
	print STDERR "Usage: mimedefang.pl [-f filter] workdir | -server | -test | -features | -validate\n";
	return 1;
    }

    $ValidateIPHeader = "";
    if (open(IN, '</etc/mimedefang-ip-key')) {
	$ValidateIPHeader = <IN>;
	chomp($ValidateIPHeader);
	close(IN);
    }

    # These are set unconditionally; filter() can change them.
    $NotifySenderSubject = "MIMEDefang Notification";
    $NotifyAdministratorSubject = "MIMEDefang Notification";
    $QuarantineSubject = "MIMEDefang Quarantine Report";
    $NotifyNoPreamble = 0;

    # Load the filter
    init_globals();
    if ($ValidateIPHeader ne "" and
	$ValidateIPHeader !~ /^X-MIMEDefang-Relay/) {
	md_syslog('err', "Invalid value for mimedefang-ip-key: $ValidateIPHeader");
	$ValidateIPHeader = "";
    }

    if (! -r $Filter) {
	md_syslog('err', "Cannot read filter $Filter: Check permissions.  mimedefang.pl will not work.");
    }

    # Special-case /dev/null so we can invoke without
    # a filter for test purposes.
    unless ($Filter eq '/dev/null') {
	    require $Filter;
    }

    # In case it wasn't done in filter... won't hurt to do it again
    detect_and_load_perl_modules();

    # Backward-compatibility
    if (defined($Administrator)) {
	$AdminAddress = $Administrator;
	md_syslog('warning', 'Variable $Administrator is deprecated.  Use $AdminAddress instead');
    }

    # Defaults
    $AdminName = 'MIMEDefang Administrator' unless defined($AdminName);
    $AdminAddress = 'postmaster@localhost' unless defined($AdminAddress);
    $DaemonName = 'MIMEDefang' unless defined($DaemonName);
    $DaemonAddress = 'mailer-daemon@localhost' unless defined($DaemonAddress);
    $SALocalTestsOnly = 1 unless defined($SALocalTestsOnly);

    if (!defined($GeneralWarning)) {
	$GeneralWarning =
	    "WARNING: This e-mail has been altered by MIMEDefang.  Following this\n" .
	    "paragraph are indications of the actual changes made.  For more\n" .
	    "information about your site's MIMEDefang policy, contact\n" .
	    "$AdminName <$AdminAddress>.  For more information about MIMEDefang, see:\n\n" .
	    "            $URL\n\n";
    }

    # check dir
    $workdir = $ARGV[0];
    if ($workdir eq "-test") {
	printf("Filter $Filter seems syntactically correct.\n");
	exit(0);
    }
    if ($workdir eq "-validate") {
	if (defined(&filter_validate)) {
	    exit(filter_validate());
	}
	print STDERR "ERROR: You must define a function called filter_validate in your filter\nto use the -validate argument.\n";
	exit(1);
    }

    if ($workdir eq "-features") {
	# Print available features
	my($thing, $ans);

	# Print MIMEDefang version
	my $ver = md_version();
	print("MIMEDefang version $ver\n\n");
	# Print the features we have first
	foreach $thing (sort keys %Features) {
	    my($feat);
	    $feat = $Features{$thing};
	    $ans = $feat ? "yes" : "no";
	    if ($ans eq "yes") {
		if ($feat ne "1") {
		    printf("%-30s: %s\n", $thing,  "yes ($feat)");
		} else {
		    printf("%-30s: %s\n", $thing,  "yes");
		}
	    }
	}

	# And now print the ones we don't have
	foreach $thing (sort keys %Features) {
	    my($feat);
	    $feat = $Features{$thing};
	    $ans = $feat ? "yes" : "no";
	    if ($ans eq "no") {
		printf("%-30s: %s\n", $thing,  "no");
	    }
	}

	# And print Perl module versions
	print("\n");
	my($version);
	foreach $thing (qw(Archive::Zip Digest::SHA HTML::Parser IO::Socket IO::Stringy MIME::Base64 MIME::Tools MIME::Words Mail::Mailer Mail::SpamAssassin Net::DNS Unix::Syslog )) {
	    unless (eval "require $thing") {
		printf("%-30s: missing\n", $thing);
		next;
	    }
	    $version = $thing->VERSION();
	    $version = "UNKNOWN" unless defined($version);
	    printf("%-30s: Version %s\n", $thing, $version);
	}
	exit(0);
    }

    my $enter_main_loop;
    if ($workdir eq "-server") {
	$ServerMode = 1;
	$enter_main_loop = 1;
    } elsif ($workdir eq "-serveru") {
	$ServerMode = 1;
	$enter_main_loop = 1;
	$DoStatusTags = 1;
    } elsif ($workdir eq "-embserver") {
	$ServerMode = 1;
	$enter_main_loop = 0;
    } elsif ($workdir eq "-embserveru") {
	$ServerMode = 1;
	$DoStatusTags = 1;
	$enter_main_loop = 0;
    } else {
	$ServerMode = 0;
    }

    if (!$ServerMode) {
	chdir($Features{'Path:SPOOLDIR'});
	if (defined(&filter_initialize)) {
	    filter_initialize();
	}

	init_globals();
	do_scan($workdir);
	exit(0);
    }

    do_main_loop() if $enter_main_loop;
}

=item is_public_ip4_address $ip_addr

Returns true if $ip_addr is a publicly-routable IPv4 address, false otherwise

=cut
sub is_public_ip4_address {
	my ($addr) = @_;
	my @octets = split(/\./, $addr);

	# Sanity check: Return false if it's not an IPv4 address
	return 0 unless (scalar(@octets) == 4);
	foreach my $octet (@octets) {
		return 0 if ($octet !~ /^\d+$/);
		return 0 if ($octet > 255);
	}

	# 10.0.0.0 to 10.255.255.255
	return 0 if ($octets[0] == 10);

	# 172.16.0.0 to 172.31.255.255
	return 0 if ($octets[0] == 172 && $octets[1] >= 16 && $octets[1] <= 31);

	# 192.168.0.0 to 192.168.255.255
	return 0 if ($octets[0] == 192 && $octets[1] == 168);

	# Loopback
	return 0 if ($octets[0] == 127);

	# Local-link for auto-DHCP
	return 0 if ($octets[0] == 169 && $octets[1] == 254);

	# IPv4 multicast
	return 0 if ($octets[0] >= 224 && $octets[0] <= 239);

	# Class E ("Don't Use")
	return 0 if ($octets[0] >= 240 && $octets[0] <= 247);

	# 0.0.0.0 and 255.255.255.255 are bogus
	return 0 if ($octets[0] == 0 &&
		     $octets[1] == 0 &&
		     $octets[2] == 0 &&
		     $octets[3] == 0);

	return 0 if ($octets[0] == 255 &&
		     $octets[1] == 255 &&
		     $octets[2] == 255 &&
		     $octets[3] == 255);
	return 1;
}

=item get_mx_ip_addresses $domain [$resolver_object]

Get IP addresses of all MX hosts for given domain.  If there are
no MX hosts, then return A records.

=cut
sub get_mx_ip_addresses {
	my($domain, $res) = @_;
	my @results;
	unless ($Features{"Net::DNS"}) {
		md_syslog('err', "Attempted to call get_mx_ip_addresses, but Perl module Net::DNS is not installed");
		return @results;
	}
	if (!defined($res)) {
		$res = Net::DNS::Resolver->new;
		$res->defnames(0);
	}

	my $packet = $res->query($domain, 'MX');
	if (!defined($packet) ||
	    $packet->header->rcode eq 'SERVFAIL' ||
	    $packet->header->rcode eq 'NXDOMAIN' ||
	    !defined($packet->answer)) {
		# No MX records; try A records
		$packet = $res->query($domain, 'A');
		if (!defined($packet) ||
		    $packet->header->rcode eq 'SERVFAIL' ||
		    $packet->header->rcode eq 'NXDOMAIN' ||
		    !defined($packet->answer)) {
			return @results;
		}
	}
	foreach my $item ($packet->answer) {
		if ($item->type eq 'MX') {

			# Weird MX record of "." or ""
			# host -t mx yahoo.com.pk for example
			if ($item->exchange eq '' ||
			    $item->exchange eq '.' ||
			    $item->exchange eq '0' ||
			    $item->exchange eq '0 ' ||
			    $item->exchange eq '0 .' ||
			    $item->exchange eq '0.') {
				push(@results, '0.0.0.0');
				next;
			}

			# If it LOOKS like an IPv4 address, don't do
			# an A lookup
			if ($item->exchange =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.?$/) {
				my ($a, $b, $c, $d) = ($1, $2, $3, $4);
				if ($a <= 255 && $b <= 255 && $c <= 255 && $d <= 255) {
					push(@results, "$a.$b.$c.$d");
					next;
				}
			}

			my $packet2 = $res->query($item->exchange, 'A');
			next unless defined($packet2);
			next if $packet2->header->rcode eq 'SERVFAIL';
			next if $packet2->header->rcode eq 'NXDOMAIN';
			next unless defined($packet2->answer);
			foreach my $item2 ($packet2->answer) {
				if ($item2->type eq 'A') {
					push(@results, $item2->address);
				}
			}
		} elsif ($item->type eq 'A') {
			push(@results, $item->address);
		}
	}
	return @results;
}

=item md_get_bogus_mx_hosts $domain

Returns a list of "bogus" IP addresses that are in $domain's list of MX
records.  A "bogus" IP address is loopback/private/multicast/etc.

=cut
#'
sub md_get_bogus_mx_hosts {
	my ($domain) = @_;
	my @bogus_hosts = ();
	my @mx = get_mx_ip_addresses($domain);
	foreach my $mx (@mx) {
		if (!is_public_ip4_address($mx)) {
			push(@bogus_hosts, $mx);
		}
	}
	return @bogus_hosts;
}

sub do_main_loop
{
	init_status_tag();

	chdir($Features{'Path:SPOOLDIR'});
	if(defined(&filter_initialize)) {
		filter_initialize();
	}

	# Infinite server loop... well, not quite infinite; we stop on EOF
	# from STDIN.
	while (my $line = <STDIN>) {
		chomp $line;

		# Clear out vars so they aren't used by filter_begin, etc.
		init_globals();

		# Change to spool dir -- ignore error
		chdir($Features{'Path:SPOOLDIR'});

		my ($cmd, @args) = map { percent_decode($_) } split(/\s+/, $line);
		$cmd = lc $cmd;

		no strict 'refs';
		my $cmd_handler = *{"handle_${cmd}"};
		use strict 'refs';
		if (defined(&{'handle_' . $cmd})) {
			no strict 'refs';
			&{'handle_' . $cmd}(@args);
			use strict 'refs';
		} else {
			unknown_command_handler( $cmd, @args );
		}
	}

	# EOF on STDIN... time to bye-bye...
	if(defined(&filter_cleanup)) {
		exit(filter_cleanup());
	}
	exit(0);
}

# This is the only command handler not named handle_XXXXX for two reasons:
#  1) We don't want someone to pass in a command named 'unknown_command' and
#     get this handler.
#  2) This handler takes $cmd as first argument, whereas the others do not get
#     their own name passed down as the first arg.
sub unknown_command_handler
{
	my ($cmd, @args) = @_;

	if(!defined(&filter_unknown_cmd)) {
		print_and_flush('error: Unknown command');
		return;
	}

	my ($code, @list) = filter_unknown_cmd($cmd, @args);
	$code = "error:" if($code ne "ok" and $code ne "error:");

	my $reply = join(' ', map { percent_encode($_) } ($code, @list) );
	print_and_flush($reply);
}

sub handle_ping
{
	print_and_flush('PONG');
}

sub handle_scan
{
	my ($dummyqid, $workdir) = @_;
	# EVIL FOLLOWS.  AVERT YOUR EYES.
	# File::Spec::Unix caches $ENV{'TMPDIR'}.
	# We want to force it to cache it BEFORE
	# we muck about with the env. variable,
	# otherwise code that uses File::Spec->tmpfile
	# will fail when our transient $workdir/tmp is
	# deleted.  Horrible.

	# FORCE File::Spec to cache a reasonable tmpfile
	File::Spec->tmpdir();

	my $old_tmpdir;
	mkdir("$workdir/tmp");
	if(-d "$workdir/tmp") {
		$old_tmpdir = $ENV{'TMPDIR'};
		$ENV{'TMPDIR'} = "$workdir/tmp";
	} else {
		$old_tmpdir = undef;
	}

	do_scan($workdir);

	# If we set TMPDIR to $workdir/tmp, reset it
	# here.
	if(exists($ENV{'TMPDIR'}) && $ENV{'TMPDIR'} eq "$workdir/tmp")
	{
		if($old_tmpdir) {
			$ENV{'TMPDIR'} = $old_tmpdir;
		} else {
			delete($ENV{'TMPDIR'});
		}
	}

	chdir($Features{'Path:SPOOLDIR'});
}

sub handle_map
{
	my ($map, $key) = @_;

	if(!defined(&filter_map)) {
		md_syslog('err', "No filter_map function defined");
		print_and_flush('PERM No filter_map function defined');
		return;
	}

	my ($code, $val) = filter_map($map, $key);
	if(         $code ne "OK"
		and $code ne "NOTFOUND"
		and $code ne "TEMP"
		and $code ne "TIMEOUT"
		and $code ne "PERM")
	{
		md_syslog('err', "Invalid code from filter_map: $code");
		print_and_flush('PERM Invalid code from filter_map: ' . percent_encode($code));
		return;
	}
	print_and_flush("$code " . percent_encode($val));
}

#***********************************************************************
# %PROCEDURE: handle_tick
# %ARGUMENTS:
#  Tick value (integer)
# %DESCRIPTION:
#  May be called periodically by multiplexor; runs filter_tick routine
#  if it exists.
# %RETURNS:
#  Nothing
#***********************************************************************
sub handle_tick
{
	my ($tick_no) = @_;
	$tick_no ||= 0;
	if(defined(&filter_tick)) {
		filter_tick($tick_no);
		print_and_flush("tock $tick_no");
	} else {
		print_and_flush("error: tick $tick_no: filter_tick undefined");
	}
}

#***********************************************************************
# %PROCEDURE: handle_relayok
# %ARGUMENTS:
#  hostip -- IP address of relay host
#  hostname -- name of relay host
#  port -- client port
#  myip -- my IP address
#  myport -- my listening port
# %RETURNS:
#  Nothing, but prints "ok 1" if we accept connection, "ok 0" if not.
#***********************************************************************
sub handle_relayok
{
	my ($hostip, $hostname, $port, $myip, $myport) = @_;
	if(!defined(&filter_relay)) {
		send_filter_answer('CONTINUE', "ok", "filter_relay", "host $hostip ($hostname)");
		return;
	}

	# Set up globals
	$RelayAddr     = $hostip;
	$RelayHostname = $hostname;
	my ($ok, $msg, $code, $dsn, $delay) = filter_relay($hostip, $hostname, $port, $myip, $myport);
	send_filter_answer($ok, $msg, "filter_relay", "host $hostip ($hostname)", $code, $dsn, $delay);
}

#***********************************************************************
# %PROCEDURE: handle_helook
# %ARGUMENTS:
#  ip -- IP address of relay host
#  name -- name of relay host
#  helo -- arg to SMTP HELO command
#  port -- client port
#  myip -- my IP address
#  myport -- my listening port
# %RETURNS:
#  Nothing, but prints "ok 1" if we accept connections from this host.
# "ok 0" if not.
#***********************************************************************
sub handle_helook
{
	my ($ip, $name, $helo, $port, $myip, $myport) = @_;
	if(!defined(&filter_helo)) {
		send_filter_answer('CONTINUE', "ok", "filter_helo", "helo $helo");
		return;
	}

	# Set up globals
	$RelayAddr     = $ip;
	$RelayHostname = $name;
	$Helo          = $helo;

	my ($ok, $msg, $code, $dsn, $delay) = filter_helo($ip, $name, $helo, $port, $myip, $myport);
	send_filter_answer($ok, $msg, "filter_helo", "helo $helo", $code, $dsn, $delay);
}

#***********************************************************************
# %PROCEDURE: handle_senderok
# %ARGUMENTS:
#  sender -- e-mail address of sender
#  ip -- IP address of relay host
#  name -- name of relay host
#  helo -- arg to SMTP HELO command
# %RETURNS:
#  Nothing, but prints "ok 1" if we accept message from this sender,
# "ok 0" if not.
#***********************************************************************
sub handle_senderok
{
	my ($sender, $ip, $name, $helo);

	($sender, $ip, $name, $helo, $CWD, $QueueID, @ESMTPArgs) = @_;

	if(!defined(&filter_sender)) {
		send_filter_answer('CONTINUE', "ok", "filter_sender", "sender $sender");
		return;
	}

	if (!chdir($CWD)) {
		send_filter_answer('TEMPFAIL', "could not chdir($CWD): $!", "filter_sender", "sender $sender");
	}

	# Set up additional globals
	$MsgID         = $QueueID;
	$Sender        = $sender;
	$RelayAddr     = $ip;
	$RelayHostname = $name;
	$Helo          = $helo;

	my ($ok, $msg, $code, $dsn, $delay) = filter_sender($sender, $ip, $name, $helo);
	send_filter_answer($ok, $msg, "filter_sender", "sender $sender", $code, $dsn, $delay);

	chdir($Features{'Path:SPOOLDIR'});
}

#***********************************************************************
# %PROCEDURE: handle_recipok
# %ARGUMENTS:
#  recipient -- e-mail address of recipient
#  sender -- e-mail address of sender
#  ip -- IP address of relay host
#  name -- name of relay host
#  firstRecip -- first recipient of message
#  helo -- arg to SMTP HELO command
# %RETURNS:
#  Nothing, but prints "ok 1" if we accept message to this recipient,
# "ok 0" if not.
#***********************************************************************
sub handle_recipok
{
	my ($recipient, $sender, $ip, $name, $firstRecip, $helo, $rcpt_mailer, $rcpt_host, $rcpt_addr);

	($recipient, $sender, $ip, $name, $firstRecip, $helo, $CWD, $QueueID, $rcpt_mailer, $rcpt_host, $rcpt_addr, @ESMTPArgs) = @_;
	$MsgID = $QueueID;

	if(!defined(&filter_recipient)) {
		send_filter_answer('CONTINUE', "ok", "filter_recipient", "recipient $recipient");
		return;
	}

	if (!chdir($CWD)) {
		send_filter_answer('TEMPFAIL', "could not chdir($CWD): $!", "filter_recipient", "recipient $recipient");
	}

	# Set up additional globals
	@Recipients    = ($recipient);
	$Sender        = $sender;
	$RelayAddr     = $ip;
	$RelayHostname = $name;
	$Helo          = $helo;
	$RecipientMailers{$recipient} = [ $rcpt_mailer, $rcpt_host, $rcpt_addr ];

	my ($ok, $msg, $code, $dsn, $delay) = filter_recipient($recipient, $sender, $ip, $name, $firstRecip, $helo, $rcpt_mailer, $rcpt_host, $rcpt_addr);
	send_filter_answer($ok, $msg, "filter_recipient", "recipient $recipient", $code, $dsn, $delay);

	chdir($Features{'Path:SPOOLDIR'});
}

sub print_and_flush
{
	local $| = 1;
	print($_[0], "\n");
}

sub init_globals {
    $CWD = $Features{'Path:SPOOLDIR'};
    $InMessageContext = 0;
    $InFilterEnd = 0;
    $InFilterContext = 0;
    $InFilterWrapUp = 0;
    undef $FilterEndReplacementEntity;
    $Action = "";
    $Changed = 0;
    $DefangCounter = 0;
    $Domain = "";
    $MIMEDefangID = "";
    $MsgID = "NOQUEUE";
    $MessageID = "NOQUEUE";
    $Helo = "";
    $QueueID = "NOQUEUE";
    $QuarantineCount = 0;
    $Rebuild = 0;
    $EntireMessageQuarantined = 0;
    $QuarantineSubdir = "";
    $RelayAddr = "";
    $RealRelayAddr = "";
    $WasResent = 0;
    $RelayHostname = "";
    $RealRelayHostname = "";
    $Sender = "";
    $Subject = "";
    $SubjectCount = 0;
    $SuspiciousCharsInHeaders = 0;
    $SuspiciousCharsInBody = 0;
    $TerminateAndDiscard = 0;
    $VirusScannerMessages = "";
    $VirusName = "";
    $WasMultiPart = 0;
    $WarningCounter = 0;
    undef %Actions;
    undef %SendmailMacros;
    undef %RecipientMailers;
    undef %RecipientESMTPArgs;
    undef @FlatParts;
    undef @Recipients;
    undef @Warnings;
    undef @AddedParts;
    undef @StatusTags;
    undef @ESMTPArgs;
    undef @SenderESMTPArgs;
    undef $results_fh;
}

sub builtin_create_parser {
    my $parser = MIME::Parser->new();
    $parser->extract_nested_messages(1);
    $parser->extract_uuencode(1);
    $parser->output_to_core(0);
    $parser->tmp_to_core(0);
    return $parser;
}

#***********************************************************************
# %PROCEDURE: do_scan
# %ARGUMENTS:
#  workdir -- working directory to scan
# %RETURNS:
#  0 if parse went well; non-zero otherwise.
# %DESCRIPTION:
#  Scan a message in working directory.
#***********************************************************************
sub do_scan {
    my($workdir) = @_;

    if (!chdir($workdir)) {
	fatal("Cannot chdir($workdir): $!");
	return -1;
    }

    $CWD = $workdir;

    # Read command file
    push_status_tag("Reading COMMANDS");
    read_commands_file('need_F') or return -1;
    pop_status_tag();

    # We're processing a message
    $InMessageContext = 1;

    # Set message ID
    if ($QueueID ne "") {
	$MsgID = $QueueID;
    } elsif ($MessageID ne "") {
	$MsgID = $MessageID;
    } else {
	$MsgID = "NOQUEUE";
    }

    if ($QueueID eq "") {
	$QueueID = "NOQUEUE";
    }
    if ($MessageID eq "") {
	$MessageID = "NOQUEUE";
    }

    my($file) = "INPUTMSG";

    # Create a subdirectory for storing all the actual message data
    my($msgdir) = "Work";
    if (!mkdir($msgdir, 0750)) {
	fatal("Cannot mkdir($msgdir): $!");
	return -1;
    }

    my $entity;
    my $parser;
    if (defined(&filter_create_parser)) {
	$parser = filter_create_parser();
	if (!defined($parser) ||
	    !$parser->isa('MIME::Parser')) {
	    $parser = builtin_create_parser();
	}
    } else {
	$parser = builtin_create_parser();
    }

    my $filer = MIME::Parser::FileInto->new($msgdir);
    # Don't trust any filenames from the message.
    $filer->ignore_filename(1);
    $parser->filer($filer);

    # Parse the input stream:
    if (!open(FILE, $file)) {
	fatal("couldn't open $file: $!");
	signal_complete();
	return -1;
    }

    if ($MaxMIMEParts > 0) {
	$parser->max_parts($MaxMIMEParts);
    }
    push_status_tag("Parsing Message");
    $entity = $parser->parse(\*FILE);
    pop_status_tag();
    close FILE;

    if (!defined($entity) && $MaxMIMEParts > 0) {
	# Message is too complex; bounce it
	action_bounce("Message contained too many MIME parts.  We do not accept such complicated messages.");
	signal_unchanged();
	signal_complete();
	return;
    }

    if (!$entity) {
	fatal("Couldn't parse MIME in $file: $!");
	signal_complete();
	return -1;
    }

    # Make entity multipart
    my ($code);
    $code = $entity->make_multipart();
    $WasMultiPart = ($code eq 'ALREADY');


    # If there are multiple Subject: lines, delete all but the first
    if ($SubjectCount > 1) {
	md_syslog('warning', "Message contains $SubjectCount Subject: headers.  Deleting all but the first");
	for (my $i=$SubjectCount; $i > 1; $i--) {
	    action_delete_header("Subject", $i);
	}
    }

    # Call pre-scan filter if defined
    if (defined(&filter_begin)) {
	push_status_tag("In filter_begin");
	filter_begin($entity);
	pop_status_tag();
	# If stream_by_domain tells us to discard, do so...
	if ($TerminateAndDiscard) {
	    write_result_line("D", "");
	    signal_unchanged();
	    md_syslog('debug', "filter_begin set TerminateAndDiscard flag.  Don't panic; it's most likely a message being streamed.");
	    signal_complete();
	    return;
	}
    }


    # Now rebuild the message!
    my($boundary);
    my($rebuilt);
    my($rebuilt_flat);

    # Prepare rebuilt container.
    # We don't want a deep copy here, so do some trickery...
    my @parts;

    # Save parts
    @parts = $entity->parts;

    # Clear them out prior to deep copy
    $entity->parts([]);

    # "Deep" copy (ha ha...)
    $rebuilt = $entity->dup;

    # And restore parts to original
    $entity->parts(\@parts);

    # Rebuild
    $InFilterContext = 1;
    push_status_tag("In rebuild loop");
    map { rebuild_entity($rebuilt, $_) } $entity->parts;
    pop_status_tag();

    if ($#Warnings >= 0) {
	my $didSomething = 0;
	my $html_warning;
	$Changed = 1;
	if ($AddWarningsInline) {
	    my $warning = $GeneralWarning . join("\n", @Warnings);
	    my $ruler = "=" x 75;
	    $html_warning = $warning;
	    $html_warning =~ s/&/&amp;/g;
	    $html_warning =~ s/</&lt;/g;
	    $html_warning =~ s/>/&gt;/g;
	    $didSomething = 1
		if append_text_boilerplate($rebuilt, "$ruler\n$warning", 0);
	    $didSomething = 1
		if append_html_boilerplate($rebuilt, "<hr>\n<pre>\n$html_warning</pre>", 0);
	}

	if (!$didSomething) {
	    # HACK for Micro$oft "LookOut!"
	    if ($WasMultiPart &&
		$Stupidity{"NoMultipleInlines"} &&
		$WarningLocation == 0) {
		# Descend into first leaf
		my($msg) = $rebuilt;
		my(@parts) = $msg->parts;
		while($#parts >= 0) {
		    $msg = $parts[0];
		    @parts = $msg->parts;
		}
		my($head) = $msg->head;
		my($type) = $msg->mime_type;
		if (lc($head->mime_type) eq "text/plain") {
		    $head->mime_attr("Content-Type.name" => "MESSAGE.TXT");
		    $head->mime_attr("Content-Disposition" => "inline");
		    $head->mime_attr("Content-Disposition.filename" => "MESSAGE.TXT");
		    $head->mime_attr("Content-Description" => "MESSAGE.TXT");
		}
	    }
	    my $warns = $GeneralWarning . join("\n", @Warnings);
	    $WarningCounter++;
	    action_add_part($rebuilt, "text/plain", "-suggest",
			    $warns, "warning$WarningCounter.txt", "inline", $WarningLocation);
	}
    }

    $InFilterContext = 0;

    # Call post-scan filter if defined
    if (defined(&filter_end)) {
	$InFilterEnd = 1;
	push_status_tag("In filter_end");
	filter_end($rebuilt);
	pop_status_tag();
	$InFilterEnd = 0;
    }

    if ($Rebuild && defined($FilterEndReplacementEntity)) {
	$rebuilt = $FilterEndReplacementEntity;
	undef $FilterEndReplacementEntity;
    }

    if ($Changed || $Rebuild) {
	if (!open(OUT, ">NEWBODY")) {
	    fatal("Can't open NEWBODY: $!");
	    signal_complete();
	    return -1;
	}

	# Add any parts inserted by action_add_part
	$rebuilt = process_added_parts($rebuilt);

	# Trim out useless multiparts.  FIXME: Make this optional?
	while ((lc($rebuilt->head->mime_type) eq "multipart/mixed" ||
		lc($rebuilt->head->mime_type) eq "multipart/alternative") &&
	       $rebuilt->parts == 1 && defined($rebuilt->parts(0))) {
		$rebuilt->make_singlepart();
	}
	push_status_tag("Writing new body");
	$rebuilt->print_body(\*OUT);
	pop_status_tag();
	close(OUT);


	# Write new content-type header in case we've changed the type.
	my $ct = $rebuilt->head->get('Content-Type');
	if (!defined($ct)) {
	    my $type;
	    $type = $rebuilt->mime_type;
	    $boundary = $rebuilt->head->multipart_boundary;
	    if (defined($boundary)) {
		$ct = "$type; boundary=\"$boundary\"";
	    } else {
		$ct = "$type";
	    }
	}
	if (defined($ct)) {
	    chomp($ct);
	    write_result_line("M", $ct);
	}
	# Write out all the other MIME headers associated with the rebuilt
	# entity.
	my($tag, $hdr);
	foreach $tag (grep {/^content-/i} $rebuilt->head->tags) {
	    # Already done content-type
	    next if ($tag =~ /^content-type$/i);
	    if ($tag =~ /^content-transfer-encoding$/i) {
		# If it is now multipart, but wasn't before, we will
		# delete any content-transfer-encoding header.
		if ($rebuilt->head->mime_type =~ m+^multipart/+i &&
		    !$WasMultiPart) {
		    next;
		}
	    }
	    $hdr = $rebuilt->head->get($tag);
	    if (defined($hdr) && $hdr ne "") {
		chomp($hdr);
		action_change_header($tag, $hdr);
	    }
	}
	# If it is now multipart, but wasn't before, delete
	# content-transfer-encoding header.
	if ($rebuilt->head->mime_type =~ m+^multipart/+i &&
	    !$WasMultiPart) {
	    action_delete_header("Content-Transfer-Encoding");
	}
	signal_changed();
    } else {
	signal_unchanged();
    }

    # Call filter_wrapup if defined
    if (defined(&filter_wrapup)) {
	$InFilterWrapUp = 1;
	push_status_tag("In filter_wrapup");
	filter_wrapup($rebuilt);
	pop_status_tag();
	$InFilterWrapUp = 0;
    }

    signal_complete();

    return 0;
}

#***********************************************************************
# %PROCEDURE: read_commands_file
# %ARGUMENTS:
#  needf - if true, will return an error when no closing "F" was found.
#          (optional, default is false). needf should not be set when
#          called from within filter_relay, filter_sender, filter_recipient.
# %RETURNS:
#  true if parse went well,
#  false otherwise
# %DESCRIPTION:
#  Parses the COMMANDS file, and sets these global variables based
#  upon the contents of that file:
#    $Sender
#    @Recipients
#    %RecipientMailers
#    $SuspiciousCharsInHeaders
#    $SuspiciousCharsInBody
#    $RelayAddr
#    $RealRelayAddr
#    $WasResent
#    $RelayHostname
#    $RealRelayHostname
#    $QueueID
#    $Subject
#    $MessageID
#    $Helo
#    %SendmailMacros
#
#***********************************************************************
sub read_commands_file {
    my $needF = shift;
    $needF = 0 unless defined($needF);

    if (!open(IN, "<COMMANDS")) {
	fatal("Cannot open COMMANDS file from mimedefang: $!");
	return 0;
    }

    my($cmd, $arg, $rawcmd, $rawarg, $seenF);

    # Save current recipient if called from filter_recipient
    my @tmp_recipients = @Recipients;
    @Recipients = ();
    $seenF = 0;
    my $recent_recip = "";

    while(<IN>) {
	chomp;
	$rawcmd = $_;
	$cmd = percent_decode($rawcmd);
	$arg = substr($cmd, 1);
	$cmd = substr($cmd, 0, 1);
	$rawarg = substr($rawcmd, 1);

	if ($cmd eq "S") {
	    $Sender = $arg;
	} elsif ($cmd eq "s") {
	    push(@SenderESMTPArgs, $arg);
	} elsif ($cmd eq "F") {
	    $seenF = 1;
	    last;
	} elsif ($cmd eq "R") {
	    my($recip, $rcpt_mailer, $rcpt_host, $rcpt_addr);
	    ($recip, $rcpt_mailer, $rcpt_host, $rcpt_addr) = split(' ', $rawarg);
	    $rcpt_mailer = "?" unless (defined($rcpt_mailer) and ($rcpt_mailer ne ""));
	    $rcpt_host = "?" unless (defined($rcpt_host) and ($rcpt_host ne ""));
	    $rcpt_addr = "?" unless (defined($rcpt_addr) and ($rcpt_addr ne ""));
	    $recip = percent_decode($recip);
	    $rcpt_mailer = percent_decode($rcpt_mailer);
	    $rcpt_host = percent_decode($rcpt_host);
	    $rcpt_addr = percent_decode($rcpt_addr);
	    push(@Recipients, $recip);
	    $RecipientMailers{$recip} = [$rcpt_mailer, $rcpt_host, $rcpt_addr];
	    $recent_recip = $recip;
	} elsif ($cmd eq "r") {
	    push (@{$RecipientESMTPArgs{$recent_recip}}, $arg);
	} elsif ($cmd eq "!") {
	    $SuspiciousCharsInHeaders = 1;
	} elsif ($cmd eq "?") {
	    $SuspiciousCharsInBody    = 1;
	} elsif ($cmd eq "I") {
	    $RelayAddr = $arg;
	    $RealRelayAddr = $arg;
	} elsif ($cmd eq "J") {
	    $WasResent = 1;
	    $RelayAddr = $arg;
	    my($iaddr, $iname);
	    $iaddr = inet_aton($RelayAddr);
	    $iname = gethostbyaddr($iaddr, AF_INET);
	    if (defined($iname)) {
		$RelayHostname = $iname;
	    } else {
		$RelayHostname = "[$RelayAddr]";
	    }
	} elsif ($cmd eq "H") {
	    $RelayHostname = $arg;
	    $RealRelayHostname = $arg;
	} elsif ($cmd eq "Q") {
	    $QueueID = $arg;
	} elsif ($cmd eq "U") {
	    $SubjectCount++;
	    if ($SubjectCount > 1) {
		md_syslog('warning', "Message contains more than one Subject: header: $Subject --> $arg");
  	    } else {
		$Subject = $arg;
	    }
	} elsif ($cmd eq "X") {
	    $MessageID = $arg;
	} elsif ($cmd eq "E") {
	    $Helo = $arg;
	} elsif ($cmd eq "=") {
	    my($macro, $value);
	    ($macro, $value) = split(' ', $rawarg);
	    $value = "" unless defined($value);
	    $macro = "" unless defined($macro);
	    if ($macro ne "") {
		$macro = percent_decode($macro);
		$value = percent_decode($value);
		$SendmailMacros{$macro} = $value;
	    }
	} elsif ($cmd eq "i") {
		$MIMEDefangID = $arg;
	} else {
	    md_syslog('warning', "Unknown command $cmd from mimedefang");
	}
    }
    close(IN);

    if ( $needF && !$seenF ) {
	md_syslog('err', "COMMANDS file from mimedefang did not terminate with 'F' -- check disk space in spool directory");
	fatal("COMMANDS file did not end with F");
        return 0;
    }

    push @Recipients, @tmp_recipients;
    return 1;
}


#***********************************************************************
# %PROCEDURE: replace_entire_message
# %ARGUMENTS:
#  e -- a MIME::Entity
# %RETURNS:
#  1 on success; 0 on failure.
# %DESCRIPTION:
#  Replaces entire message with $e
# %PRECONDITIONS:
#  Can only be called from filter_end
#***********************************************************************
sub replace_entire_message {
    my($e) = @_;
    return 0 unless in_filter_end("replace_entire_message");

    if (!defined($e)) {
	md_syslog('err', "Call to replace_entire_message with undefined argument");
	return 0;
    }
    if (ref($e) ne "MIME::Entity") {
	md_syslog('err', "Call to replace_entire_message with agument that is not of type MIME::Entity");
	return 0;
    }
    $FilterEndReplacementEntity = $e;
    $Rebuild = 1;
    return 1;
}

#***********************************************************************
# %PROCEDURE: remove_redundant_html_parts
# %ARGUMENTS:
#  e -- entity
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Rebuilds $e without redundant HTML parts.  That is, if
#  a multipart/alternative entity contains text/plain and text/html
#  parts, we nuke the text/html part.
#***********************************************************************
sub remove_redundant_html_parts {
    my($e) = @_;
    return 0 unless in_filter_end("remove_redundant_html_parts");

    my(@parts) = $e->parts;
    my($type) = lc($e->mime_type);

    # Don't recurse into multipart/signed or multipart/encrypted
    return 0 if ($type eq "multipart/signed" or
		 $type eq "multipart/encrypted");
    my(@keep, $part);
    my($didsomething);
    $didsomething = 0;
    my($have_text_plain);
    if ($type eq "multipart/alternative" && $#parts >= 0) {
	# First look for a text/plain part
	$have_text_plain = 0;
	foreach $part (@parts) {
	    $type = lc($part->mime_type);
	    if ($type eq "text/plain") {
		$have_text_plain = 1;
		last;
	    }
	}

	# If we have a text/plain part, delete any text/html part
	if ($have_text_plain) {
	    foreach $part (@parts) {
		$type = lc($part->mime_type);
		if ($type ne "text/html") {
		    push(@keep, $part);
		} else {
		    $didsomething = 1;
		}
	    }
	    if ($didsomething) {
		$e->parts(\@keep);
		@parts = @keep;
		$Changed = 1;
	    }
	}
    }
    if ($#parts >= 0) {
	foreach $part (@parts) {
	    $didsomething = 1 if (remove_redundant_html_parts($part));
	}
    }
    return $didsomething;
}

#***********************************************************************
# %PROCEDURE: find_part
# %ARGUMENTS:
#  entity -- root MIME part
#  content_type -- desired MIME content type
#  skip_pgp_mime -- If true, do not descend into multipart/signed or
#                   multipart/encrypted parts
# %RETURNS:
#  First MIME entity of type "$content_type"; undef if none exists.
#***********************************************************************
sub find_part {
    my($entity, $content_type, $skip_pgp_mime) = @_;
    my(@parts);
    my($part);
    my($ans);
    if (!($entity->is_multipart)) {
	if (lc($entity->head->mime_type) eq lc($content_type)) {
	    return $entity;
	} else {
	    return undef;
	}
    }

    if ($skip_pgp_mime &&
	(lc($entity->head->mime_type) eq "multipart/signed" or
	 lc($entity->head->mime_type) eq "multipart/encrypted")) {
	return undef;
    }

    @parts = $entity->parts;
    foreach $part (@parts) {
	$ans = find_part($part, $content_type, $skip_pgp_mime);
	return $ans if defined($ans);
    }
    return undef;
}

#***********************************************************************
# %PROCEDURE: append_to_part
# %ARGUMENTS:
#  part -- a mime entity
#  msg -- text to append to the entity
# %RETURNS:
#  1 on success; 0 on failure.
# %DESCRIPTION:
#  Appends text to $part
#***********************************************************************
sub append_to_part {
    my($part, $boilerplate) = @_;
    return 0 unless defined($part->bodyhandle);
    my($path) = $part->bodyhandle->path;
    return 0 unless (defined($path));
    return 0 unless (open(OUT, ">>$path"));
    print OUT "\n$boilerplate\n";
    close(OUT);
    $Changed = 1;
    return 1;
}

# HTML parser callbacks
sub html_echo {
    my($text) = @_;
    print OUT $text;
}

sub html_end {
    my($text) = @_;
    if (!$HTMLFoundEndBody) {
	if ($text =~ m+<\s*/body+i) {
	    print OUT "$HTMLBoilerplate\n";
	    $HTMLFoundEndBody = 1;
	}
    }
    if (!$HTMLFoundEndBody) {
	if ($text =~ m+<\s*/html+i) {
	    print OUT "$HTMLBoilerplate\n";
	    $HTMLFoundEndBody = 1;
	}
    }

    print OUT $text;
}

#***********************************************************************
# %PROCEDURE: append_to_html_part
# %ARGUMENTS:
#  part -- a mime entity (of type text/html)
#  msg -- text to append to the entity
# %RETURNS:
#  1 on success; 0 on failure.
# %DESCRIPTION:
#  Appends text to $part, but does so by parsing HTML and adding the
#  text before </body> or </html>
#***********************************************************************
sub append_to_html_part {
    my($part, $boilerplate) = @_;

    if (!$Features{"HTML::Parser"}) {
	md_syslog('warning', "Attempt to call append_to_html_part, but HTML::Parser Perl module not installed");
	return 0;
    }
    return 0 unless defined($part->bodyhandle);
    my($path) = $part->bodyhandle->path;
    return 0 unless (defined($path));
    return 0 unless (open(IN, "<$path"));
    if (!open(OUT, ">$path.tmp")) {
	close(IN);
	return(0);
    }

    $HTMLFoundEndBody = 0;
    $HTMLBoilerplate = $boilerplate;
    my($p);
    $p = HTML::Parser->new(api_version => 3,
			   default_h   => [\&html_echo, "text"],
			   end_h       => [\&html_end,  "text"]);
    $p->unbroken_text(1);
    $p->parse_file(*IN);
    if (!$HTMLFoundEndBody) {
	print OUT "\n$boilerplate\n";
    }
    close(IN);
    close(OUT);

    # Rename the path
    return 0 unless rename($path, "$path.old");
    unless (rename("$path.tmp", $path)) {
	rename ("$path.old", $path);
	return 0;
    }
    unlink "$path.old";
    $Changed = 1;
    return 1;
}

#***********************************************************************
# %PROCEDURE: append_text_boilerplate
# %ARGUMENTS:
#  msg -- root MIME entity.
#  boilerplate -- boilerplate text to append
#  all -- if 1, append to ALL text/plain parts.  If 0, append only to
#         FIRST text/plain part.
# %RETURNS:
#  1 if text was appended to at least one part; 0 otherwise.
# %DESCRIPTION:
#  Appends text to text/plain part or parts.
#***********************************************************************
sub append_text_boilerplate {
    my($msg, $boilerplate, $all) = @_;
    my($part);
    if (!$all) {
	$part = find_part($msg, "text/plain", 1);
	if (defined($part)) {
	    if (append_to_part($part, $boilerplate)) {
		$Actions{'append_text_boilerplate'}++;
		return 1;
	    }
	}
	return 0;
    }
    @FlatParts = ();
    my($ok) = 0;
    collect_parts($msg, 1);
    foreach $part (@FlatParts) {
	if (lc($part->head->mime_type) eq "text/plain") {
	    if (append_to_part($part, $boilerplate)) {
		$ok = 1;
		$Actions{'append_text_boilerplate'}++;
	    }
	}
    }
    return $ok;
}

#***********************************************************************
# %PROCEDURE: append_html_boilerplate
# %ARGUMENTS:
#  msg -- root MIME entity.
#  boilerplate -- boilerplate text to append
#  all -- if 1, append to ALL text/html parts.  If 0, append only to
#         FIRST text/html part.
# %RETURNS:
#  1 if text was appended to at least one part; 0 otherwise.
# %DESCRIPTION:
#  Appends text to text/html part or parts.  Tries to be clever and
#  insert the text before the </body> tag so it has a hope in hell of
#  being seen.
#***********************************************************************
sub append_html_boilerplate {
    my($msg, $boilerplate, $all) = @_;
    my($part);
    if (!$all) {
	$part = find_part($msg, "text/html", 1);
	if (defined($part)) {
	    if (append_to_html_part($part, $boilerplate)) {
		$Actions{'append_html_boilerplate'}++;
		return 1;
	    }
	}
	return 0;
    }
    @FlatParts = ();
    my($ok) = 0;
    collect_parts($msg, 1);
    foreach $part (@FlatParts) {
	if (lc($part->head->mime_type) eq "text/html") {
	    if (append_to_html_part($part, $boilerplate)) {
		$ok = 1;
		$Actions{'append_html_boilerplate'}++;
	    }
	}
    }
    return $ok;
}

#***********************************************************************
# %PROCEDURE: action_replace_with_url
# %ARGUMENTS:
#  entity -- part to replace
#  doc_root -- document root in which to place file
#  base_url -- base URL for retrieving document
#  msg -- message to replace document with.  The string "_URL_" is
#         replaced with the actual URL of the part.
#  cd_data -- optional Content-Disposition filename data to save
#  salt    -- optional salt to add to SHA1 hash.
# %RETURNS:
#  1 on success, 0 on failure
# %DESCRIPTION:
#  Places the part in doc_root/{sha1_of_part}.ext and replaces it with
#  a text/plain part giving the URL for pickup.
#***********************************************************************
sub action_replace_with_url {
    my($entity, $doc_root, $base_url, $msg, $cd_data, $salt) = @_;
    my($ctx);
    my($path);
    my($fname, $ext, $name, $url);
    my $extension = "";

    return 0 unless in_filter_context("action_replace_with_url");
    return 0 unless defined($entity->bodyhandle);
    $path = $entity->bodyhandle->path;
    return 0 unless defined($path);
    open(IN, "<$path") or return 0;

    $ctx = Digest::SHA->new;
    $ctx->addfile(*IN);
    $ctx->add($salt) if defined($salt);
    close(IN);

    $fname = takeStabAtFilename($entity);
    $fname = "" unless defined($fname);
    $extension = $1 if ($fname =~ /(\.[^.]*)$/);

    # Use extension if it is .[alpha,digit,underscore]
    $extension = "" unless ($extension =~ /^\.[A-Za-z0-9_]*$/);

    # Filename to save
    $name = $ctx->hexdigest . $extension;
    $fname = $doc_root . "/" . $name;
    $url = $base_url . "/" . $name;

    if (-r $fname) {
	# If file exists, then this is either a duplicate or someone
	# has defeated SHA1.  Just update the mtime on the file.
	my($now);
	$now = time;
	utime($now, $now, $fname);
    } else {
	copy_or_link($path, $fname) or return 0;
	# In case umask is whacked...
	chmod 0644, $fname;
    }

    # save optional Content-Disposition data
    if (defined($cd_data) and ($cd_data ne "")) {
	if (open CDF, ">$doc_root/.$name") {
	    print CDF $cd_data;
	    close CDF;
	    chmod 0644, "$doc_root/.$name";
	}
    }

    $msg =~ s/_URL_/$url/g;
    action_replace_with_warning($msg);
    return 1;
}

#***********************************************************************
# %PROCEDURE: add_recipient
# %ARGUMENTS:
#  recip -- recipient to add
# %RETURNS:
#  0 on failure, 1 on success.
# %DESCRIPTION:
#  Signals to MIMEDefang to add a recipient to the envelope.
#***********************************************************************
sub add_recipient {
    my($recip) = @_;
    write_result_line("R", $recip);
    return 1;
}

#***********************************************************************
# %PROCEDURE: change_sender
# %ARGUMENTS:
#  sender -- new envelope sender
# %RETURNS:
#  0 on failure, 1 on success.
# %DESCRIPTION:
#  Signals to MIMEDefang to change the envelope sender.  Only works on
#  Sendmail 8.14.0 and higher, but no feedback is given to Perl caller!
#***********************************************************************
sub change_sender {
    my($sender) = @_;
    write_result_line("f", $sender);
    return 1;
}

#***********************************************************************
# %PROCEDURE: delete_recipient
# %ARGUMENTS:
#  recip -- recipient to delete
# %RETURNS:
#  0 on failure, 1 on success.
# %DESCRIPTION:
#  Signals to MIMEDefang to delete a recipient from the envelope.
#***********************************************************************
sub delete_recipient {
    my($recip) = @_;
    write_result_line("S", $recip);
    return 1;
}

#***********************************************************************
# %PROCEDURE: spam_assassin_is_spam
# %ARGUMENTS:
#  config -- optional configuration file
# %RETURNS:
#  1 if SpamAssassin thinks current message is SPAM; 0 otherwise
#  or if message could not be opened.
# %DESCRIPTION:
#  Scans message using SpamAssassin (http://www.spamassassin.org)
#***********************************************************************
sub spam_assassin_is_spam {

    my($hits, $req, $tests, $report) = spam_assassin_check(@_);
    return undef if (!defined($hits));

    return ($hits >= $req);
}

#***********************************************************************
# %PROCEDURE: spam_assassin_check
# %ARGUMENTS:
#  config -- optional spamassassin config file
# %RETURNS:
#  An array of four elements,
#       Weight of message ('hits')
#       Number of hits required before SA conciders a message spam
#       Comma separated list of symbolic test names that were triggered
#       A 'report' string, detailing tests that failed and their weights
# %DESCRIPTION:
#  Scans message using SpamAssassin (http://www.spamassassin.org)
#***********************************************************************
sub spam_assassin_check {

    my($status) = spam_assassin_status(@_);
    return undef if (!defined($status));

    my $hits = $status->get_hits;
    my $req = $status->get_required_hits();
    my $tests = $status->get_names_of_tests_hit();
    my $report = $status->get_report();

    $status->finish();

    return ($hits, $req, $tests, $report);
}

#***********************************************************************
# %PROCEDURE: spam_assassin_status
# %ARGUMENTS:
#  config -- optional spamassassin config file
# %RETURNS:
#  A Mail::SpamAssassin:PerMsgStatus object.
#  CALLER IS RESPONSIBLE FOR CALLING finish()
# %DESCRIPTION:
#  Scans message using SpamAssassin (http://www.spamassassin.org)
#***********************************************************************
sub spam_assassin_status {

    my $object = spam_assassin_init(@_);
    return undef unless $object;

    my $mail = spam_assassin_mail();
    return undef unless $mail;

    my $status;
    push_status_tag("Running SpamAssassin");
    $status = $object->check($mail);
    $mail->finish();
    pop_status_tag();
    return $status;
}

#***********************************************************************
# %PROCEDURE: spam_assassin_init
# %ARGUMENTS:
#  config -- optional spamassassin config file
# %RETURNS:
#  A Mail::SpamAssassin object.
# %DESCRIPTION:
#  Scans message using SpamAssassin (http://www.spamassassin.org)
#***********************************************************************
sub spam_assassin_init {
    my($config) = @_;
    my $LOCAL_RULES_DIR = '/etc/spamassassin';
    my $LOCAL_STATE_DIR = '/var/lib';

    unless ($Features{"SpamAssassin"}) {
	md_syslog('err', "Attempt to call SpamAssassin function, but SpamAssassin is not installed.");
	return undef;
    }

    if (!defined($SASpamTester)) {
	if (!defined($config)) {
	    if (-r '/etc/sa-mimedefang.cf') {
		$config = '/etc/sa-mimedefang.cf';
	    } elsif (-r '/etc/mail/sa-mimedefang.cf') {
		$config = '/etc/mail/sa-mimedefang.cf';
	    } elsif (-r '/etc/spamassassin/local.cf') {
		$config = '/etc/spamassassin/local.cf';
	    } else {
		$config = '/etc/spamassassin.cf';
	    }
	}

	push_status_tag("Creating SpamAssasin Object");

	my $sa_args = {
		local_tests_only   => $SALocalTestsOnly,
		dont_copy_prefs    => 1,
		userprefs_filename => $config,
		user_dir           => $Features{'Path:QUARANTINEDIR'},
	};

	# If SpamAssassin version is older than 3.1.5, we must set
	# LOCAL_STATE_DIR or LOCAL_RULES_DIR, because Mail::SpamAssassin
	# doesn't provide a default value.
	if ($Mail::SpamAssassin::VERSION < 3.001005) {
		$sa_args->{LOCAL_STATE_DIR} = $LOCAL_STATE_DIR;
		$sa_args->{LOCAL_RULES_DIR} = $LOCAL_RULES_DIR;
	}
	$SASpamTester = Mail::SpamAssassin->new( $sa_args );
	pop_status_tag();
    }

    return $SASpamTester;
}

#***********************************************************************
# %PROCEDURE: spam_assassin_mail
# %ARGUMENTS:
#  none
# %RETURNS:
#  A Mail::SpamAssassin::Message object
#***********************************************************************
sub spam_assassin_mail {

    unless ($Features{"SpamAssassin"}) {
	md_syslog('err', "Attempt to call SpamAssassin function, but SpamAssassin is not installed.");
	return undef;
    }

    open(IN, "<./INPUTMSG") or return undef;
    my @msg = <IN>;
    close(IN);

    # Synthesize a "Return-Path" and "Received:" header
    my @sahdrs;
    push (@sahdrs, "Return-Path: $Sender\n");
    push (@sahdrs, split(/^/m, synthesize_received_header()));

    if ($AddApparentlyToForSpamAssassin and
	($#Recipients >= 0)) {
	push(@sahdrs, "Apparently-To: " .
	     join(", ", @Recipients) . "\n");
    }
    unshift (@msg, @sahdrs);
    if (!defined($SASpamTester)) {
	spam_assassin_init(@_);
	return undef unless $SASpamTester;
    }
    return $SASpamTester->parse(\@msg);
}

#***********************************************************************
# %PROCEDURE: send_filter_answer
# %ARGUMENTS:
#  ok -- 1 = accept, 0 = reject, -1 = tmpfail
#  msg -- if non-blank, additional message
#  who -- one of "filter_sender", "filter_relay" or "filter_recipient"
#  what -- the address or host being adjusted
#  code -- SMTP reply code
#  dsn -- DSN code
#  delay -- number of seconds C code should delay before returning
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Sends an answer back for filter_relay, filter_sender and filter_recipient
#***********************************************************************
sub send_filter_answer {
    my($ok, $msg, $who, $what, $code, $dsn, $delay) = @_;

    my($num_ok);
    $num_ok = 0;
    # Did we get an integer?

    $delay = 0 unless (defined($delay) and $delay =~ /^\d+$/);

    if ($ok =~ /^-?\d+$/) {
	$num_ok = $ok;
    }

    $msg = "?" if (!defined($msg) or ($msg eq ""));

    if ($ok eq 'ACCEPT_AND_NO_MORE_FILTERING') {
	md_syslog('debug', "$who said ACCEPT_AND_NO_MORE_FILTERING: No further filtering for this message");
	$code = 250 unless (defined($code) and $code =~ /^2\d\d$/);
	$dsn = "2.1.0" unless (defined($dsn) and $dsn =~ /^2\.\d{1,3}\.\d{1,3}$/);
	$msg = percent_encode($msg);
	$code = percent_encode($code);
	$dsn = percent_encode($dsn);
	print_and_flush("ok 2 $msg $code $dsn $delay");
    } elsif ($ok eq 'DISCARD') {
	$code = 250 unless (defined($code) and $code =~ /^2\d\d$/);
	$dsn = "2.1.0" unless (defined($dsn) and $dsn =~ /^2\.\d{1,3}\.\d{1,3}$/);
	$msg = percent_encode($msg);
	$code = percent_encode($code);
	$dsn = percent_encode($dsn);
	md_syslog('info', "$who said DISCARD: Discarding this message");
	print_and_flush("ok 3 $msg $code $dsn $delay");
    } elsif (($ok eq 'CONTINUE') or ($num_ok > 0)) {
	$code = 250 unless (defined($code) and $code =~ /^2\d\d$/);
	$dsn = "2.1.0" unless (defined($dsn) and $dsn =~ /^2\.\d{1,3}\.\d{1,3}$/);
	$msg = percent_encode($msg);
	$code = percent_encode($code);
	$dsn = percent_encode($dsn);
	print_and_flush("ok 1 $msg $code $dsn $delay");
    } elsif (($ok eq 'TEMPFAIL') or ($num_ok < 0)) {
	md_syslog('debug', "$who tempfailed $what");
	$code = 451 unless (defined($code) and $code =~ /^4\d\d$/);
	$dsn = "4.3.0" unless (defined($dsn) and $dsn =~ /^4\.\d{1,3}\.\d{1,3}$/);
	$msg = percent_encode($msg);
	$code = percent_encode($code);
	$dsn = percent_encode($dsn);
	print_and_flush("ok -1 $msg $code $dsn $delay");
    } else {
	$code = 554 unless (defined($code) and $code =~ /^5\d\d$/);
	$dsn = "5.7.1" unless (defined($dsn) and $dsn =~ /^5\.\d{1,3}\.\d{1,3}$/);
	md_syslog('debug', "$who rejected $what");
	$msg = percent_encode($msg);
	$code = percent_encode($code);
	$dsn = percent_encode($dsn);
	print_and_flush("ok 0 $msg $code $dsn $delay");
    }
}

#***********************************************************************
# %PROCEDURE: md_graphdefang_log_enable
# %ARGUMENTS:
#  SyslogFacility -- (optional) The Syslog facility to which mimedefang
#                    should log messages when md_graphdefang_log() is called.  If
#                    this variable is not passed in, a default value
#                    of 'mail' will be used.
#  EnumerateRecipients -- (optional) Whether or not to output a syslog
#                    line for each recipient of a spam message or only
#                    once per incoming message.  Disabling this will
#                    reduce the entries to syslog but will reduce
#                    statistical granularity on a per user basis.
#
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  This is called to enable Mimedefang logging when the md_graphdefang_log()
#  subroutine is called.  The $SyslogFacility name should be known
#  to syslog on the machine on which Mimedefang is running.
#***********************************************************************
sub md_graphdefang_log_enable
{
    $GraphDefangSyslogFacility = shift;
    $EnumerateRecipients = shift;

    # If we don't have a SyslogFacility from the user,
    # use the system default

    $GraphDefangSyslogFacility = $SyslogFacility
	unless defined($GraphDefangSyslogFacility);

    # By default, we want md_graphdefang_log to output a syslog line for each
    # recipient.  This is useful for per user spam statistics.
    # i.e. How many spam messages were received by foo@bar.com?

    $EnumerateRecipients = 1 unless defined($EnumerateRecipients);
}

#***********************************************************************
# %PROCEDURE: add_ip_validation_header
# %ARGUMENTS:
#  None
# %RETURNS:
#  1 if header was added; 0 otherwise
# %DESCRIPTION:
#  Adds an IP address validation header to preserve relay info.
#***********************************************************************
sub add_ip_validation_header {
    if ($ValidateIPHeader eq "") {
	md_syslog('warning', 'add_ip_validation_header called, but no validation header available.  Check permissions on /etc/mimedefang-ip-key');
	return 0;
    }
    action_add_header($ValidateIPHeader, $RelayAddr);
    return 1;
}

#***********************************************************************
# %PROCEDURE: delete_ip_validation_header
# %ARGUMENTS:
#  None
# %RETURNS:
#  1 if header was deleted; 0 otherwise
# %DESCRIPTION:
#  Deletes IP address validation header.
#***********************************************************************
sub delete_ip_validation_header {
    if ($ValidateIPHeader eq "") {
	md_syslog('warning', 'delete_ip_validation_header called, but no validation header available.  Check permissions on /etc/mimedefang-ip-key');
	return 0;
    }
    action_delete_all_headers($ValidateIPHeader);
    return 1;
}

#***********************************************************************
# %PROCEDURE: md_graphdefang_log
# %ARGUMENTS:
#  event -- The name of the event that is being logged.  Examples
#           include virus, spam, mail, etc.
#  value1 -- (optional) A value associated with the event being logged.
#  value2 -- (optional) A value associated with the event being logged.
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  This is called to log events that occur during mimedefang processing.
#  It should be called from mimedefang-filter with appropriate
#  event names and values.  Possible examples:
#      md_graphdefang_log('virus',$VirusName,$filename);
#      md_graphdefang_log('spam',$hits);
#      md_graphdefang_log('bad_filename',$filename,$extension);
#***********************************************************************
sub md_graphdefang_log
{
    return unless defined($GraphDefangSyslogFacility);
    return if (!in_message_context("md_graphdefang_log"));

    my $event = shift;
    my $value1 = shift;
    my $value2 = shift;

    $value1 = "" unless defined($value1);
    $value2 = "" unless defined($value2);

    my $lcsender = percent_encode_for_graphdefang(lc($Sender));

    # Make values safe for graphdefang
    my $id = percent_encode_for_graphdefang($MsgID);
    my $subj = percent_encode_for_graphdefang($Subject);
    $event = percent_encode_for_graphdefang($event);
    $value1 = percent_encode_for_graphdefang($value1);
    $value2 = percent_encode_for_graphdefang($value2);
    if ($EnumerateRecipients || scalar(@Recipients) == 1) {
	foreach my $recipient (@Recipients) {
	    my $lcrecipient = percent_encode_for_graphdefang(lc($recipient));
	    md_syslog("$GraphDefangSyslogFacility|info","MDLOG,$id," .
		      "$event,$value1,$value2,$lcsender," .
		      "$lcrecipient,$subj");
	}
    } else {
	my $lcrecipient = "rcpts=" . scalar(@Recipients);
	$lcrecipient = percent_encode_for_graphdefang($lcrecipient);
	md_syslog("$GraphDefangSyslogFacility|info","MDLOG,$id," .
		  "$event,$value1,$value2,$lcsender," .
		  "$lcrecipient,$subj");
    }
}

#***********************************************************************
# %PROCEDURE: message_contains_virus
# %ARGUMENTS:
#  None
# %RETURNS:
#  ($code, $category, $action) -- standard virus-scanner return values.
# %DESCRIPTION:
#  Scans message using *every single* installed virus scanner.
#***********************************************************************
sub message_contains_virus {
    my($code, $category, $action);
    $code = 0;
    $category = 'ok';
    $action = 'ok';
    initialize_virus_scanner_routines();

    if (!@VirusScannerMessageRoutines) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    my ($scanner, $scode, $scat, $sact);
    push_status_tag("Running virus scanner");
    foreach $scanner (@VirusScannerMessageRoutines) {
	($scode, $scat, $sact) = &$scanner();
	if ($scat eq "virus") {
	    return (wantarray ? ($scode, $scat, $sact) : $scode);
	}
	if ($scat ne "ok") {
	    $code = $scode;
	    $category = $scat;
	    $action = $sact;
	}
    }
    pop_status_tag();
    return (wantarray ? ($code, $category, $action) : $code);
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus
# %ARGUMENTS:
#  e -- a MIME::Entity
# %RETURNS:
#  ($code, $category, $action) -- standard virus-scanner return values.
# %DESCRIPTION:
#  Scans entity using *every single* installed virus scanner.
#***********************************************************************
sub entity_contains_virus {
    my($e) = @_;
    my($code, $category, $action);
    $code = 0;
    $category = 'ok';
    $action = 'ok';

    initialize_virus_scanner_routines();
    if (!@VirusScannerEntityRoutines) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    my ($scanner, $scode, $scat, $sact);
    push_status_tag("Running virus scanner");
    foreach $scanner (@VirusScannerEntityRoutines) {
	($scode, $scat, $sact) = &$scanner($e);
	if ($scat eq "virus") {
	    return (wantarray ? ($scode, $scat, $sact) : $scode);
	}
	if ($scat ne "ok") {
	    $code = $scode;
	    $category = $scat;
	    $action = $sact;
	}
    }
    pop_status_tag();
    return (wantarray ? ($code, $category, $action) : $code);
}

#***********************************************************************
# %PROCEDURE: initialize_virus_scanner_routines
# %ARGUMENTS:
#  None
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Sets @VirusScannerMessageRoutines and @VirusScannerEntityRoutines
#  to arrays of virus-scanner routines to call, based on installed
#  scanners.
#***********************************************************************
sub initialize_virus_scanner_routines {
    if ($VirusScannerRoutinesInitialized) {
	return;
    }
    $VirusScannerRoutinesInitialized = 1;

    # The daemonized scanners first
    if ($Features{'Virus:CLAMD'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_clamd;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_clamd;
    }

    if ($Features{'Virus:SOPHIE'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_sophie;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_sophie;
    }

    if ($Features{'Virus:TROPHIE'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_trophie;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_trophie;
    }

    if ($Features{'Virus:SymantecCSS'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_carrier_scan;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_carrier_scan;
    }

    if ($Features{'Virus:FPROTD'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_fprotd;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_fprotd;
    }

    if ($Features{'Virus:FPROTD6'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_fprotd_v6;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_fprotd_v6;
    }

    if ($Features{'Virus:AVP5'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_avp5;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_avp5;
    }

    if ($Features{'Virus:KAVSCANNER'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_kavscanner;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_kavscanner;
    }

    # Finally the command-line scanners
    if ($Features{'Virus:CLAMAV'} && ! $Features{'Virus:CLAMD'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_clamav;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_clamav;
    }

    if ($Features{'Virus:AVP'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_avp;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_avp;
    }

    if ($Features{'Virus:NAI'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_nai;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_nai;
    }

    if ($Features{'Virus:FPROT'} && !$Features{'Virus:FPROTD'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_fprot;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_fprot;
    }

    if ($Features{'Virus:FPSCAN'} && !$Features{'Virus:FPROTD6'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_fpscan;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_fpscan;
    }

    if ($Features{'Virus:CSAV'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_csav;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_csav;
    }

    if ($Features{'Virus:FSAV'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_fsav;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_fsav;
    }

    if ($Features{'Virus:HBEDV'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_hbedv;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_hbedv;
    }

    if ($Features{'Virus:BDC'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_bdc;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_bdc;
    }

    if ($Features{'Virus:NVCC'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_nvcc;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_nvcc;
    }

    if ($Features{'Virus:VEXIRA'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_vexira;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_vexira;
    }

    if ($Features{'Virus:SOPHOS'} && ! $Features{'Virus:SOPHIE'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_sophos;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_sophos;
    }

    if ($Features{'Virus:SAVSCAN'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_savscan;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_savscan;
    }

    if ($Features{'Virus:TREND'} && ! $Features{'Virus:TROPHIE'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_trend;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_trend;
    }

    if ($Features{'Virus:NOD32'}) {
	push @VirusScannerMessageRoutines, \&message_contains_virus_nod32;
	push @VirusScannerEntityRoutines, \&entity_contains_virus_nod32;
    }
}

#***********************************************************************
# %PROCEDURE: get_smtp_return_code
# %ARGUMENTS:
#  sock -- a socket connected to an SMTP server
#  recip -- the recipient we're inquring about
#  server -- the server we're querying
# %RETURNS:
#  A four-element list:(retval, code, dsn, text),
#  where code is a 3-digit SMTP code.
#  Retval is 'CONTINUE', 'TEMPFAIL' or 'REJECT'.
# %DESCRIPTION:
#  Reads return codes from SMTP server
#***********************************************************************
sub get_smtp_return_code {
    my($sock, $recip, $server) = @_;
    my($line, $code, $text, $retval, $dsn);
    while (defined ($line = $sock->getline())) {
	# Chew up all white space, including CR
	$line =~ s/\s+$//;
	if (($line =~ /^\d\d\d$/) or ($line =~ /^\d\d\d\s/)) {
	    $line =~ /^(\d\d\d)\s*(.*)$/;
	    $code = $1;
	    $text = $2;
	    # Check for DSN
	    if ($text =~ /^(\d\.\d{1,3}\.\d{1,3})\s+(.*)$/) {
		$dsn = $1;
		$text = $2;
	    } else {
		$dsn = "";
	    }
	    if ($code =~ /^[123]/) {
		$retval = 'CONTINUE';
	    } elsif ($code =~ /^4/) {
		md_syslog('info', "md_check_against_smtp_server for $recip on $server returned $code $dsn $text");
		$retval = 'TEMPFAIL';
	    } elsif ($code =~ /^5/) {
		md_syslog('info', "md_check_against_smtp_server for $recip on $server returned $code $dsn $text");
		$retval = 'REJECT';
	    } else {
		md_syslog('warning', "Invalid SMTP reply code $code from server $server for $recip");
		$retval = 'TEMPFAIL';
	    }
	    return ($retval, $code, $dsn, $text);
	}
    }

    my $msg;
    if( defined $line ) {
        $msg = "Invalid response [$line] from SMTP server";
        md_syslog('info', "md_check_against_smtp_server for $recip on $server returned invalid response [$line]");
    } else {
        $msg = "Empty response from SMTP server";
        md_syslog('info', "md_check_against_smtp_server for $recip on $server returned an empty response");
    }

    return ('TEMPFAIL', "451", "4.3.0", $msg );
}

#***********************************************************************
# %PROCEDURE: md_check_against_smtp_server
# %ARGUMENTS:
#  sender -- sender e-mail address
#  recip -- recipient e-mail address
#  helo -- string to put in "HELO" command
#  server -- SMTP server to try.
#  port   -- optional: Port to connect on (defaults to 25)
# %RETURNS:
#  ('CONTINUE', "OK") if recipient is OK
#  ('TEMPFAIL', "err") if temporary failure
#  ('REJECT', "err") if recipient is not OK.
# %DESCRIPTION:
#  Verifies a recipient against another SMTP server by issuing a
#  HELO / MAIL FROM: / RCPT TO: / QUIT sequence
#***********************************************************************
sub md_check_against_smtp_server {
    my($sender, $recip, $helo, $server, $port) = @_;
    my($code, $text, $dsn, $retval);

    $port = 'smtp(25)' unless defined($port);

    # Add angle-brackets if needed
    if (!($sender =~ /^<.*>$/)) {
	$sender = "<$sender>";
    }

    if (!($recip =~ /^<.*>$/)) {
	$recip = "<$recip>";
    }

    my $sock = IO::Socket::INET->new(PeerAddr => $server,
				     PeerPort => $port,
				     Proto    => 'tcp',
				     Timeout  => 15);
    if (!defined($sock)) {
	return ('TEMPFAIL', "Could not connect to other SMTP server $server: $!");
    }

    ($retval, $code, $dsn, $text) = get_smtp_return_code($sock, $recip, $server);
    if ($retval ne 'CONTINUE') {
	$sock->print("QUIT\r\n");
	$sock->flush();
	# Swallow return value
	get_smtp_return_code($sock, $recip, $server);
	$sock->close();
	return ($retval, $text, $code, $dsn);
    }

    # If the banner contains our host name, there's a loop!
    # However, don't check if $server is explicitly 127.0.0.1
    # because presumably that indicates the caller knows
    # what he or she is doing.
    if ($server ne '127.0.0.1' && $server ne '::1') {
	    my $host_expr = quotemeta(get_host_name());
	    if ($text =~ /^$host_expr\b/) {
		    $sock->print("QUIT\r\n");
		    $sock->flush();
		    # Swallow return value
		    get_smtp_return_code($sock, $recip, $server);
		    $sock->close();
		    return('REJECT', "Verification server loop!  Trying to verify $recip against myself!",
			   554, '5.4.6');
	    }
    }

    $sock->print("HELO $helo\r\n");
    $sock->flush();

    ($retval, $code, $dsn, $text) = get_smtp_return_code($sock, $recip, $server);
    if ($retval ne 'CONTINUE') {
	$sock->print("QUIT\r\n");
	$sock->flush();
	# Swallow return value
	get_smtp_return_code($sock, $recip, $server);
	$sock->close();
	return ($retval, $text, $code, $dsn);
    }

    $sock->print("MAIL FROM:$sender\r\n");
    $sock->flush();

    ($retval, $code, $dsn, $text) = get_smtp_return_code($sock, $recip, $server);
    if ($retval ne 'CONTINUE') {
	$sock->print("QUIT\r\n");
	$sock->flush();
	# Swallow return value
	get_smtp_return_code($sock, $recip, $server);
	$sock->close();
	return ($retval, $text, $code, $dsn);
    }

    $sock->print("RCPT TO:$recip\r\n");
    $sock->flush();

    ($retval, $code, $dsn, $text) = get_smtp_return_code($sock, $recip, $server);
    $sock->print("QUIT\r\n");
    $sock->flush();
    # Swallow return value
    get_smtp_return_code($sock, $recip, $server);
    $sock->close();
    return ($retval, $text, $code, $dsn);
}

exit(&main) unless caller;
#------------------------------------------------------------
1;