#!/usr/local/bin/perl -w
# -*- Perl -*-
#***********************************************************************
#
# mimedefang.pl
#
# Perl scanner which parses MIME messages and filters or removes
# objectionable attachments.
#
# Copyright (C) 2000, 2001 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.
#
# $Id: mimedefang.pl.in,v 1.169 2002/05/31 16:38:38 dfs Exp $
#***********************************************************************

# MIME-Tools requires this?
require 5.001;

use vars qw($AddWarningsInline
	    $Action $Administrator $AdminName $AdminAddress
	    $Changed $DaemonAddress $DaemonName
	    $DefangCounter $Domain $EntireMessageQuarantined
	    $MessageID $Rebuild $QuarantineCount
	    $QuarantineDir $QuarantineSubdir $QueueID $MsgID
	    $RelayAddr $RelayHostname
	    $ReplacementEntity $Sender $ServerMode $Subject
	    $SuspiciousCharsInHeaders
	    $SuspiciousCharsInBody
	    $TerminateAndDiscard $URL $OpenAVHost
	    $VirusScannerMessages $WarningLocation $WasMultiPart $WorkDir
	    $NotifySenderSubject $NotifyAdministratorSubject
	    $QuarantineSubject $SALocalTestsOnly $NotifyNoPreamble
	    %Actions %Stupidity @FlatParts @Recipients @Warnings %Features);

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

use IO::Socket;
use MIME::Tools 5.410 ();
use MIME::Words qw(:all);
use Digest::SHA1;

# Detect SpamAssassin, HTMLCleaner and File::Scan at run-time...

(eval 'use Mail::SpamAssassin 1.6 (); $Features{"SpamAssassin"} = 1;')
    or $Features{"SpamAssassin"} = 0;

(eval 'use Anomy::HTMLCleaner; $Features{"HTMLCleaner"} = 1;')
    or $Features{"HTMLCleaner"} = 0;

(eval 'use File::Scan; $Features{"File::Scan"} = 1;')
    or $Features{"File::Scan"} = 0;
(eval 'use HTML::Parser; $Features{"HTML::Parser"} = 1;')
    or $Features{"HTML::Parser"} = 0;

undef $SASpamTester;
$Features{'Virus:FileScan'} = $Features{'File::Scan'};
$Features{'Virus:OpenAV'}   = 1;  # Not a good idea but we need a test!
$Features{'Virus:NAI'}      = ("/usr/local/bin/uvscan" ne "/bin/false" ? "/usr/local/bin/uvscan" : 0);
$Features{'Virus:HBEDV'}    = ("/bin/false" ne "/bin/false" ? "/bin/false" : 0);
$Features{'Virus:SOPHOS'}   = ("/usr/X11R6/bin/sweep" ne "/bin/false" ? "/usr/X11R6/bin/sweep" : 0);
$Features{'Virus:TREND'}   = ("/bin/false" ne "/bin/false" ? "/bin/false" : 0);
$Features{'Virus:AVP'}      = ("/bin/false" ne "/bin/false" ? "/bin/false" : 0);
$Features{'Virus:FSAV'}     = ("/bin/false" ne "/bin/false" ? "/bin/false" : 0);
$Features{'Virus:RAV'}      = ("/bin/false" ne "/bin/false" ? "/bin/false" : 0);
$Features{'Virus:FPROT'}     = ("/bin/false" ne "/bin/false" ? "/bin/false" : 0);


use strict;
# Sys::Syslog gives a bunch of warnings in strict mode on Linux...
use Sys::Syslog qw(:DEFAULT setlogsock);

# No stupidity yet
$Stupidity{"flatten"} = 0;

# Not in server mode by default
$ServerMode = 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;

# Location of binaries, filters, etc.
$QuarantineDir = "/var/spool/MIMEDefang";
use MIME::Parser;
use Getopt::Std;

$URL = 'http://www.roaringpenguin.com/mimedefang/enduser.php3';
$OpenAVHost = "127.0.0.1:8127";

package main;

package MIME::Parser::ParanoidFiler;

use vars qw(@ISA);
@ISA=qw(MIME::Parser::FileInto);

#***********************************************************************
# %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/([^\x20-\x7e]|[%\\'"])/sprintf("%%%02X", unpack("c", $1))/ge;
    #" Fix emacs highlighting...
    return $str;
}

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

#***********************************************************************
# %PROCEDURE: evil_filename
# %ARGUMENTS:
#  Ignored
# %RETURNS:
#  1
# %DESCRIPTION:
#  Forces MIME::Tools *not* to trust ANY filename supplied in the
#  mail message.
#***********************************************************************
sub evil_filename {
    return 1;
}

package main;

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

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

#***********************************************************************
# %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($disposition) = $in->head->mime_attr("Content-Disposition");
    my($body) = $in->bodyhandle;
    my($fname) = takeStabAtFilename($in);
    $fname = "" unless defined($fname);
    $fname =~ /(\.[^.]*)$/;
    my($extension) = $1;
    $extension = "" unless defined($extension);


    $disposition = "inline" unless defined($disposition);
    if (!defined($body)) {
	$Action = "accept";
	if (defined(&filter_multipart)) {
	    filter_multipart($in, $fname, $extension, $type);
	}
	if ($Action eq "drop") {
	    $Changed = 1;
	    return 0;
	}

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

	# Sigh... bug in MIME-Tools
	if (!($type =~ m{^multipart/})) {
	    $type = "multipart/mixed";
	}
	my($subentity) = MIME::Entity->build(Type => $type,
					     Disposition => $disposition);
	$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";

	filter($in, $fname, $extension, $type);

	# 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") {
	    $ReplacementEntity->head->mime_attr("Content-Disposition" => $disposition);
	    $Changed = 1;
	    $out->add_part($ReplacementEntity);
	    return 0;
	}

	# Otherwise, accept it
	$in->head->mime_attr("Content-Disposition" => $disposition);
	$out->add_part($in);
    }
}

#***********************************************************************
# %PROCEDURE: collect_parts
# %ARGUMENTS:
#  entity -- root entity to rebuild
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Adds parts to the array @FlatParts for flattening.
#***********************************************************************
sub collect_parts ($); # Forward declaration to stop warning
sub collect_parts ($) {
    my($entity) = @_;
    my(@parts) = $entity->parts;
    my($part);
    if ($#parts >= 0) {
	foreach $part (@parts) {
	    collect_parts($part);
	}
    } else {
	push(@FlatParts, $entity);
    }
}

#***********************************************************************
# %PROCEDURE: flatten_mime
# %ARGUMENTS:
#  entity -- root entity to rebuild
#  rebuilt -- empty entity in which rebuilt parts will be placed
# %RETURNS:
#  rebuilt part
# %DESCRIPTION:
#  Flattens the MIME message so nested parts appear simply as sequential
#  parts.
#***********************************************************************
sub flatten_mime ($$) {
    my($entity, $rebuilt) = @_;
    my($part);
    @FlatParts = ();
    collect_parts($entity);
    foreach $part (@FlatParts) {
	$rebuilt->add_part($part);
    }
    return $rebuilt;
}

#***********************************************************************
# %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 () {
    $Rebuild = 1;
}

#***********************************************************************
# %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:
#  Adds a new part to the message, possibly changing it to multipart.
#  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;

    $offset ||= -1;

    my ($part);

    $part = MIME::Entity->build(Type => $type,
				Encoding => $encoding,
				Data => ["$data"]);
    $part->head->mime_attr("Content-Type.name" => $fname);
    $part->head->mime_attr("Content-Disposition" => $disposition);
    $part->head->mime_attr("Content-Disposition.filename" => $fname);
    my $mtype = lc($entity->head->mime_type);

    if ($mtype ne "multipart/mixed") {
	print STDERR "Converting to multipart/mixed\n";
	$entity->make_multipart("mixed", Force=>1);
    }

    $entity->add_part($part, $offset);
    action_rebuild();
    return $part;
}

#***********************************************************************
# %PROCEDURE: print_mangled_header
# %ARGUMENTS:
#  header -- header name
#  value -- header value
#  fname -- file to append to
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Converts "\n" in value to "\\n\t" and appends header, value to fname
#***********************************************************************
sub print_mangled_header ($$$) {
    my($header, $value, $fname) = @_;
    my(@lines);
    my($thing);
    my($first) = 1;
    unless (open(HDRS, ">>$fname")) {
	syslog('err', "Could not open $fname to add or change headers: $!");
	return;
    }

    @lines = split("\n", $value);

    # Change newlines to "\n"; they'll be changed back by MIMEDefang
    print HDRS "$header\n";
    foreach $thing (@lines) {
	if (!$first) {
	    print HDRS "\\n\t";
	}
	$first = 0;
	print HDRS "$thing";
    }
    print HDRS "\n";
    close(HDRS);
}

#***********************************************************************
# %PROCEDURE: action_add_header
# %ARGUMENTS:
#  header -- header name (eg: X-My-Header)
#  value -- header value (eg: any text goes here)
#           If value contains newlines, multiple headers are added
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note for milter to add a header to the message.
#***********************************************************************
sub action_add_header ($$) {
    my($header, $value) = @_;
    print_mangled_header($header, $value, "NEWHEADERS");
}


#***********************************************************************
# %PROCEDURE: action_change_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 change a header in the message.
#***********************************************************************
sub action_change_header ($$) {
    my($header, $value) = @_;
    print_mangled_header($header, $value, "CHGHEADERS");
}

#***********************************************************************
# %PROCEDURE: action_accept
# %ARGUMENTS:
#  Ignored
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Makes a note to accept the current part.
#***********************************************************************
sub 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) = @_;
    $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 (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 () {
    $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) = @_;
    $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) = @_;
    $Actions{'replace_with_warning'}++;
    $Action = "replace";
    $ReplacementEntity = MIME::Entity->build(Type => "text/plain",
					     Encoding => "-suggest",
					     Data => [ "$msg\n" ]);
    return 1;
}

#***********************************************************************
# %PROCEDURE: action_replace_with_warning
# %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) = @_;
    $Actions{'defang'}++;
    my($head) = $entity->head;
    my($oldfname) = takeStabAtFilename($entity);
    my($oldname) = $head->mime_attr("Content-Type.name");
    my($oldtype) = $head->mime_type;

    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->mime_attr("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) = @_;

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

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

    unless(open(OUT, ">FILTERINPUT")) {
	syslog('err', "Could not open FILTERINPUT: $!");
	return(0);
    }

    if (defined($body->path)) {
	my($path) = $body->path;
	unless(open(IN, "<$path")) {
	    syslog('err', "Could not open body part $path: $!");
	    return(0);
	}
	my($n, $string);
	while(($n = read(IN, $string, 4096)) > 0) {
	    print OUT $string;
	}
    } else {
	# Can't handle bodies without paths.
	syslog('err', "Cannot filter body without a path");
	close(OUT);
	return 0;
    }
    close(OUT);
    close(IN);

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

    # Filter failed if non-zero exit
    if ($status % 255) {
	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)) {
	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) = @_;

    $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
    if (open(OUT, ">$QuarantineSubdir/PART.$QuarantineCount.BODY")) {
	my($path) = $body->path;
	if (open(IN, "<$path")) {
	    my($n, $string);
	    while(($n = read(IN, $string, 4096)) > 0) {
		print OUT $string;
	    }
	    close(IN);
	}
	close(OUT);
    }

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

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();
    do {
	$counter++;
	$QuarantineSubdir = sprintf("%s/qdir-%s-%03d",
				    $QuarantineDir, $tm, $counter);
	if (mkdir($QuarantineSubdir, 0700)) {
	    $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/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) = @_;
    # 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;
    }

    if (defined($msg) && ($msg ne "")) {
	push(@Warnings, "$msg\n");
	if (open(OUT, ">$QuarantineSubdir/MSG.0")) {
	    print OUT "$msg\n";
	    close(OUT);
	}
    }

    $EntireMessageQuarantined = 1;

    if (open(OUT, ">$QuarantineSubdir/ENTIRE_MESSAGE")) {
	if (open(IN, "<INPUTMSG")) {
	    while(<IN>) {
		print OUT;
	    }
	    close(IN);
	}
	close(OUT);
    }

    return 1;
}

#***********************************************************************
# %PROCEDURE: action_bounce
# %ARGUMENTS:
#  reply -- SMTP reply text (eg: "Not allowed, sorry")
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Causes the SMTP transaction to fail with an SMTP 554 failure code and the
#  specified reply text.
#***********************************************************************
sub action_bounce ($) {
    my($reply) = @_;
    if (open(FILE, ">BOUNCE")) {
	print FILE "$reply\n";
	close(FILE);
	$Actions{'bounce'}++;
	return 1;
    }
    syslog('err', "Could not create BOUNCE file: $!");
    return 0;
}

#***********************************************************************
# %PROCEDURE: action_discard
# %ARGUMENTS:
#  None
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Causes the entire message to be silently discarded without without
#  notifying anyone.
#***********************************************************************
sub action_discard () {
    if (open(FILE, ">DISCARD")) {
	close(FILE);
	$Actions{'discard'}++;
	return 1;
    }
    syslog('err', "Could not create DISCARD file: $!");
    return 0;
}

#***********************************************************************
# %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) = @_;
    if ($Sender eq '<>') {
	syslog('err', 'Skipped action_notify_sender: $Sender = <>');
	return 0;
    }

    if (open(FILE, ">>NOTIFICATION")) {
	print FILE $msg;
	close(FILE);
	$Actions{'notify_sender'}++;
	return 1;
    }
    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 (open(FILE, ">>ADMIN_NOTIFICATION")) {
	print FILE $msg;
	close(FILE);
	$Actions{'notify_administrator'}++;
	return 1;
    }
    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:
#  true if relay is blacklisted; false otherwise.
#***********************************************************************
sub relay_is_blacklisted ($$) {
    my($addr, $domain) = @_;
    # Reverse IP address
    my($a, $b, $c, $d) = split(/\./, $addr);
    $addr = "$d.$c.$b.$a.$domain";
    return (defined(gethostbyname($addr)));
}

#***********************************************************************
# %PROCEDURE: signal_unchanged
# %ARGUMENTS:
#  None
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Tells mimedefang C program message has not been altered.
#***********************************************************************
sub signal_unchanged () {
    open(FILE, ">UNCHANGED") && close(FILE);
}

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

#***********************************************************************
# %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 () {
    # If there are quarantined parts, e-mail a report
    if ($QuarantineCount > 0 || $EntireMessageQuarantined) {
	# Copy the NEWHEADERS file, if it exists
	if (open(IN, "<NEWHEADERS")) {
	    if (open(OUT, ">$QuarantineSubdir/NEWHEADERS")) {
		while(<IN>) {
		    chomp;
		    my $hname = $_;
		    my $val = <IN>;
		    print OUT "$hname: $val";
		}
		close(OUT);
	    }
	    close(IN);
	}
	my($body);
	$body = "From: $DaemonName <$DaemonAddress>\n";
	$body .= "To: \"$AdminName\" <$AdminAddress>\n";
	$body .= "Subject: $QuarantineSubject\n\n";
	$body .= "An e-mail had $QuarantineCount part";
	$body .= "s" if ($QuarantineCount != 1);
	$body .= " quarantined in the directory\n";
	$body .= "$QuarantineSubdir on the mail server.\n\n";
	$body .= "The sender was '$Sender'.\n\n" if defined($Sender);
	$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";
	}
	if (open(IN, "<$QuarantineSubdir/HEADERS")) {
	    $body .= "\n----------\nHere are the message headers:\n";
	    while(<IN>) {
		$body .= $_;
	    }
	    close(IN);
	}
	my($i);
	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);
    }

    # Send notification to sender, if required
    if ($Sender ne '<>' && -r "NOTIFICATION") {
	my($body);
	$body = "From: $DaemonName <$DaemonAddress>\n";
	$body .= "To: $Sender\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);
	$body = "From: $DaemonName <$DaemonAddress>\n";
	$body .= "To: \"$AdminName\" <$AdminAddress>\n";
	$body .= "Subject: $NotifyAdministratorSubject\n\n";
	if (open(FILE, "<ADMIN_NOTIFICATION")) {
	    while(<FILE>) {
		$body .= $_;
	    }
	    close(FILE);
	}
	send_mail($DaemonAddress, $DaemonName, $AdminAddress, $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 "") {
	$msg = "filter: $MsgID: " . $msg;
	syslog('info', $msg);
    }
    unlink("UNFINISHED");
    if ($ServerMode) {
	$| = 1;
	print "ok\n";
	$| = 0;
    }
}

#***********************************************************************
# %PROCEDURE: send_mail
# %ARGUMENTS:
#  fromAddr -- address of sender
#  fromFull -- full name of sender
#  recipient -- address of recipient
#  body -- mail message (including headers) newline-terminated
# %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) = @_;
    my($pid);

    # Fork and exec for safety instead of involving shell
    $pid = open(CHILD, "|-");
    if (!defined($pid)) {
	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 /dev/null
    open(STDOUT, ">/dev/null");

    my(@cmd);
    push(@cmd, "-f$fromAddr");
    push(@cmd, "-F$fromFull");
    push(@cmd, "-odi");
    push(@cmd, $recipient);

    # In curlies to silence Perl warning...
    { exec("/usr/local/sbin/sendmail", @cmd); }

    # exec failed!
    syslog('err', "Could not exec /usr/local/sbin/sendmail: $!");
    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 {
    my(@recips);
    @recips = @_;
    my($pid);

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

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

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

    # In the child -- invoke Sendmail
    my(@cmd);
    my($sender, $recip);
    # Remove angle-brackets from sender
    $sender = $Sender;
    $sender =~ s/[<>]//g;
    push(@cmd, "-f$sender");
    push(@cmd, "-odi");
    foreach $recip (@recips) {
	push(@cmd, $recip);
    }
    # In curlies to silence Perl warning...
    { exec("/usr/local/sbin/sendmail", @cmd); }

    # exec failed!
    syslog('err', "Could not exec /usr/local/sbin/sendmail: $!");
    exit(1);
    # NOTREACHED
}

#***********************************************************************
# %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);

    # 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) {
	    resend_message(@{$Domains{$key}});
	}
	$TerminateAndDiscard = 1;
	return 1;
    }

    return 0;
}

#***********************************************************************
# %PROCEDURE: takeStabAtFilename
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  A reasonable stab at a reasonable filename for the attachement.
#  Tries the "Content-Disposition.filename" field first;
#  tries "Content-Type.name" next;
#  tries "Content-Description" last.
# %DESCRIPTION:
#  Makes a desparate stab at guessing a filename for the attachment for
#  those STUPID BUGGY e-mail clients which make life difficult.
#***********************************************************************
sub takeStabAtFilename ($) {
    my($entity) = @_;
    my($head) = $entity->head;
    my($guess) = $head->mime_attr("Content-Disposition.filename");
    if (defined($guess)) {
	$guess = decode_mimewords($guess);
	return $guess;
    }
    $guess = $head->mime_attr("Content-Type.name");
    if (defined($guess)) {
	$guess = decode_mimewords($guess);
	return $guess;
    }
    $guess = $head->mime_attr("Content-Description");
    if (defined($guess)) {
	$guess = decode_mimewords($guess);
	return $guess;
    }
    return "";
}

#***********************************************************************
# %PROCEDURE: re_match
# %ARGUMENTS:
#  entity -- a MIME entity
#  regexp -- a regular expression
# %RETURNS:
#  1 if any of Content-Disposition.filename, Content-Type.name or
#  Content-Description 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;
    }

    $guess = $head->mime_attr("Content-Description");
    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 any of Content-Disposition.filename,
#  Content-Type.name or Content-Description 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);
	$guess =~ /(\.[^.]*)$/;
	$ext = $1;
	return 1 if (defined($ext) && $ext =~ /$regexp/i);
    }

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

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

    return 0;
}

#***********************************************************************
# %PROCEDURE: entity_contains_virus_filescan
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by File::Scan; 0 otherwise.
# %DESCRIPTION:
#  Scans the entity using the File::Scan module.
#***********************************************************************
sub entity_contains_virus_filescan ($) {

    unless ($Features{"Virus:FileScan"}) {
	syslog('err', 'Attempt to use File::Scan, but File::Scan is not installed.');
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Initialize scanner
    my $scanner = File::Scan->new();
    my ($msg) = "";

    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 File::Scan
    if ( my $virus = $scanner->scan($path) ) {
	# Virus Found
	$msg = "File::Scan found the '$virus' virus.";
	$VirusScannerMessages .= "$msg\n";
	return (wantarray ? (1, 'virus', 'quarantine') : 1);
    } elsif ( my $err = $scanner->error() ) {
	# Scanner error
	$msg = "Unable to execute File::Scan: $err";
	syslog('err', "entity_contains_virus_filescan: $msg");
	$VirusScannerMessages .= "$msg\n";
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    } elsif ( $scanner->skipped() ) {
	# File was skipped due to size, etc.
	# This occurs when it's not possible for a file to be infected
	# (eg, file is too small to contain any known virus)
	return (wantarray ? (0, 'ok', 'ok') : 0);
    } elsif ( $scanner->suspicious() ) {
	# No virus found, but File::Scan thinks it's suspicious
	$msg = "File::Scan reports this file is suspicious.";
	$VirusScannerMessages .= "$msg\n";
	return (wantarray ? (2, 'suspicious', 'quarantine') : 1);
    } else {
	# Entity is clean
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_filescan
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Scans the working directory using File::Scan module.
#***********************************************************************
sub message_contains_virus_filescan () {

    unless ($Features{"Virus:FileScan"}) {
	syslog('err', 'Attempt to use File::Scan, but File::Scan is not installed.');
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }

    # Initialize scanner
    my $scanner = File::Scan->new();
    my ($msg) = "";

    # Run antivir
    my $dir_path = './Work';

    # Used scan.pl from File::Scan distribution
    opendir(DIRHANDLE, $dir_path);
    for my $file (readdir(DIRHANDLE)) {
	next if ($file =~ /^\./);
	my $fn = "$dir_path/$file";
	my $virus = $scanner->scan($fn);
	if ($virus || $scanner->suspicious) {
	    # Found a virus or suspicious file, so
	    # status of remaining files is moot
	    closedir(DIRHANDLE);
	    if ($virus) {
		$msg = "File::Scan found the '$virus' virus.";
		$VirusScannerMessages .= "$msg\n";
		return (wantarray ? (1, 'virus', 'quarantine') : 1);
	    } else {
		$msg = "File::Scan reports a suspicious attachment.";
		$VirusScannerMessages .= "$msg\n";
		return (wantarray ? (2, 'suspicious', 'quarantine') : 1);
	    }
	} elsif ( my $err = $scanner->error() ) {
	    # Scanner error
	    closedir(DIRHANDLE);
	    $msg = "Unable to execute File::Scan: $err";
	    syslog('err', "message_contains_virus_filescan: $msg");
	    $VirusScannerMessages .= "$msg\n";
	    return (wantarray ? (999, 'swerr', 'tempfail') : 1);
	}
    }
    closedir(DIRHANDLE);
    return (wantarray ? (0, 'ok', 'ok') : 0);
}

#***********************************************************************
# %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'}) {
	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'} . " --noboot --secure --allole $path 2>&1");
    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'}) {
	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 --allole ./Work 2>&1");
    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
    return ($code, 'virus', 'quarantine') if ($code == 13);

    # 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_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'}) {
	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 $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'}) {
	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 ./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
    return ($code, 'virus', 'quarantine') if ($code == 3);

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

    # Virus removed
    return ($code, 'virus', 'quarantine') if ($code == 6);

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

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

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

#***********************************************************************
# %PROCEDURE: entity_contains_virus_openantivirus
# %ARGUMENTS:
#  entity -- a MIME entity
#  host (optional) -- OpenAntiVirus host:port
# %RETURNS:
#  1 if entity contains a virus as reported by Open Antivirus
# %DESCRIPTION:
#  Invokes the Open Antivirus daemon (http://www.openantivirus.org/) on
#  the entity.
#***********************************************************************
sub entity_contains_virus_openantivirus ($;$) {
    my ($entity) = shift;
    my ($host) = $OpenAVHost;
    $host = shift if (@_ > 0);
    $host = '127.0.0.1:8127' if (!defined($host));

    my $sock = IO::Socket::INET->new($host);
    if (!defined($entity->bodyhandle)) {
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    if (!defined($entity->bodyhandle->path)) {
	return (wantarray ? (999, 'swerr', 'tempfail') : 1);
    }
    if (defined $sock) {
	my($cwd);
	chomp($cwd = `pwd`);
	my $path = $entity->bodyhandle->path;
	# If path is not absolute, add cwd
	if (! ($path =~ m+^/+)) {
	    $path = $cwd . "/" . $path;
	}
	$sock->print("SCAN $path\n");
	$sock->flush;
	my($output);
	chomp($output = $sock->getline);
	$sock->close;
	if ($output =~ /^FOUND: /) {
	    $VirusScannerMessages .= "$output\n";
	    return (wantarray ? (1, 'virus', 'quarantine') : 1);
	}
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }

    # Could not connect to daemon
    syslog('err', "Could not connect to OpenAntiVirus Daemon at $host");
    return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}

#***********************************************************************
# %PROCEDURE: message_contains_virus_openantivirus
# %ARGUMENTS:
#  Nothing
# %RETURNS:
#  1 if any file in the working directory contains a virus
# %DESCRIPTION:
#  Invokes the Open Antivirus daemon (http://www.openantivirus.org/) on
#  the entire message.
#***********************************************************************
sub message_contains_virus_openantivirus (;$) {
    my ($host) = $OpenAVHost;
    $host = shift if (@_ > 0);
    $host = '127.0.0.1:8127' if (!defined($host));
    my $sock = IO::Socket::INET->new($host);
    if (defined $sock) {
	my($cwd);
	chomp($cwd = `pwd`);
	$sock->print("SCAN $cwd/Work\n");
	$sock->flush;
	my($output);
	chomp($output = $sock->getline);
	$sock->close;
	if ($output =~ /^FOUND: /) {
	    $VirusScannerMessages .= "$output\n";
	    return (wantarray ? (1, 'virus', 'quarantine') : 1);
	}
	return (wantarray ? (0, 'ok', 'ok') : 0);
    }
    # Could not connect to daemon
    syslog('err', "Could not connect to OpenAntiVirus Daemon at $host");
    return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}

#***********************************************************************
# %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'}) {
	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 -q -rs $path 2>&1");
    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'}) {
	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 -q -rs ./Work 2>&1");
    return (wantarray ? interpret_hbedv_code($code) : $code);
}

sub interpret_hbedv_code ($) {
    # Based on info from Nels Lindquist
    my($code) = @_;

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

    # Virus
    return ($code, 'virus', 'quarantine') if ($code == 1);

    # Virus in memory??
    return ($code, 'virus', 'quarantine') if ($code == 2);

    # 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'}) {
	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 -all -archive -ss $path 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_sweep_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'}) {
	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 -all -archive -ss ./Work 2>&1");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : $code);
    }
    return (wantarray ? interpret_sweep_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);

    # Error
    return ($code, 'swerr', 'tempfail') if ($code == 2);

    # Virus
    return ($code, 'virus', 'quarantine') if ($code == 3);

    # Unknown code
    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'}) {
	syslog('err', "AVP AvpLinux 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:AVP'} . " -Y -O- -K -I0 $path 2>&1");
    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'}) {
	syslog('err', "AVP AvpLinux not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run antivir
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:AVP'} . " -Y -O- -K -I0 ./Work 2>&1");
    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"
    return ($code, 'virus', 'quarantine') if ($code == 2);

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

    # virus found
    return ($code, 'virus', 'quarantine') if ($code == 4);

    # 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
    return ($code, 'suspicious', 'quarantine') if ($code == 8);

    # 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.fprot.com)
#***********************************************************************
sub entity_contains_virus_fprot ($) {
    unless ($Features{'Virus:FPROT'}) {
	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'}) {
	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
    return ($code, 'virus', 'quarantine') if ($code == 3);

    # 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_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'}) {
	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'} . " -a $path 2>&1");
    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'}) {
	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'} . " -a ./Work/* 2>&1");
    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
    return ($code, 'virus', 'quarantine') if ( ($code == 2) || ($code == 1));

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

#***********************************************************************
# %PROCEDURE: entity_contains_virus_rav
# %ARGUMENTS:
#  entity -- a MIME entity
# %RETURNS:
#  1 if entity contains a virus as reported by Reliable Antivirus (RAV)
# %DESCRIPTION:
#  Runs the RAV Anti-Virus program. (http://www.ravantivirus.com)
#***********************************************************************
sub entity_contains_virus_rav ($) {

    unless($Features{'Virus:RAV'}) {
	syslog('err', "Reliable AntiVirus (RAV) 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 rav
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:RAV'} . " -A -H on -I on $path 2>&1 < /dev/tty0");
    if ($action ne 'proceed') {
	return (wantarray ? ($code, $category, $action) : ($code==2 || $code==3));
    }

    # rav return codes
    return (wantarray ? interpret_rav_code($code) : ($code==2 || $code==3));
}

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

    unless($Features{'Virus:RAV'}) {
	syslog('err', "Reliable AntiVirus (RAV) not installed on this system");
	return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
    }

    # Run rav
    my($code, $category, $action) =
	run_virus_scanner($Features{'Virus:RAV'} . " -A -M -H on -I on ./Work 2>&1 < /dev/tty0");

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

sub interpret_rav_code ($) {

    my($code) = shift;

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

    # Found a virus
    return ($code, 'virus', 'quarantine') if ($code == 2);

    # Suspicious file
    return ($code, 'suspicious', 'quarantine') if ($code == 3);

    # Engine error
    return ($code, 'swerr', 'tmpfail') if ($code == 30);

    # Syntax error
    return ($code, 'swerr', 'tempfail') if ($code == 31);

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

#***********************************************************************
# %PROCEDURE: run_virus_scanner
# %ARGUMENTS:
#  cmdline -- command to run
# %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) = @_;
    my($retcode);
    my($msg) = "";
    unless (open(SCANNER, "$cmd |")) {
	$msg = "Unable to execute $cmd: $!";
	syslog('err', "run_virus_scanner: $msg");
	$VirusScannerMessages .= "$msg\n";
	return (999, 'cannot-execute', 'tempfail');
    }
    while(<SCANNER>) {
	$msg .= $_;
    }
    close(SCANNER);
    $VirusScannerMessages .= $msg;
    $retcode = $? / 256;
    return ($retcode, 'ok', 'proceed');
}

#***********************************************************************
# %PROCEDURE: action_tempfail
# %ARGUMENTS:
#  msg -- the message to include
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Tempfails the message with a 4.x.x SMTP code.
#***********************************************************************
sub action_tempfail ($) {
    my($msg) = @_;
    $msg = "" unless defined($msg);
    if (open(FILE, ">TEMPFAIL")) {
	print FILE "$msg\n";
	close(FILE);
	$Actions{'tempfail'}++;
	return 1;
    }
    syslog('err', "Could not create TEMPFAIL file: $!");
    return 0;
}


#***********************************************************************
# %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);
    $Filter = '/usr/local/etc/mimedefang/mimedefang-filter';

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

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

    # Load the filter
    require $Filter;

    # Backward-compatibility
    if (defined($Administrator)) {
	$AdminAddress = $Administrator;
	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 "-structure") {
	# Parse message on stdin; print structure
	print_message_structure();
	exit(0);
    }
    if ($WorkDir eq "-features") {
	# Print available features
	my($thing, $ans);

	# 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") {
		    print "$thing: yes ($feat)\n";
		} else {
		    print "$thing: yes\n";
		}
	    }
	}

	# 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") {
		print "$thing: no\n";
	    }
	}
	exit(0);
    }

    if ($WorkDir eq "-server") {
	$ServerMode = 1;
    } else {
	$ServerMode = 0;
    }

    # Do logging
    setlogsock('unix');
    openlog("mimedefang.pl", "pid", "mail");

    if (!$ServerMode) {
	serverloop($WorkDir);
	exit(0);
    }

    # Infinite server loop
    while(<STDIN>) {
	chomp;
	if ($_ =~ /^scan (.*)$/) {
	    $WorkDir = $1;
	    serverloop($WorkDir);
	    next;
	}
	if ($_ =~ /^relayok (\S*)\s+(\S*)/) {
	    $ip = $1;
	    $name = $2;
	    relay_ok($ip, $name);
	    next;
	}
	if ($_ =~ /^senderok (\S*)/) {
	    $sender = $1;
	    sender_ok($sender);
	    next;
	}
	$| = 1;
	print "error: Unknown command $_\n";
	$| = 0;
    }
}

#***********************************************************************
# %PROCEDURE: serverloop
# %ARGUMENTS:
#  workdir -- working directory to scan
# %RETURNS:
#  0 if parse went well; non-zero otherwise.
# %DESCRIPTION:
#  Main loop.
#***********************************************************************
sub serverloop ($) {
    my($WorkDir) = @_;

    # Initialize globals on each pass of server loop.
    $Action = "";
    $Changed = 0;
    $DefangCounter = 0;
    $Domain = "";
    $MsgID = "";
    $MessageID = "";
    $QueueID = "";
    $QuarantineCount = 0;
    $Rebuild = 0;
    $EntireMessageQuarantined = 0;
    $QuarantineSubdir = "";
    $RelayAddr = "";
    $RelayHostname = "";
    $Sender = "";
    $Subject = "";
    $SuspiciousCharsInHeaders = 0;
    $SuspiciousCharsInBody = 0;
    $TerminateAndDiscard = 0;
    $VirusScannerMessages = "";
    $WasMultiPart = 0;
    undef %Actions;
    undef @FlatParts;
    undef @Recipients;
    undef @Warnings;

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

    if (open(IN, "<SENDER")) {
	$Sender = <IN>;
	chomp $Sender;
	close(IN);
    }

    if (open(IN, "<HOSTIP")) {
	$RelayAddr = <IN>;
	chomp($RelayAddr);
	close(IN);
    }

    if (open(IN, "<HOSTNAME")) {
	$RelayHostname = <IN>;
	chomp($RelayHostname);
	close(IN);
    }

    if (open(IN, "<RECIPIENTS")) {
	while(<IN>) {
	    chomp;
	    push(@Recipients, $_);
	}
	close(IN);
    }

    if (open(HDRS, "<HEADERS")) {
	while(<HDRS>) {
	    chomp;
	    if (/^Message-ID:\s*(\S+)/i) {
		$MessageID = $1;
	    }
	    if (/^Subject:\s*(\S.*)$/i) {
		$Subject = $1;
	    }
	}
	close(HDRS);
    }
    if (open(IN, "<QUEUEID")) {
	$QueueID = <IN>;
	chomp($QueueID);
	close(IN);
    }

    # Set message ID
    if ($QueueID ne "") {
	$MsgID = $QueueID;
    } elsif ($MessageID ne "") {
	$MsgID = $MessageID;
    } else {
	$MsgID = "<No-Message-ID>";
    }

    if ($QueueID eq "") {
	$QueueID = "<No-Queue-ID>";
    }
    if ($MessageID eq "") {
	$MessageID = "<No-Message-ID>";
    }

    # Suspicious chars in headers?
    if (-f 'SUSPICIOUS-CHARS-IN-HEADERS') {
	$SuspiciousCharsInHeaders = 1;
    }

    # Suspicious chars in body?
    if (-f 'SUSPICIOUS-CHARS-IN-BODY') {
	$SuspiciousCharsInHeaders = 1;
    }

    my($file) = "INPUTMSG";

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

    my $entity;

    my $parser = new MIME::Parser;
    my $filer = new MIME::Parser::ParanoidFiler($msgdir);
    $parser->filer($filer);

    $parser->extract_nested_messages(1);
    $parser->extract_uuencode(1);

    # Don't put stuff in memory.
    $parser->output_to_core(0);
    $parser->tmp_to_core(0);

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

    $entity = $parser->parse(\*FILE);
    close FILE;
    if (!$entity) {
	fatal("$MsgID: Couldn't parse MIME in $file: $!");
	return -1;
    }

    my($boundary) = $entity->head->multipart_boundary;

    # Now rebuild the message!

    my($rebuilt);
    my($rebuilt_flat);
    my($multipart_type);

    # Pick a sensible multipart type.
    $multipart_type = $entity->head->mime_type;
    if ($multipart_type ne "multipart/alternative" &&
	$multipart_type ne "multipart/digest") {
	$multipart_type = "multipart/mixed";
    }

    if (defined($boundary)) {
	$rebuilt = MIME::Entity->build(Type        => $multipart_type,
				       Boundary    => $boundary);
    } else {
	$rebuilt = MIME::Entity->build(Type        => $multipart_type);
    }

    # Don't add levels of parts if top-level is multipart already
    my($code) = $entity->make_multipart();
    if ($code eq 'ALREADY') {
	$WasMultiPart = 1;
    } else {
	$WasMultiPart = 0;
    }

    # Call pre-scan filter if defined
    if (defined(&filter_begin)) {
	filter_begin();
    }

    # If not in server mode, check relay
    if (!$ServerMode) {
	if (defined(&filter_relay)) {
	    my($result, $msg);
	    ($result, $msg) = filter_relay($RelayAddr, $RelayHostname);
	    if (!$result) {
		action_bounce($msg);
		signal_unchanged();
		signal_complete();
		syslog('info', "$RelayAddr ($RelayHostname) rejected by filter_relay");
		return;
	    }
	}
    }

    # If stream_by_domain tells us to discard, do so...
    if ($TerminateAndDiscard) {
	signal_unchanged();
	open(FILE, ">DISCARD") and close(FILE);
	syslog('info', "$MsgID streamed by domain and resent.");
	signal_complete();
	return;
    }

    # Rebuild
    if (!defined($entity->bodyhandle)) {
	map { rebuild_entity($rebuilt, $_) } $entity->parts;
    } else {
	rebuild_entity($rebuilt, $entity);
    }

    if ($#Warnings >= 0) {
	my $didSomething = 0;
	$rebuilt->make_multipart();
	$Changed = 1;
	if ($AddWarningsInline) {
	    my $warning = $GeneralWarning . join("\n", @Warnings);
	    my $ruler = "=" x 75;
	    $didSomething = 1
		if append_text_boilerplate($rebuilt, "$ruler\n$warning", 0);
	    $didSomething = 1
		if append_html_boilerplate($rebuilt, "<hr>\n<pre>\n$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);
	    action_add_part($rebuilt, "text/plain", "-suggest",
			    $warns, "WARNING.TXT", "inline", $WarningLocation);
	}
    }

    # Call post-scan filter if defined
    if (defined(&filter_end)) {
	filter_end($rebuilt);
    }

    if ($Changed || $Rebuild) {
	if (!open(OUT, ">NEWBODY")) {
	    fatal("$MsgID: Can't open NEWBODY: $!");
	    return -1;
	}
	# Pick a sensible multipart type.
	$multipart_type = $rebuilt->head->mime_type;
	if ($multipart_type ne "multipart/alternative" &&
	    $multipart_type ne "multipart/digest") {
	    $multipart_type = "multipart/mixed";
	}

	if ($Stupidity{"flatten"}) {
	    if (defined($boundary)) {
		$rebuilt_flat = MIME::Entity->build(Type        => $multipart_type,
						    Boundary    => $boundary);
	    } else {
		$rebuilt_flat = MIME::Entity->build(Type        => $multipart_type);
	    }

	    flatten_mime($rebuilt, $rebuilt_flat);

	    $rebuilt_flat->print_body(\*OUT);
	    $rebuilt = $rebuilt_flat;
	} else {
	    $rebuilt->print_body(\*OUT);
	}
	close(OUT);

	# Write new content-type header -- required for messages which
	# are not originally multipart!
	if (!open(OUT, ">CONTENT-TYPE")) {
	    fatal("$MsgID: Can't open CONTENT-TYPE: $!");
	    return -1;
	}
	my($boundary) = $rebuilt->head->multipart_boundary;
	print OUT "$multipart_type; boundary=\"$boundary\"\n";
	close(OUT);
	signal_changed();
    } else {
	signal_unchanged();
    }

    signal_complete();
    return 0;
}

#***********************************************************************
# %PROCEDURE: find_part
# %ARGUMENTS:
#  entity -- root MIME part
#  content_type -- desired MIME content type
# %RETURNS:
#  First MIME entity of type "$content_type"; undef if none exists.
#***********************************************************************
sub find_part ($$); # Forward declaration to stop warning
sub find_part ($$) {
    my($entity, $content_type) = @_;
    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;
	}
    }

    @parts = $entity->parts;
    foreach $part (@parts) {
	$ans = find_part($part, $content_type);
	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"}) {
	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(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_boilerplate
# %ARGUMENTS:
#  msg -- root MIME part of e-mail message.
#  boilerplate -- text to append
# %RETURNS:
#  1 on success; 0 on failure
# %DESCRIPTION:
#  Appends "$boilerplate" to first text/plain or text/html part in the
#  message.
#***********************************************************************
sub append_boilerplate ($$) {
    my($msg, $boilerplate) = @_;
    my($part);
    $part = find_part($msg, "text/plain");
    if (!defined($part)) {
	$boilerplate = "<PRE>\n$boilerplate</PRE>";
	$part = find_part($msg, "text/html");
	return 0 unless (defined($part));
    }

    if (append_to_part($part, $boilerplate)) {
	$Changed = 1;
	$Actions{'append_boilerplate'}++;
	return 1;
    }
    return 0;
}

#***********************************************************************
# %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");
	if (defined($part)) {
	    if (append_to_part($part, $boilerplate)) {
		$Actions{'append_text_boilerplate'}++;
		return 1;
	    }
	}
	return 0;
    }
    @FlatParts = ();
    my($ok) = 0;
    collect_parts($msg);
    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");
	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);
    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.
# %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) = @_;
    my($ctx);
    my($path);
    my($fname, $ext, $name, $url);

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

    $ctx = Digest::SHA1->new;
    $ctx->addfile(*IN);
    close(IN);

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

    # 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 {
	open(IN, "<$path") or return 0;
	open(OUT, ">$fname") or (close(IN), return 0);
	while(<IN>) {
	    print OUT;
	}
	close(IN);
	close(OUT);
	# In case umask is whacked...
	chmod 0644, $fname;
    }
    $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) = @_;
    open(OUT, ">>NEWRCPTS") or return 0;
    print OUT "$recip\n";
    close(OUT);
    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) = @_;
    open(OUT, ">>DELRCPTS") or return 0;
    print OUT "$recip\n";
    close(OUT);
    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;

    return $object->check($mail);
}

#***********************************************************************
# %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 (;$) {

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

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

	$SASpamTester = Mail::SpamAssassin->new({
	    local_tests_only   => $SALocalTestsOnly,
	    dont_copy_prefs    => 1,
	    userprefs_filename => $config});
    }

    return $SASpamTester;
}

#***********************************************************************
# %PROCEDURE: spam_assassin_mail
# %ARGUMENTS:
#  none
# %RETURNS:
#  A Mail::SpamAssassin:NoMailAudit object.
# %DESCRIPTION:
#  Scans message using SpamAssassin (http://www.spamassassin.org)
#***********************************************************************
sub spam_assassin_mail (;$) {

    unless ($Features{"SpamAssassin"}) {
	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);

    return Mail::SpamAssassin::NoMailAudit->new(data=>\@msg);
}

#***********************************************************************
# %PROCEDURE: anomy_clean_html
# %ARGUMENTS:
#  entity -- entity to clean.  Assumed to be of type text/html
#  hash -- hash of arguments for HTML sanitizer constructor
# %RETURNS:
#  0 on failure; 1 on success
# %DESCRIPTION:
#  Uses the Anomy Sanitiers HTMLCleaner to sanitize HTML
#  See http://mailtools.anomy.net/
#***********************************************************************
sub anomy_clean_html {
    my($entity, $hash);
    $entity = shift;
    $hash = shift;

    unless ($Features{"HTMLCleaner"}) {
	syslog('err', 'Attempt to call anomy_clean_html, but Anomy::HTMLCleaner is not installed.');
	return 0;
    }

    if (!$hash) {
	$hash = { };
	$hash->{"Paranoid"} = 1;
	$hash->{"NoWebBugs"} = 1;
    }

    my $cleaner = new Anomy::HTMLCleaner $hash;
    my $t;
    my $l = "";
    return 0 unless defined($entity->bodyhandle);
    my $path = $entity->bodyhandle->path;
    return 0 unless defined("$path");
    unless(open(IN, "<$path")) {
	syslog('err', "anomy_clean_html: Could not open body part $path: $!");
	return(0);
    }
    unless(open(OUT, ">$path.new")) {
	close(IN);
	syslog('err', "anomy_clean_html: Could not open output part $path.new: $!");
	return(0);
    }

    while ($t = $l . <IN>) {
	$l = $cleaner->clean(\$t);
	print OUT $t;
    }
    close(IN);
    close(OUT);
    unless (rename("$path.new", "$path")) {
	syslog('err', "anomy_clean_html: Could not rename $path.new to $path: $!");
	return(0);
    }
    $Changed = 1;
    return(1);
}

#***********************************************************************
# %PROCEDURE: relay_ok
# %ARGUMENTS:
#  hostip -- IP address of relay host
#  hostname -- name of relay host
# %RETURNS:
#  Nothing, but prints "ok 1" if we accept connection, "ok 0" if not.
#***********************************************************************
sub relay_ok ($$) {
    my($hostip, $hostname) = @_;
    if (!defined(&filter_relay)) {
	$| = 1;
	print "ok 1\n";
	$| = 0;
	return;
    }

    my($ok, $msg) = filter_relay($hostip, $hostname);
    if ($ok) {
	$| = 1;
	print "ok 1\n";
	$| = 0;
	return;
    }
    syslog('info', "$hostip ($hostname) rejected by filter_relay");
    if ($msg ne "") {
	$| = 1;
	print "ok 0 $msg\n";
	$| = 0;
	return;
    }
    $| = 1;
    print "ok 0\n";
    $| = 0;
    return;
}

#***********************************************************************
# %PROCEDURE: sender_ok
# %ARGUMENTS:
#  sender -- e-mail address of sender
# %RETURNS:
#  Nothing, but prints "ok 1" if we accept message from this sender,
# "ok 0" if not.
#***********************************************************************
sub sender_ok ($) {
    my($sender) = @_;
    if (!defined(&filter_sender)) {
	$| = 1;
	print "ok 1\n";
	$| = 0;
	return;
    }

    my($ok, $msg) = filter_sender($sender);
    if ($ok) {
	$| = 1;
	print "ok 1\n";
	$| = 0;
	return;
    }
    syslog('info', "$sender rejected by filter_sender");
    if ($msg ne "") {
	$| = 1;
	print "ok 0 $msg\n";
	$| = 0;
	return;
    }
    $| = 1;
    print "ok 0\n";
    $| = 0;
    return;
}

#***********************************************************************
# %PROCEDURE: print_message_structure
# %ARGUMENTS:
#  None
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  A debugging procedure.  Parses message from stdin; prints MIME structure.
#***********************************************************************
sub print_message_structure () {
    my $parser = new MIME::Parser;
    my $filer = new MIME::Parser::ParanoidFiler("./Work");
    mkdir("./Work", 0700);
    #MIME::Tools->debugging(1);
    $parser->filer($filer);

    $parser->extract_nested_messages(1);
    $parser->extract_uuencode(1);

    # Don't put stuff in memory.
    $parser->output_to_core(0);
    $parser->tmp_to_core(0);

    # Parse the input stream:
    my($entity);
    $entity = $parser->parse(\*STDIN);
    if (!$entity) {
	print STDERR "Could not parse MIME: $!";
	exit(1);
    }
    print_entity_structure($entity, 0);
    exit(0);
}

sub print_entity_structure ($$) {
    my($in, $level) = @_;
    my($type) = $in->mime_type;
    my @parts = $in->parts;
    $type =~ tr/A-Z/a-z/;
    my($disposition) = $in->head->mime_attr("Content-Disposition");
    my($body) = $in->bodyhandle;
    my($fname) = takeStabAtFilename($in);
    $fname = "" unless defined($fname);
    $fname =~ /(\.[^.]*)$/;
    my($extension) = $1;
    $extension = "" unless defined($extension);
    $disposition = "inline" unless defined($disposition);

    print "    " x $level;
    if (!defined($body)) {
	print "non-leaf: type=$type; fname=$fname; disp=$disposition\n";
	map { print_entity_structure($_, $level+1) } @parts;
    } else {
	print "leaf: type=$type; fname=$fname; disp=$disposition\n";
    }
}

exit(&main);
#------------------------------------------------------------
1;
