#
# Procmail Sanitizer perl script
# (C) 2002 John D. Hardin <jhardin@impsec.org>
# License: GPL
# Contact author for commercial licensing
# $Id: sanitizer.pl,v 0.46 2002-01-13 14:25:14-08 jhardin Exp jhardin $

use File::MkTemp;

# MIME support
use MIME::QuotedPrint;
use MIME::Base64;

# i18n and l10n support
use POSIX;
use Locale::PGetText;

sub initialize {
	my ($junk,$sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst);

	if (setlocale(LC_CTIME) ne "C") {
		warn "Setting locale to \"", setlocale(LC_CTIME), "\"\n" if $dbg;
		Locale::PGetText::setLocaleDir("/opt/sanitizer/locale");
		Locale::PGetText::setLanguage(setlocale(LC_CTIME));
	}

	$HOST = $ENV{"HOST"};		# assume procmail environment
	$TEMP = $ENV{"TMPDIR"} || "/tmp";
	$dbgv = $ENV{"DEBUG_VERBOSE"};
	$dbg = $dbgv || $ENV{"DEBUG"};
	# maximum size of encoded in-memory body part
	$MAX_BP_SZ = ($ENV{"MAX_BP_SZ"} * 1) || (128 * 1024);

	$INFO = gettext("INFO:");
	$CONF = gettext("CONF:");
	$WARN = gettext("WARN:");
	$FATAL = gettext("FATAL:");

	$DEFANG = gettext("DEFANGED");
	die "$CONF ", gettext("dangerous characters in localized string"), " \"DEFANGED\"\n" if $DEFANG =~ /[^-0-9a-zA-Z_]/;
	$DEFANG = sprintf("%05d-%s.txt", $$, $DEFANG);

	unless ($HOST) {
		warn "$CONF \$HOST ", gettext("not set in environment"), "\n";
		$HOST = $ENV{"HOSTNAME"} || `hostname`;
	}
	$SANHDR = "X-Content-Security: [${HOST}] ";

	$CHARSET = $ENV{"CHARSET"} || "ISO-8859-1";

	$default_policy = "SD";		# fail securely - strip and discard
	umask(0007);

	# zero out arrays
	@boundariestoolong =
	@gotboundaries =
	@mimeboundaries =
	@newboundaries =
	@nullboundaries =
	@rawboundaries =
	@Policy =
	%RFC822maxlen =
	@Headers = 
	@MsgLog = ();


	# Do we have a quarantine mailbox?
	if ($Qbox = $ENV{"SECURITY_QUARANTINE"}) {
		$Qbox =~ s/(^\s+|\s+$)//g;
		die "$CONF \$SECURITY_QUARANTINE ", gettext("is not valid if relative"), "\n" if $Qbox !~ /^\//;
		if (-e $Qbox) {
			die "$CONF \$SECURITY_QUARANTINE=\"$Qbox\": ", gettext("not a file or directory"), "\n" unless -f $Qbox || -d $Qbox;
			die "$CONF \$SECURITY_QUARANTINE=\"$Qbox\": ", gettext("not writable"), "\n" unless -w $Qbox;
		}
	}

	# Do we have a quarantine directory?
	if ($Qdir = $ENV{"SECURITY_QUARANTINE_DIR"}) {
		$Qdir =~ s/(^\s+|\s+$)//g;
		die "$CONF \$SECURITY_QUARANTINE_DIR ", gettext("is not valid if relative"), "\n" if $Qdir !~ /^\//;
		$Qdir =~ s/\/$// if $Qdir ne "/";
		die "$CONF \$SECURITY_QUARANTINE_DIR=\"$Qdir\": ", gettext("not a directory"), "\n" unless -d $Qdir;
		die "$CONF \$SECURITY_QUARANTINE_DIR=\"$Qdir\": ", gettext("not writable"), "\n" unless -w $Qdir;
		$default_policy = "SQ";		# fail securely - strip and quarantine
		($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
		$Qtemplate = sprintf("%04d%02d%02d:%02d%02d-%05d-", $year + 1900, $mon + 1, $mday, $hour, $min, $$);
	}

	# Do we have a filename log?
	if ($Flog = $ENV{"SECURITY_FILENAME_LOG"}) {
		$Flog =~ s/(^\s+|\s+$)//g;
		die "$CONF \$SECURITY_FILENAME_LOG ", gettext("is not valid if relative"), "\n" if $Flog !~ /^\//;
		if (-e $Flog) {
			die "$CONF \$SECURITY_FILENAME_LOG=\"$Flog\": ", gettext("not a file"), "\n" unless -f $Flog;
			die "$CONF \$SECURITY_FILENAME_LOG=\"$Flog\": ", gettext("not writable"), "\n" unless -w $Flog;
		}
		$default_policy .= "L";
	}

	# Do we have a policy files directory?
	if ($Pdir = $ENV{"SECURITY_POLICY_DIR"}) {
		$Pdir =~ s/(^\s+|\s+$)//g;
		die "$CONF \$SECURITY_POLICY_DIR ", gettext("is not valid if relative"), "\n" if $Pdir !~ /^\//;
		$Pdir =~ s/\/$// if $Pdir ne "/";
		die "$CONF \$SECURITY_POLICY_DIR=\"$Pdir\": ", gettext("not a directory"), "\n" unless -d $Pdir;
		die "$CONF \$SECURITY_POLICY_DIR=\"$Pdir\": ", gettext("not readable"), "\n" unless -r $Pdir;
	}
}

sub readpolicy {
	# Read the attachment security policy and header max length files
	# Create the Policy and RFC822maxlen arrays
	# TODO compile and save the policy rather than parsing it every time
	my($list, $dir, $file, $glob, $policy, $header, $maxlen);

	unless (@Policy) {	# read it only once
		warn "$INFO ", gettext("reading attachment policies"), "\n" if $dbg;
		if ($list = $ENV{"SECURITY_POLICY"}) {
			foreach $file (split(/:/, $list)) {
				$file =~ s/^((\s+)|(\.+\/))+//;
				$file =~ s/\s+$//;
				next unless $file;
				unless ($file =~ /^\//) {
					die "$CONF \$SECURITY_POLICY_DIR ", gettext("not given, cannot find"), " $file\n" unless $Pdir;
					$file = "${Pdir}/${file}";
				}
				warn "$INFO ", gettext("policy"), " $file\n" if $dbg;
				if (open(POLICY,"<$file")) {
					while (<POLICY>) {
						s/#.*//;	# no hashes in filenames!
						if (($glob, $policy) = /^\s*(\S+)\s+(\S+)/) {
							$policy =~ s/^([a-np-z]*)O/$1/ig;	# ignore O, we know better
							unless ($policy =~ /^[b-z]*[AMSP]/i) {
								warn "$CONF ", gettext("no valid primary policy in"), " \"$policy\"\n";
								warn "$CONF ...file $file, glob $glob\n";
								warn "$CONF ...", gettext("defaulting to"), " $default_policy\n";
								$policy = $default_policy;
							}
							die "$CONF \$SECURITY_QUARANTINE_DIR ", gettext("not given"), "\n" if $policy =~ /^[a-z]*SQ/i && ! $Qdir;
							die "$CONF \$SECURITY_QUARANTINE ", gettext("not given"), "\n" if $policy =~ /^[a-z]*PQ/i && ! $Qbox;
							die "$CONF \$SECURITY_FILENAME_LOG ", gettext("not given"), "\n" if $policy =~ /^[a-z]*L/i && ! $Flog;
							$glob =~ s/([^\\])\./$1\\./g;
							$glob =~ s/\*/.*/g;
							$glob =~ s/\?/./g;
							push(@Policy, "${glob}\034${policy}");
							warn "$INFO $glob $policy\n" if $dbgv;
						}
					}
					close(POLICY);
				} else {
					warn "$WARN ", gettext("could not open"), " $file: $!";
				}
			}
			if ($dbgv) {
				warn "$INFO *** ", gettext("policy dump"), " ***\n";
				for (@Policy) {
					warn "$INFO $_\n";
				}
			}
			warn "$WARN ", gettext("no policy defined"), " - ", gettext("defaulting to"), " $default_policy\n" unless @Policy;
		} else {
			warn "$WARN ", gettext("no policy files defined by"), " \$SECURITY_POLICY - ", gettext("defaulting to"), " $default_policy\n";
		}
	}

	unless (%RFC822maxlen) {	# read it only once
		warn "$INFO ", gettext("reading RFC822 length limits"), "\n" if $dbg;
		$RFC822maxlen{"DATE"} =
		$RFC822maxlen{"FROM"} =
		$RFC822maxlen{"STATUS"} =
		$RFC822maxlen{"SUBJECT"} =
		$RFC822maxlen{"X-STATUS"} =
		$RFC822maxlen{"X-KEYWORDS"} =
		$RFC822maxlen{"MESSAGE-ID"} =
		$RFC822maxlen{"RESENT-DATE"} =
		$RFC822maxlen{"MIME-VERSION"} = 250;
		if ($file = $ENV{"SECURITY_RFC822_MAXLEN"}) {
			unless ($file =~ /^\//) {
				die "$CONF \$SECURITY_POLICY_DIR ", gettext("not given, cannot find"), " $file\n" unless $Pdir;
				$file = "${Pdir}/${file}";
			}
			warn "$INFO RFC822 maxlen $file\n" if $dbg;
			if (open(POLICY,"<$file")) {
				while (<POLICY>) {
					s/#.*//;	# no hashes in filenames!
					if (($header, $maxlen) = /^\s*(\w+):\s*(\d+)/) {
						if ($maxlen > 32) {
							warn "$INFO $header maxlen $maxlen\n" if $dbgv;
							$RFC822maxlen{"\U$header"} = $maxlen;
						} else {
							warn "$CONF $header maxlen $maxlen ", gettext("is too short"), "\n";
						}
					}
				}
				close(POLICY);
			} else {
				warn "$WARN ", gettext("could not open"), " $file: $!";
			}
		} else {
			warn "$WARN \$SECURITY_RFC822_MAXLEN ", gettext("not given, using defaults"), "\n" if $dbgv;
		}
	}
}

sub decodefilename {
	# decode RFC2047-encoded text
	my($filename, $junk) = @_;
	my($dec, $cset, $charset, $enc, $encoding, $enw);

	if ($filename =~ /^=\?.*\?=$/s) {
		warn "$INFO ", gettext("decoding filename"), " \"$filename\"\n" if $dbg;
		$dec = "";

		while (($cset, $enc, $enw) = $filename =~ /^=\?([-\w]+)\?([a-z])\?([^?\s]+)\?=\s*/is) {
			$charset = "\U$cset";
			$encoding = "\U$enc";
			if ($encoding eq "Q") {
				$dec .= decode_qp($enw);
			} elsif ($encoding eq "B") {
				$dec .= decode_base64($enw);
			} else {
				warn "MIME: \"$filename\" ", gettext("uses unrecognized text encoding"), " \"$encoding\"\n";
				$dec .= $enw;
			}
			$filename =~ s/^=\?[-\w]+\?[a-z]\?[^?\s]+\?=\s*//is;
		}
		$filename = $dec;
		warn "$INFO ", gettext("decoded filename"), " \"$filename\"\n" if $dbg;
		die "$FATAL ", gettext("catastrophic failure in"), " decodefilename()\n" unless $filename;
	}
	return wantarray? ($filename, $charset, $encoding) : $filename;
}

sub checkfilename {
	# see if file has a policy
	# if not, default to $default_policy
	# if a Microsoft Office document, tag for the VBA scanner
	my($filename, $junk) = @_;
	my($glob, $policy, $dec, $enc, $enw, $scan, $handling);

	$handling = $scan = "";
	$filename = decodefilename($filename);

	$scan = "O" if $filename =~ /\.(do[ct]|xl[swt]|p[po]t|rtf|pps)$/i;

	$filename =~ s/\\\001/\\"/sg;
	warn "$INFO ", gettext("scanning for policy for filename"), " \"$filename\"\n" if $dbg;

	for (@Policy) {
		($glob, $policy) = split(/\034/);
		warn "$INFO ", gettext("glob"), " \"$glob\"\n" if $dbgv;
		if ($filename =~ /^${glob}$/i) {
			$handling = "${scan}${policy}";
			last;
		}
	}

	unless ($handling) {
		warn "$WARN ", gettext("no policy found for"), " \"$filename\" - ", gettext("defaulting to"), " $default_policy\n";
		$handling = "${scan}${default_policy}";
	}

	warn "$INFO ", gettext("policy"), ": \"$handling\"\n" if $dbgv;

	if ($handling =~ /^[a-z]*L/i) {
		if (open (FLOG, ">>$Flog")) {
			print FLOG "$MSGID $filename\n";
			close(FLOG);
		}
	}

	return $handling;
}

sub setMIMEboundary {
	# set the current MIME boundary string
	# save the previous
	# do length-limiting, etc.
	my($bndry, $junk) = @_;

	if ($gotboundary) {
		push @boundariestoolong, $boundarytoolong;
		push @mimeboundaries, $mimeboundary;
		push @newboundaries, $newboundary;
		push @nullboundaries, $nullboundary;
	}

	$bndry =~ s/(^"|"$)//g;
	$newboundary = $mimeboundary = $bndry;
	$boundarytoolong = $nullboundary = 0;
	$gotboundary++;
	warn "$INFO ", gettext("boundary"), " $gotboundary = \"$mimeboundary\"\n" if $dbgv;

	if ($boundarytoolong = (length($mimeboundary) > 80)) {
		push (@MsgLog, "\n",
			gettext("MIME boundary string is excessively long."), " ",
			gettext("Possible buffer overflow attack."),
			"\n");
		warn "MIME: ", gettext("truncating long boundary string"), "\n";
		$newboundary = substr($mimeboundary,0,64);
	} elsif ($nullboundary = (length($mimeboundary) < 1)) {
		push (@MsgLog, "\n",
			gettext("MIME boundary string explicitly empty."), " ",
			gettext("Denial-of-Service attack."),
			"\n");
		warn "MIME: ", gettext("replacing null boundary string"), "\n";
		$newboundary = "==NULL_MIME_BOUNDARY_SANITIZED-${HOST}-${$}-${gotboundary}==";
	}
	$mimeboundary = quotemeta($mimeboundary);
	warn "$INFO ", gettext("boundary"), " $gotboundary = \"$mimeboundary\"\n" if $dbgv;
}

sub popMIMEboundary {
	$gotboundary--;
	$boundarytoolong = pop @boundariestoolong;
	$mimeboundary = pop @mimeboundaries;
	$newboundary = pop @newboundaries;
	$nullboundary = pop @nullboundaries;
}

sub resetbodypart {
	# clean up BodyPart temporary file if necessary
	if ($BodyPart && !$BodyPartSize && -f $BodyPart) {
		unlink($BodyPart) || warn "$WARN ", gettext("could not remove"), " $BodyPart: $!";
	}
	$BodyPart = "";
	$BodyPartSize = 0;
	$BNDRY = "";
}

sub readheaders {
	# read lines until blank line
	# if line begins with whitespace, append to previous line
	# retain the whitespace and \n for writing it back out
	# add finished line to headers array
	my($SRC, $Headers, $junk) = @_;
	my($hdr);

	@$Headers = ();
	$hdr = "";

	while (<$SRC>) {
		if (/^\s*$/) {
			if (@$Headers) {
				# blank line and had some headers; end of headers
				if ($hdr) {
					warn "$INFO ", gettext("saved header"), " \"$hdr\"\n" if $dbgv;
					push(@$Headers, $hdr);
				}
				return;
			} else {
				# skip blank lines before headers
				next;
			}
		} elsif (/^\s/) {
			# indented - append to prev partial hdr
			$hdr .= " $_";
		} else {
			# normal header line
			if ($hdr) {
				warn "$INFO ", gettext("saved header"), " \"$hdr\"\n" if $dbgv;
				push(@$Headers, $hdr);
			}
			$hdr = $_;
		}
	}

	# Eep. should not hit EOF in this routine...
	die "$FATAL ", gettext("catastrophic failure in"), " readheaders()\n";
	return;
}

sub doRFC822headers {
	# state: reading RFC822 headers and setting up to process body
	my($SRC, $Headers, $MSGID, $HasMIME, $junk) = @_;
	my($hdr, $junk, $index, $header, $maxlen);

	warn "$INFO ", gettext("reading RFC822 headers"), "\n" if $dbg;
	readheaders($SRC, $Headers);

	$index = $$HasMIME = 0;
	foreach $hdr (@$Headers) {
		warn "$INFO ", gettext("RFC822 header"), " \"$hdr\"\n" if $dbgv;
		if ($hdr =~ /`\s*`/sg) {
			# Unix shell escape attack
			push (@MsgLog, "\n",
				gettext("Header contained double backquotes."), " ",
				gettext("Possible UNIX shell-script attack."), 
				"\n",
				gettext("Original value:"), " \"$hdr\"",
				"\n");
			warn "MIME: ", gettext("fixing double backquotes"), "\n";
			$hdr =~ s/`[\s\n]*`/\\"/sg;
		}
		if (($junk) = $hdr =~ /^Message-ID\s*:\s.*(<[^@>]+@[^>]+>)/i) {
			$$MSGID = $junk unless $$MSGID;
		}
		($header) = $hdr =~ /^(\w+)\s*:/;
		$maxlen = $RFC822maxlen{"\U$header"};
		if ($maxlen && length($hdr) > $maxlen) {
			push (@MsgLog, "\n",
				gettext("Message header is excessively long."), " ",
				gettext("Possible buffer overflow attack."),
				"\n",
				gettext("Original value:"), " \"$hdr\"",
				"\n");
			warn "RFC822: ", gettext("truncating long header"), " $hdr\n";
			$hdr = chomp(substr($hdr, 0, $maxlen)) . "\n";
		}
		next if $$HasMIME;
		if ($hdr =~ /^MIME-Version\s*:\s/i) {
			$$HasMIME = 1;
			$junk = "X-Security: " . gettext("message sanitized on") . " $HOST " . localtime() . "\n";
			$junk .= "\t" . gettext("See") . " http://www.impsec.org/email-tools/procmail-security.html\n";
			$junk .= "\t" . gettext("for details.") . " \$Revision: 0.46 $x\n";
			warn "$INFO ", gettext("adding header(s)"), "\n" if $dbgv;
			splice (@$Headers, $index++, 0, $junk);
			unless ($Qdir && $Qbox) {
				$junk = "X-Security: " . gettext("the postmaster has not enabled quarantine support") . "\n";
				splice (@$Headers, $index++, 0, $junk);
			}
		}
		$index++;
	}
}

sub doMIMEheaders {
	# state: reading MIME headers and sanitizing them
	# setting up to process body
	my($SRC, $Headers, $junk) = @_;
	my($hdr, $index, $hname, $Hname, $hdata,
		$cth, $ceh, $mangle_mime_type, $filename, $oldfilename, $newfilename, $dispfilename,
		$policy, $handling, $logfiles,
		$depthatentry, $junk2, $nulls, $cset, $enc);

	if (@$Headers) {
		warn "$INFO ", gettext("Processing MIME headers"), "\n" if $dbg;
	} else {
		warn "$INFO ", gettext("Reading MIME headers"), "\n" if $dbg;
		readheaders($SRC, $Headers);
	}

	$policy = $handling = $logfiles = $MIMEencoding = $MIMEtype = $MIMEsubtype = "";
	$mangle_mime_type = $index = 0;
	$depthatentry = $gotboundary;
	resetbodypart();

	foreach $hdr (@$Headers) {
		warn "$INFO ", gettext("MIME header"), " \"$hdr\"\n" if $dbgv;
	        $hdr =~ s/([^\\])\\"/$1\\\001/sg;	# hide escaped quotes to simplify things

		if (($junk) = $hdr =~ /^Content-Transfer-Encoding\s*:\s+([78]bit|binary|quoted-printable|base64|x-uuencode)/is) {
			$MIMEencoding = "\U$junk";
			if ($ceh) {
				warn "MIME ", gettext("Multiple Content-Transfer-Encoding headers"), "\n";
			} else {
				$ceh = \$hdr;
			}
		}

		if (($hname, $hdata) = $hdr =~ /^(Content-[a-z0-9-]+)\s*:\s+(\S.*)/si) {
			$Hname = "\U$hname";

			if ($hdr =~ /`\s*`/) {
				# Unix shell escape attack
				push (@MsgLog, "\n",
					gettext("Header contained double backquotes."), " ",
					gettext("Possible UNIX shell-script attack."), 
					"\n",
					gettext("Original value:"), " \"$hdr\"",
					"\n");
				warn "MIME: ", gettext("fixing double backquotes"), "\n";
				$hdr =~ s/`\s*`/\\"/sg;
			}

			for ($hdr =~ /\s(\S+)\s*=\s*""/sgi) {
				$junk = $_;
				push (@MsgLog, "\n",
					gettext("Header contained null value."), " ",
					gettext("Denial-of-Service attack."), 
					"\n",
					gettext("Header: "), "${hname}: ${junk}=\"\"",
					"\n");
				warn "MIME: ", gettext("null value in header"), " ${hname}: ${junk}=\"\"\n";
				$junk2 = quotemeta($junk);
				$nulls = gettext("null value sanitized") unless $nulls;
				$hdr =~ s/\s${junk2}\s*=\s*""(;?\s)\s*/ X-${junk}="[${nulls}]"$1/sgi;
			}

			if ($hdr =~ /name\s*=\s*"[^"]+$/is) {
				warn "MIME: ", gettext("fixing missing close quote on filename"), "\n";
				$hdr =~ s/$/"/;
			}

			for ($hdr =~ /name\s*=\s*([^"\s][^;]+)/sgi) {
				s/\s+$//;
				$junk = $newfilename = $filename = $_;
				$junk =~ s/\\\001/\\"/sg;
				warn "MIME: ", gettext("fixing unquoted filename"), " \"${junk}\"\n";
				if ($newfilename =~ /\([^)]*\)/ && $newfilename !~ /^=\?/) {
					push (@MsgLog, "\n",
						gettext("MIME body part name contained an RFC822 comment."), " ",
						gettext("Possible attempt to bypass filename filtering."),
						"\n",
						gettext("Original name: "), $junk,
						"\n");
					warn "MIME: ", gettext("filename contains embedded RFC822 comment - removing"), "\n";
					$newfilename =~ s/\([^)]*\)//g;
					$junk = $newfilename;
					$junk =~ s/\\\001/\\"/sg;
					push (@MsgLog,
						gettext("New name: "), $junk,
						"\n");
				}
				$newfilename =~ s/\"/\\\001/g;	# escape quotes embedded in filename
				$filename = quotemeta($filename);
				$hdr =~ s/name\s*=\s*${filename}\s*/name="${newfilename}"/sgi;
			}

			for ($hdr =~ /name\s*=\s*"([^"]{250,})"/sgi) {
				$junk = $filename = $_;
				$junk =~ s/\\\001/\\"/sg;
				push (@MsgLog, "\n",
					gettext("MIME body part name is excessively long."), " ",
					gettext("Possible buffer overflow attack."),
					"\n",
					gettext("Original name: "), $junk,
					"\n");
				warn "MIME: ", gettext("truncating long filename"), " \"${junk}\".\n";

				($junk, $cset, $enc) = decodefilename($filename);
				$newfilename = substr($junk, 0, 200);

				# TODO: what if "extension" is very long?
				# preserve the extension, if any
				if ($junk =~ /\.[-a-z0-9{}]+$/) {
					$junk =~ s/^.+\.//;
					$newfilename .= ".$junk";
				}

				# restore encoding, if any
				if ($enc eq "Q") {
					$newfilename = "=?${cset}?Q?" . encode_qp($newfilename) . "?=";
					$newfilename =~ s/=\n//sg;
				} elsif ($enc eq "B") {
					$newfilename = "=?${cset}?B?" . encode_base64($newfilename) . "?=";
					$newfilename =~ s/\s+//sg;
				}

				$junk = $newfilename;
				$junk =~ s/\\\001/\\"/sg;
				push (@MsgLog,
					gettext("New name: "), $junk,
					"\n");

				$filename = quotemeta($filename);
				$hdr =~ s/name\s*=\s*"${filename}"/name="${newfilename}"/sgi;
				$mangle_mime_type = 1;
			}

			for ($hdr =~ /name\s*=\s*"([^"]+)"/sgi) {
				$newfilename = $filename = $_;

				$junk = checkfilename($filename);
				($policy, $logfiles) = $junk =~ /^([a-z]+)(:.+)?$/i;
				# if different names are used in multiple name= clauses,
				# different policies may match - keep them all
				$handling .= $policy;

				if ($policy =~ /M/i) {
					$junk = $filename;
					$junk =~ s/\\\001/\\"/sg;
					$oldfilename = decodefilename($junk);
					push (@MsgLog, "\n",
						gettext("MIME body part name is being mangled due to site security policy."),
						"\n",
						gettext("Original name: "), $oldfilename,
						"\n");
					warn "MIME: ", gettext("mangling filename"), " \"${junk}\".\n";

					# if filename is encoded, encode the mangling
					if ($filename =~ /=\?[-_a-z0-9]+\?[a-z]\?/i) {
						$newfilename = "$filename =?ISO-8859-1?Q?" . encode_qp("-${DEFANG}") . "?=";
					} else {
						$newfilename = "${filename}-${DEFANG}";
					}

					$junk = $newfilename;
					$junk =~ s/\\\001/\\"/sg;
					$junk = decodefilename($junk);
					push (@MsgLog,
						gettext("New name: "), $junk,
						"\n");

					$filename = quotemeta($filename);
					$hdr =~ s/name\s*=\s*"${filename}"/name="${newfilename}"/sgi;
					$mangle_mime_type = 1;
					$newfilename = $junk;
				}

				if ($Hname eq "CONTENT-DISPOSITION") {
					if ($dispfilename) {
						warn "MIME ", gettext("Multiple Content-Disposition headers/filenames"), "\n";
					} else {
						$dispfilename = $newfilename;
					}
				}

				# TODO don't do this here?
				# there's lots more %x stuff to interpolate after the attachment has been dealt with
				# but does it apply for mangling?
				# make this a parameterized subroutine
				# it should also accept multiple colon-delimited filenames
				for ($logfiles =~ /:([^:]+)/) {
					# interpolate a custom status message
					$junk = $_;
					$junk =~ s/^(\.+\/)*//;		# strip leading ../../
					if ($junk =~ /^[^\/]/) {
						# relative filename may only be in policy dir
						if ($Pdir) {
							$junk = "${Pdir}/${junk}";
						} else {
							warn "$CONF \$SECURITY_POLICY_DIR ", gettext("not given, cannot find"), " $junk\n";
							$junk = "";
						}
					}
					if ($junk) {
						if (-f $junk) {
							if (-r $junk) {
								if (open(NOTE,"<$junk")) {
									while (<NOTE>) {
										s/\%f/${oldfilename}/g;
										s/\%m/${newfilename}/g;
										push (@MsgLog, $_);
									}
									close (NOTE);
								} else {
									warn "$WARN ", gettext("error attempting to read"), " $junk : $!\n";
								}
							} else {
								warn  "$CONF \"$junk\": ", gettext("not readable"), "\n";
							}
						} else {
							warn  "$CONF \"$junk\": ", gettext("not a file"), "\n";
						}
					}
				}
			}

			if ($Hname eq "CONTENT-TYPE") {
				if ($cth) {
					warn "MIME ", gettext("Multiple Content-Type headers"), "\n";
				} else {
					$cth = \$hdr;
				}
				if (($junk, $junk2) = $hdata =~ /^([-\w]+)\/([^";\s]+)/is) {
					$MIMEtype = "\U$junk";
					$MIMEsubtype = "\U$junk2";
					if (($junk) = $hdata =~ /multipart\/.*boundary\s*=\s*(("")|("[^"]+")|([^"]\S+))/is) {
						setMIMEboundary($junk);
						$hdr =~ s/${mimeboundary}/${newboundary}/ if $boundarytoolong;
						$hdr =~ s/boundary[\s\n]*=[\s\n]*""/boundary="${newboundary}"/is if $nullboundary;
					}
					if ($mangle_mime_type) {
						warn "$INFO ", gettext("Mangling MIME type"), "\n" if $dbg;
						$junk = "${MIMEtype}/${MIMEsubtype}";
						warn "$INFO ", gettext("adding header(s)"), "\n" if $dbgv;
						push (@Headers, $SANHDR . gettext("original") . " Content-Type: $junk\n");
						$junk = quotemeta($junk);
						$hdr =~ s/${junk}/APPLICATION\/OCTET-STREAM/sgi;
						$hdr =~ s/\stype\s*=\s*"/ X-type="/sgi;
						# remove x-mac-* clauses to prevent
						# Eudora restoring the file type
						$junk = "";
						for ($hdata =~ /(\sx-mac-\S+\s*=\s*\S+;?)/sgi) {
							$junk .= $_;
							$junk2 = quotemeta($_);
							$hdr =~ s/${junk2}//sgi;
						}
						$junk =~ s/\s+/ /sg;
						push (@Headers, $SANHDR . gettext("removed") . ": $junk\n") if $junk;
					}
				}

				if (length($hdr) > 500) {
					push (@MsgLog, "\n",
						"Content-Type ",
						gettext("header is excessively long."), " ",
						gettext("Possible buffer overflow attack."),
						"\n",
						gettext("Original value: "), $hdata,
						"\n");
					warn "MIME: ", gettext("truncating long header"), ": $hname\n";
					$junk = $hdr;
					$junk =~ s/\\\001/\\"/g;
					$junk =~ s/\s+/ /g;
					$hdr = "Content-Type: X-BOGUS/X-BOGUS\n";
					warn "$INFO ", gettext("adding header(s)"), "\n" if $dbgv;
					splice (@Headers, $index++, 0, $SANHDR . gettext("excessively long header") . ": " . substr($junk,0,400) . "...\n");
					$mangle_mime_type = 0;
				}
			} else {
				if (length($hdata) > 500) {
					push (@MsgLog, "\n",
						"$hname ",
						gettext("header is excessively long."), " ",
						gettext("Possible buffer overflow attack."),
						"\n",
						gettext("Original value: "), $hdata,
						"\n");
					warn "MIME: ", gettext("truncating long header"), ": $hname\n";
					$hdr =~ s/\s+/ /sg;
					$hdr = $SANHDR . gettext("excessively long header") . ": " . substr($hdr,0,400) . "...\n";
				}
			}
		}

		$hdr =~ s/\\\001/\\"/sg;
		$hdr =~ s/\n\s+/\n\t/sg;
		$index++;
	}

	unless ($MIMEtype =~ /^(multipart|message)/i) {
		if ($cth) {
			# make sure content-type header has a name
			# we wait until now to do this so that we can
			# use the attachment filename from the content-disposition header
			# some MIME builders only put the filename there, so if
			# it's there, copy it rather than naming the body part
			# "default.txt"
			unless ($$cth =~ /[;\s]name\s*=\s*"/is) {
				warn "MIME: ", gettext("supplying default filename"), "\n" unless $dispfilename;
				$$cth =~ s/\s*$/;\n/ unless $$cth =~ /;\s*$/;
				$$cth .= "\tname=\"" . ($dispfilename? $dispfilename : "default.txt") . "\";\n";
				$$cth =~ s/\\\001/\\"/sg;
			}
		}
	}

	# Okay, at this point we should know the MIME type and encoding of the body part
	warn "$INFO Content-Type: $MIMEtype/$MIMEsubtype\n" if $dbgv;
	warn "$INFO Content-Transfer-Encoding: $MIMEencoding\n" if $dbgv;
	warn "$INFO ", gettext("policy"), ": $handling\n" if $dbgv;

	# Let's figure out what to do with it...
	# TODO it should be possible to define this stuff in a table
	# and use function references
	# TODO move this out of this function
	if ($MIMEtype eq "MESSAGE") {
		if ($MIMEsubtype eq "RFC822") {
			warn "$INFO ", gettext("recursing into attached RFC822 message"), "\n" if $dbg;
			for (@Headers) {
				print $_;
			}
			print "\n";
			doRFC822headers();	
		}
	} elsif ($MIMEtype eq "TEXT") {
		$junk = "";
		getbodypart();
		writebodypart($junk, $MIMEencoding);
		if ($junk =~ /<html>/si && ! $ENV{"SECURITY_TRUST_HTML"}) {
			$_ = $junk;
                	s/<(META|APP|SCRIPT|OBJECT|EMBED|FRAME|IFRAME|LAYER)\s/<DEFANGED_$1 /sgi;
			unless ($ENV{"SECURITY_TRUST_STYLE_TAGS"}) {
				s/<STYLE\s/ <!-- <DEFANGED_STYLE /sgi;
				s/(-->\s+)?<\/STYLE>/ --> <\/DEFANGED_STYLE>/sgi;
				s/\sSTYLE\s*=/ DEFANGED_STYLE=/sgi;
			}
			unless ($ENV{"SECURITY_TRUST_WEBBUGS"}) {
				s/<IMG\s/<DEFANGED_IMG /sgi;
				s/<BGSOUND\s/<DEFANGED_BGSOUND /sgi;
			}
			s/\sOn(Abort|Blur|Change|Click|DblClick|DragDrop|Error|Focus|KeyDown|KeyPress|KeyUp|Load|MouseDown|MouseMove|MouseOut|MouseOver|MouseUp|Move|Reset|Resize|Select|Submit|Unload)/ DEFANGED_On$1/sgi;
			if (/["\047][^"\047\s]*&#x?[1-9][0-9a-f]/si) {
				while (/["\047][^"\047\s]*&#((4[6-9]|5[0-8]|6[4-9]|[78][0-9]|9[07-9]|1[0-1][0-9]|12[0-2]))/s) {
					$char = chr($1);
					s/&#$1;?/$char/sg;
				}
				while (/["\047][^"\047\s]*&#(x(2[ef]|3[0-9a]|4[0-9a-f]|5[0-9a]|6[1-9a-f]|7[0-9a]))/si) {
					$char = chr(hex("0$1"));
					s/&#$1;?/$char/sgi;
				}
			}
			if (/["\047][^"\047\s]*%[2-7][0-9a-f]/si) {
				while (/["\047][^"\047\s]*%((2[ef]|3[0-9a]|4[0-9a-f]|5[0-9a]|6[1-9a-f]|7[0-9a]))/si) {
					$char = chr(hex("0x$1"));
					s/%$1/$char/sgi;
				}
			}
			s/(["\047])([a-z]+script|mocha):/${1}DEFANGED_$2:/sgi;
			s/(["\047])&{/${1}DEFANGED_&{/sg;
			$junk = $_;
		}
	        if ($junk =~ /[\100-\377]/) {
			$$ceh = "Content-Transfer-Encoding: quoted-printable\n";
			$junk = encode_qp($junk);
		} else {
			$$ceh = "Content-Transfer-Encoding: 7bit\n";
		}
		for (@Headers) {
			print $_;
		}
		print "\n";
		print $junk;
	} else {
		# No special handling, write the headers back out.
		for (@Headers) {
			print $_;
		}
		print "\n";
	}
}

sub getbodypart {
	# read a MIME body part for further processing
	# if we read more than $MAX_BP_SIZE bytes, put it in a file to control memory use
	my ($bfileh, $bfilen);

	resetbodypart();

	while (<>) {
		last if /^--${mimeboundary}(--)?$/;

		if ($BodyPartSize || !$BodyPart) {
			$BodyPart .= $_;
			$BodyPartSize += length($_);
			if ($BodyPartSize > $MAX_BP_SZ) {
				# Reading large attachment, redirect to file
				warn "$INFO ", gettext("large MIME body part, redirecting to temporary file"), "\n";
				if (($bfileh, $bfilen) = mkstempt("sanitizer-XXXXXXXX", $TEMP)) {
					warn "$INFO $bfilen\n" if $dbgv;
				} else {
					# not possible to create temporary file
					die "$WARN ", gettext("error attempting to create temporary file"), ": $!\n";
				}
				print $bfileh $BodyPart;
				$BodyPart = $bfilen;
				$BodyPartSize = 0;
			}
		} else {
			print $bfileh $_;
		}
	}

	if ($bfileh) {
		$bfileh->close;
	} else {
		warn "$INFO \"$BodyPart\"\n" if $dbgv;
	}
	$BNDRY = $_;
}

sub writebodypart {
	# copy the body part to a file or variable, possibly decoding
	# caller must open and close file
	my ($dest, $encoding, $junk) = @_;
	my ($enc, $tofile);

	$tofile = $enc = 0;
	$encoding = "\U$encoding";
	$enc = 1 if $encoding eq "BASE64";
	$enc = 2 if $encoding eq "QUOTED-PRINTABLE";
	$enc = 3 if $encoding eq "X-UUENCODE";	# MS-ism
	if ($dest) {
		$tofile = 1;
	} else {
		$dest = \$_[0];
	}
	warn "$INFO \$enc=$enc \$tofile=$tofile\n" if $dbgv;

	if ($BodyPart) {
		if ($BodyPartSize) {
			# in memory
			if ($enc == 1) {
				if ($tofile) {
					print $dest decode_base64($BodyPart);
				} else {
					$$dest = decode_base64($BodyPart);
				}
			} elsif ($enc == 2) {
				if ($tofile) {
					print $dest decode_qp($BodyPart);
				} else {
					$$dest = decode_qp($BodyPart);
				}
			} elsif ($enc == 3) {
				if ($tofile) {
					print $dest unpack("u", $BodyPart);
				} else {
					$$dest = unpack("u", $BodyPart);
				}
			} else {
				if ($tofile) {
					print $dest $BodyPart;
				} else {
					$$dest = $BodyPart;
				}
			}
		} else {
			# in temporary file
			if (open(BP,"<$BodyPart")) {
				while (<BP>) {
					if ($enc == 1) {
						if ($tofile) {
							print $dest decode_base64($_);
						} else {
							$$dest .= decode_base64($_);
						}
					} elsif ($enc == 2) {
						if ($tofile) {
							print $dest decode_qp($_);
						} else {
							$$dest .= decode_qp($_);
						}
					} elsif ($enc == 3) {
						if ($tofile) {
							print $dest unpack("u", $_);
						} else {
							$$dest .= unpack("u", $_);
						}
					} else {
						if ($tofile) {
							print $dest $_;
						} else {
							$$dest .= $_;
						}
					}
				}
				close(BP);
			}
		}
		return TRUE;
	} else {
		warn "$WARN ", gettext("internal error: attempt to write body part before reading it"), "\n";
		return FALSE;
	}
	return TRUE;
}

sub passbodypart {
	# stream the current body part out to get to the next body part

	if ($BodyPart) {
		# already been read, stream it out
		if ($BodyPartSize) {
			# in memory
			print $BodyPart;
		} else {
			# in file
			if (open(BP,"<$BodyPart")) {
				while (<BP>) {
					print $_;
				}
				close(BP);
			}
		}
	} else {
		# streaming from STDIN
		while (<>) {
			last if /^--${mimeboundary}(--)?$/;
			print $_;
		}
		$BNDRY = $_;
	}

	resetbodypart();
}

sub discardbodypart {
	# discard everything up to the next boundary string
	# if $BodyPart exists, discard it instead of reading from STDIN
	my ($origname, $junk) = @_;

	push (@MsgLog, "\n",
		gettext("Discarding MIME body part."),
		"\n",
		gettext("Original name: "),
		$origname,
		"\n") if $origname;
	warn "$INFO ", gettext("Discarding MIME body part."), "\n";

	unless ($BodyPart) {
		# if we haven't already read the body part, read and discard it.
		while (<>) {
			last if /^--${mimeboundary}(--)?$/;
		}
		$BNDRY = $_;
	}

 	resetbodypart();
}

sub quarantinebodypart {
	# quarantine the body part, decoding if appropriate
	my ($origname, $encoding, $junk) = @_;
	my ($qfileh, $qfilen);

	push (@MsgLog, "\n",
		gettext("Quarantining MIME body part."),
		"\n",
		gettext("Original name: "),
		$origname,
		"\n") if $origname;
	warn "$INFO ", gettext("Quarantining MIME body part."), "\n";

	unless ($Qdir) {
		# not possible to quarantine
		push (@MsgLog, "\n",
			gettext("Due to a sanitizer configuration error"), " ",
			gettext("the MIME body part could not be quarantined and will be discarded."),
			"\n",
			gettext("Please notify your system administrator."),
			"\n");
		warn "$CONF \$SECURITY_QUARANTINE_DIR ", gettext("not given, cannot quarantine body part"), "\n";
		discardbodypart();
		return "";
	}

	$origname =~ s/\//_/g;
	unless (($qfileh, $qfilen) = mkstempt($Qtemplate . $origname . "-XXXXXXXX", $Qdir)) {
		# not possible to quarantine
		push (@MsgLog, "\n",
			gettext("Due to a system error"), " ",
			gettext("the MIME body part could not be quarantined and will be discarded."),
			"\n",
			gettext("The system error was:"), " $!",
			"\n",
			gettext("Please notify your system administrator."),
			"\n");
		warn "$WARN ", gettext("error attempting to quarantine"), ": $!\n";
		discardbodypart();
		return "";
	}

	push (@MsgLog, "\n",
		gettext("Quarantine file name:"),
		" $qfilen",
		"\n");
	warn "$INFO ", gettext("Quarantine file name:"), " $qfilen\n";
	
	writebodypart($qfileh, $encoding);

	$qfileh->close;
	resetbodypart();
	return $qfilen;
}

sub savebodypart {
	# copy the body part to a file, decoding if appropriate
	# return the file name
	my ($encoding, $junk) = @_;
	my ($tfileh, $tfilen);

	if (($tfileh, $tfilen) = mkstempt("sanitizer-XXXXXXXX", $TEMP)) {
		writebodypart($tfileh, $encoding);
		$tfileh->close;
		return $tfilen;
	} else {
		# not possible to create temporary file
		warn "$WARN ", gettext("error attempting to create temporary file"), ": $!\n";
		return "";
	}
}

initialize();
readpolicy();

for (@ARGV) {
	print "$_ = ", checkfilename($_), "\n";
}
@ARGV = ();

doRFC822headers();


# temporary
if (@MsgLog) {
	for (@MsgLog) {
		print $_;
	}
}

exit;


      if ($mimeboundary || ($gotboundary && $nullboundary) || $inmimehdr) {
        if (/^\s*$/) {
          $inmimehdr = 0;
          if ($recursemsg) {
            push @mimeboundaries, $mimeboundary;
            push @newboundaries, $newboundary;
            push @rawboundaries, $rawboundary;
            push @boundariestoolong, $boundarytoolong;
            push @gotboundaries, $gotboundary;
            push @nullboundaries, $nullboundary;
            $mimeboundary = $newboundary = "";
            $recursemsg = $pastmsghdr = $boundarytoolong = $gotboundary = 0;
          }
        } elsif (/^--${mimeboundary}(--)?$/) {
          $mend = $1;
          s/${mimeboundary}/${newboundary}/ if $boundarytoolong;
          s/^--/--${newboundary}${mend}/ if $nullboundary;
          if ($mend) {
            if ($mimeboundaries[0]) {
              warn " End of RFC822/Multipart attachment.\n" if $ENV{"DEBUG"};
              $mimeboundary = pop @mimeboundaries;
              $newboundary = pop @newboundaries;
              $rawboundary = pop @rawboundaries;
              $boundarytoolong = pop @boundariestoolong;
              $gotboundary = pop @gotboundaries;
              $nullboundary = pop @nullboundaries;
            }
          } else {
            $inmimehdr = 1;
            $recursemsg = $strip_attachment = $check_attachment = 0;
          }
        } elsif (!$inmimehdr && $strip_attachment) {
          $_ = "";
        } elsif (!$inmimehdr && $check_attachment) {
          $check_attachment = 0;
          if ($destf = `mktemp /tmp/mailchk.XXXXXX`) {
            chomp($destf);
            if (open(DECODE,"|mimencode -u -o $destf")) {
              do {
                print $_;
                print DECODE $_;
                $_ = <>;
                $lastline = $_;
              } until (/^\s*$/ || /^--/);
              close(DECODE);
              # Run virus-checker here.
              open(ATTCH,"< $destf");
              $msapp = $score = 0;
              @scores = ();
              while (<ATTCH>) {
                $score+= 99 if /\000VirusProtection/i;
                $score+= 99 if /\000select\s[^\000]*shell\s*\(/i;
                $score+= 9 if /\000regedit/i;
                $score+= 9 if /\000SaveNormalPrompt/i;
                $score+= 9 if /\000Outlook.Application\000/i;
                $score+= 9 if /\000CountOfLines/i;
                $score+= 9 if /\000AddFromString/i;
                $score+= 9 if /\000StartupPath/i;
                $score+= 4 if /\000ID="{[-0-9A-F]+$/i;
                $score+= 4 if /\000CreateObject/i;
                $score+= 4 if /(\000|\004)([a-z0-9_]\.)*(Autoexec|Workbook_(Open|BeforeClose|Window(De)?activate)|Document_(Open|New|Close))/i;
                $score+= 4 if /(\000|\004)(Logon|AddressLists|AddressEntries|Recipients|Attachments|Logoff)/i;
                $scores[0] = 4 if /(\000|\004)(Subject|Body)/i;
                $score+= 2 if /\000Shell/i;
                $score+= 2 if /\000Options[^\w\s]/i;
                $score+= 2 if /\000CodeModule/i;
                $score+= 2 if /\000([a-z]+\.)?Application\000/i;
                $score+= 2 if /(\000|\004)stdole/i;
                $score+= 2 if /(\000|\004)NormalTemplate/i;
                $score+= 2 if /\000ID="{[-0-9A-F]+}"/i;
                $score+= 1 if /\000ThisWorkbook\000/i;
                $score+= 1 if /\000PrivateProfileString/i;
                $score+= 1 if /(\000|\004)(ActiveDocument|ThisDocument|ThisWorkbook)/i;
                $score+= 1 if /\000\[?HKEY_(CLASSES_ROOT|CURRENT_USER|LOCAL_MACHINE)/;
                $msapp+= 1 if /\000(Microsoft (Word Document|Excel Worksheet|Excel|PowerPoint)|MSWordDoc|Word\.Document\.[0-9]+|Excel\.Sheet\.[0-9]+)\000/;
              }
              close(ATTCH);
              unlink($destf);
              if ($msapp) {
 		for (@scores) {
		  $score += $_;
		}
                if ($histfile = $ENV{"SCORE_HISTORY"}) {
                  if (open(HIST,">>$histfile")) {
                    print HIST "score=$score msgid=".$ENV{"MSGID"}." from=".$ENV{"FROM"}."\n";
                    close HIST;
                  }
                }
                $poison_score = $ENV{"POISONED_SCORE"};
                $poison_score = 5 if $poison_score < 5;
                if ($score > $poison_score && !$ENV{"SCORE_ONLY"}) {
                  warn " POSSIBLE MACRO EXPLOIT: Score=$score\n";
                  print "\n\n--$rawboundary\n";
                  print "Content-Type: TEXT/PLAIN;\n";
                  print "X-Content-Security: NOTIFY\n" if $ENV{"SECURITY_NOTIFY"} || $ENV{"SECURITY_NOTIFY_VERBOSE"};
                  print "X-Content-Security: REPORT: Trapped poisoned Microsoft attachment\n" if $ENV{"SECURITY_NOTIFY"} || $ENV{"SECURITY_NOTIFY_VERBOSE"};
                  print "X-Content-Security: QUARANTINE\n" if $ENV{"SECURITY_QUARANTINE"};
                  print "Content-Description: SECURITY WARNING\n\n";
                  print "SECURITY WARNING!\n";
                  print "The mail delivery system has detected that the preceding\n";
                  print "document attachment appears to contain hazardous macro code.\n";
                  print "Macro Scanner score: $score\n";
                  print "Contact your system administrator immediately!\n\n";
                }
              } else {
                $score = 0;
              }
              if ($lastline =~ /^--${mimeboundary}(--)?$/) {
                $inmimehdr = 1;
                $check_attachment = 0;
                $lastline =~ s/${mimeboundary}/${newboundary}/ if $boundarytoolong;
              }
              print $lastline;
            } else {
              warn "*** Cannot decode attachment: $!  - is mimencode installed?\n";
            }
          } else {
            warn "*** Cannot extract attachment - is mktemp installed?\n";
          }
        }
        if ($inmimehdr || $hdrcnt) {
          if (/^(\s+\S|(file)?name)/) {
            s/^\s*/ /;
            s/^\s*// if $hdrtxt =~ /"[^"]*[^;]$/;
            s/\s*\n$//;
            $hdrtxt .= $_;
            $_ = "";
          } else {
            if ($hdrtxt) {
              while (($hdr, $val) = $hdrtxt =~ /^([-\w]+)\s*:.*\s(\S+)\s*=\s*""/i) {
                warn " Null $val in $hdr header.\n";
                $sval = quotemeta($val);
                $hdrtxt =~ s/\s$sval\s*=\s*""/ X-$val="{null value sanitized}"/;
              }
              while (($junk,$filen) = $hdrtxt =~ /^Content-[-\w]+\s*:[^"]*("[^"]*"[^"]+)*name\s*=\s*([^"\s][^;]+)/i) {
                warn " Fixing unquoted filename \"$filen\".\n";
                $newfilen = $filen;
                $newfilen =~ s/\"/\\"/g;
                if ($newfilen =~ /\([^)]*\)/) {
                  warn " Filename contains embedded RFC822 comment - removing.\n";
                  $newfilen =~ s/\([^)]*\)//g;
                }
                $filen = quotemeta($filen);
                $hdrtxt =~ s/name\s*=\s*${filen}/name="$newfilen"/ig;
              }
              while (($filen) = $hdrtxt =~ /^Content-[-\w]+\s*:.*name\s*=\s*"(=\?[^"]+=2E[^"]+\?=)"/i) {
                warn " Fixing encoded periods in \"$filen\".\n";
                $newfilen = $filen;
                $newfilen =~ s/=2E/./ig;
                $filen = quotemeta($filen);
                $hdrtxt =~ s/name\s*=\s*"${filen}"/name="$newfilen"/ig;
              }
              while (($filen) = $hdrtxt =~ /^Content-[-\w]+\s*:.*name\s*=\s*"([^"]{120})[^"]{16,}"/i) {
                warn " Truncating long filename \"$filen...\".\n";
                $filen .= "...";
                $filen .= "?=" if $filen =~ /^=\?/;
                $hdrtxt =~ s/name\s*=\s*"[^"]{128,}"/name="$filen"/i;
                $mangle_mime_type = 1;
              }
	      if (($mtype) = $hdrtxt =~ /Content-Type:\s+([a-z0-9-_]+\/[a-z0-9-_]+)/i) {
	        unless ($mtype =~ /^(multipart|text|message)\//i) {
		  unless ($hdrtxt =~ /name\s*=\s*"/i) {
		    warn "*** Supplying default filename.\n";
		    $hdrtxt .= "; " unless $hdrtxt =~ /;\s*$/;
		    $hdrtxt .= "name=\"default\";";
		  }
		}
	      }
              if (($filen) = $hdrtxt =~ /^Content-[-\w]+\s*:.*name\s*=\s*"([^"]+\.(do[ct]|xl[swt]|p[po]t|rtf|pps)(\?=)?)"/i) {
                warn " Scanning \"$filen\".\n";
                if (!$poisoned && ($specf = $ENV{"POISONED_EXECUTABLES"})) {
                  if (open(POISONED,$specf)) {
                    while (chomp($poisoned_spec = <POISONED>)) {
                      $poisoned_spec =~ s/^\s+//g;
                      $poisoned_spec =~ s/\s+$//g;
                      next unless $poisoned_spec;
                      $poisoned_spec =~ s/([^\\])\./$1\\./g;
                      $poisoned_spec =~ s/\*/.*/g;
                      $poisoned_spec =~ s/\?/./g;
                      $poisoned_spec .= "(\\?=)?";
                      warn "Checking against \"$poisoned_spec\"\n" if $ENV{"DEBUG"};
                      if ($filen =~ /^${poisoned_spec}$/i) {
                        warn " Trapped poisoned document \"$filen\".\n";
                        $poisoned = 1;
                        print "Content-Type: TEXT/PLAIN;\n";
                        print "X-Content-Security: NOTIFY\n" if $ENV{"SECURITY_NOTIFY"} || $ENV{"SECURITY_NOTIFY_VERBOSE"};
                        print "X-Content-Security: REPORT: Trapped poisoned Microsoft attachment \"$filen\"\n" if $ENV{"SECURITY_NOTIFY"} || $ENV{"SECURITY_NOTIFY_VERBOSE"};
                        print "X-Content-Security: QUARANTINE\n" if $ENV{"SECURITY_QUARANTINE"};
                        print "Content-Description: SECURITY WARNING\n\n";
                        print "SECURITY WARNING!\n";
                        print "The mail system has detected that the following\n";
                        print "attachment may contain hazardous macro code,\n";
                        print "is a suspicious file type or has a suspicious file name.\n";
                        print "Contact your system administrator immediately!\n";
                        print "Macro Scanner score: 0 (not scanned due to poisoning policy)\n\n";
                        last;
                      }
                    }
                    close(POISONED);
                  } else {
                    warn " Unable to open poisoned-executables file \"$specf\".\n";
                  }
                }
                $check_attachment = 1 unless $ENV{"DISABLE_MACRO_CHECK"};
              }
              if (($bndry) = $hdrtxt =~ /^Content-Type:\s+multipart\/.*\s+boundary\s*=\s*"([^"]+)"/i) {
                warn " Recursing into multipart attachment.\n" if $ENV{"DEBUG"};
                if (!$inmimehdr) {
                  push @mimeboundaries, $mimeboundary;
                  push @newboundaries, $newboundary;
                  push @rawboundaries, $rawboundary;
                  push @boundariestoolong, $boundarytoolong;
                  push @gotboundaries, $gotboundary;
                  push @nullboundaries, $nullboundary;
                  $mimeboundary = $newboundary = $bndry;
                  $recursemsg = $pastmsghdr = $boundarytoolong = $gotboundary = 0;
                } else {
                  $recursemsg = 1;
                }
              }
              if ($hdrtxt =~ /^Content-Type:\s+message\/rfc822/i) {
                warn " Recursing into RFC822 attachment.\n" if $ENV{"DEBUG"};
                if (!$inmimehdr) {
                  push @mimeboundaries, $mimeboundary;
                  push @newboundaries, $newboundary;
                  push @rawboundaries, $rawboundary;
                  push @boundariestoolong, $boundarytoolong;
                  push @gotboundaries, $gotboundary;
                  push @nullboundaries, $nullboundary;
                  $mimeboundary = $newboundary = "";
                  $recursemsg = $pastmsghdr = $boundarytoolong = $gotboundary = 0;
                } else {
                  $recursemsg = 1;
                }
              }
              if ($ENV{"SECURITY_STRIP_MSTNEF"} && $hdrtxt =~ /^Content-Type:\s+application\/MS-TNEF/i) {
		print "Content-Type: TEXT/PLAIN;\n";
		print "X-Content-Security: REPORT: Stripped MS-TNEF attachment\n";
		print "Content-Description: SECURITY NOTICE\n\n";
		print "SECURITY NOTICE\n";
		print "The mail system has removed a Microsoft attachment for security reasons.\n";
		print "The sender should disable sending Rich Text format in Outlook and\n";
		print "disable sending TNEF to the Internet from their Microsoft Exchange gateway.\n\n";
		print "See http://support.microsoft.com/support/kb/articles/Q241/5/38.ASP\n";
		print "and http://www.microsoft.com/TechNet/exchange/2505ch10.asp for more information.\n\n";
		$_ = $hdrtxt = "";
                $strip_attachment = 1;
                $inmimehdr = 0;
              }
              while (($filen) = $hdrtxt =~ /^Content-[-\w]+\s*:.*name\s*=\s*"([^"]+\.($ENV{"MANGLE_EXTENSIONS"})(\?=)?)"/io) {
                if (!$poisoned && ($specf = $ENV{"POISONED_EXECUTABLES"})) {
                  if (open(POISONED,$specf)) {
                    while (chomp($poisoned_spec = <POISONED>)) {
                      $poisoned_spec =~ s/^\s+//g;
                      $poisoned_spec =~ s/\s+$//g;
                      next unless $poisoned_spec;
                      $poisoned_spec =~ s/([^\\])\./$1\\./g;
                      $poisoned_spec =~ s/\*/.*/g;
                      $poisoned_spec =~ s/\?/./g;
                      $poisoned_spec .= "(\\?=)?";
                      warn "Checking against \"$poisoned_spec\"\n" if $ENV{"DEBUG"};
                      if ($filen =~ /^${poisoned_spec}$/i) {
                        warn " Trapped poisoned executable \"$filen\".\n";
                        $poisoned = 1;
                        print "Content-Type: TEXT/PLAIN;\n";
                        print "X-Content-Security: NOTIFY\n" if $ENV{"SECURITY_NOTIFY"} || $ENV{"SECURITY_NOTIFY_VERBOSE"};
                        print "X-Content-Security: REPORT: Trapped poisoned executable \"$filen\"\n" if $ENV{"SECURITY_NOTIFY"} || $ENV{"SECURITY_NOTIFY_VERBOSE"};
                        print "X-Content-Security: QUARANTINE\n" if $ENV{"SECURITY_QUARANTINE"};
                        print "Content-Description: SECURITY WARNING\n\n";
                        print "SECURITY WARNING!\n";
                        print "The mail system has detected that the following\n";
                        print "attachment may contain hazardous executable code,\n";
                        print "is a suspicious file type or has a suspicious file name.\n";
                        print "Contact your system administrator immediately!\n\n";
                        last;
                      }
                    }
                    close(POISONED);
                  } else {
                    warn " Unable to open poisoned-executables file \"$specf\".\n";
                  }
                }
                warn " Mangling executable filename \"$filen\".\n";
                $newfilen = $filen;
                $newfilen =~ s/\.([a-z0-9]+(\?=)?)$/.${$}DEFANGED-$1/i;
                $filen = quotemeta($filen);
                $hdrtxt =~ s/name\s*=\s*"?${filen}"?/name="$newfilen"/ig;
                $mangle_mime_type = 1;
              }
              if ($mangle_mime_type && $hdrtxt =~ /^Content-Type:\s/i) {
                ($oct) = $hdrtxt =~ /^Content-Type:.*\s(\S+\/\S+;?)/i;
                unless ($oct =~ /application\/octet-stream;/i) {
                  print "X-Content-Security: original Content-Type was $oct\n";
                  $oct = quotemeta($oct);
                  $hdrtxt =~ s/${oct}/application\/octet-stream;/i;
                }
              }
              if ($mangle_mime_type && $hdrtxt =~ /\sx-mac-\S+/i) {
                $eudora = "";
                while (($eh) = $hdrtxt =~ /(\sx-mac-\S+\s*=\s*\S+;?)/i) {
                  $eudora .= $eh;
                  $eh = quotemeta($eh);
                  $hdrtxt =~ s/${eh}//i;
                }
                print "X-Content-Security: removed$eudora\n";
              }
              if (($junk) = $hdrtxt =~ /^Content-Type\s*:\s+(.{128}).{100,}$/i) {
                warn " Truncating long Content-Type header.\n";
                $junk =~ s/"/\\"/g;
                $hdrtxt = "Content-Type: X-BOGUS\/X-BOGUS; originally=\"$junk...\"";
              } elsif (($junk) = $hdrtxt =~ /^Content-Description\s*:\s+(.{128}).{100,}$/i) {
                warn " Truncating long Content-Description header.\n";
                $hdrtxt = "Content-Description: $junk...";
              } elsif (($junk) = $hdrtxt =~ /^Content-[-\w]+\s*:\s+(.{128}).{100,}$/i) {
                warn " Truncating long MIME header.\n";
                $junk =~ s/"/\\"/g;
                $hdrtxt =~ s/^Content-([-\w]+)\s*:.*$/X-Overflow: Content-$1; originally="$junk..."/i;
              }
              #if ($hdrtxt =~ /^Content-Transfer-Encoding\s*:\s+base64/i) {
              #  $check_attachment = 1;
              #}
              $hdrtxt =~ s/\\ÿ/\\"/g;
              print $hdrtxt, "\n";
              $hdrtxt = "";
            }
            if (/^\S/) {
              s/\s*\n$//;
              $hdrtxt = $_;
              $_ = "";
              $hdrcnt++;
            } else {
              $hdrcnt = 0;
              $hdrtxt = "";
            }
          }
        } else {
          $poisoned = 0;
        }
      }