#
# MailScanner - SMTP E-Mail Virus Scanner
# Copyright (C) 2002 Julian Field
#
# $Id: Message.pm 3918 2007-05-27 20:32:11Z sysjkf $
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
# The author, Julian Field, can be contacted by email at
# Jules@JulianField.net
# or by paper mail at
# Julian Field
# Dept of Electronics & Computer Science
# University of Southampton
# Southampton
# SO17 1BJ
# United Kingdom
#
package MailScanner::Message;
use strict 'vars';
use strict 'refs';
no strict 'subs'; # Allow bare words for parameter %'s
use DirHandle;
use Time::localtime qw/ctime/;
use Time::HiRes qw/time/;
use MIME::Parser;
use MIME::Decoder::UU;
use MIME::Decoder::BinHex;
use MIME::WordDecoder;
use POSIX qw(:signal_h setsid);
use HTML::TokeParser;
use HTML::Parser;
use Archive::Zip qw( :ERROR_CODES );
use Filesys::Df;
#use MailScanner::BinHex;
# Install an extra MIME decoder for badly-header uue messages.
install MIME::Decoder::UU 'uuencode';
# Install an extra MIME decoder for binhex-encoded attachments.
install MIME::Decoder::BinHex 'binhex','binhex40','mac-binhex40','mac-binhex';
use vars qw($VERSION);
### The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = substr q$Revision: 3918 $, 10;
# Attributes are
#
# $id set by new
# $store set by new (is a SMDiskStore for now)
# #$hpath set by new
# #$dpath set by new
# $size set by new (copy of $store->{size})
# #$inhhandle set by new
# #$indhandle set by new
# $from set by ReadQf
# $fromdomain set by new
# $fromuser set by new
# @to set by new
# @todomain set by new
# @touser set by new
# $subject set by ReadQf
# @headers set by ReadQf # just the headers, with /^H/ removed
# Note @headers is read-only!
# @metadata set by ReadQf # the entire qf file excluding final "."
# $returnpathflags set by ReadQf # Only used for sendmail at the moment
# $clientip set by ReadQf
# $scanme set by NeedsScanning (from MsgBatch constructor)
# $workarea set by new
# @archiveplaces set by new (addresses and dirs)
# @quarantineplaces set by Quarantine.pm
# $spamwhitelisted set by IsSpam
# $spamblacklisted set by IsSpam
# $isspam set by IsSpam
# $issaspam set by IsSpam
# $isrblspam set by IsSpam
# $ishigh set by IsSpam
# $sascore set by IsSpam
# $spamreport set by IsSpam
# $mcpwhitelisted set by IsMCP
# $ismcp set by IsMCP
# $issamcp set by IsMCP
# $ishighmcp set by IsMCP
# $mcpsascore set by IsMCP
# $mcpreport set by IsMCP
# $deleted set by delivery functions
# $headerspath set by WriterHeaderFile # file is read-only
# $cantparse set by Explode
# $toomanyattach set by Explode
# $cantdisinfect set by ExplodeArchive
# $entity set by Explode
# $tnefentity set by Explode (only set if it's a TNEF message)
# $badtnef set by Explode
# $entity set by Explode
# %name2entity set by Explode
# %file2parent set by Explode
# $virusinfected set by new and ScanBatch
# $nameinfected set by new and ScanBatch
# $otherinfected set by new and ScanBatch
# $sizeinfected set by new and ScanBatch
# %virusreports set by TryCommercial (key is filename)
# %virustypes set by TryCommercial (key is filename)
# %namereports set by filename trap checker
# %nametypes set by filename trap checker
# %otherreports set by TryOther (key is filename)
# %othertypes set by TryOther (key is filename)
# %entityreports set by TryOther (key is entity)
# %oldviruses set by DisinfectAndDeliver
# $infected set by CombineReports
# %allreports set by CombineReports
# %alltypes set by CombineReports
# %entity2parent set by CreateEntitiesHelpers
# %entity2file set by CreateEntitiesHelpers
# %file2entity set by CreateEntitiesHelpers (maps original evil names)
# %file2safefile set by CreateEntitiesHelpers (evil==>safe)
# %safefile2file set by CreateEntitiesHelpers (safe==>evil)
# $numberparts set by CreateEntitiesHelpers
# $signed set by Clean
# $bodymodified set by Clean and SignUninfected
# $silent set by FindSilentAndNoisyInfections
# if infected with a silent virus
# $noisy set by FindSilentAndNoisyInfections
# if infected with a noisy virus
# $needsstripping set by HandleSpam and HandleMCP
# $stillwarn set by new # Still send warnings even if deleted
# $needsencapsulating set by HandleSpam and HAndleMCP
# %postfixrecips set by ReadQf in Postfix support only. Hash of all the
# 'R' addresses in the message to aid rebuilding.
# %originalrecips set by ReadQf in Postfix support only. Hash of all the
# 'O' addresses in the message to aid rebuilding.
# %deleteattach set by ScanBatch and CheckFiletypeRules. True if
# attachment is to be deleted rather than stored.
# $tagstoconvert set by ??? is list of HTML tags to dis-arm
# $gonefromdisk set by calls to DeleteUnlock
# $subjectwasunsafe set by SweepContent.pm
# $safesubject set by SweepContent.pm
# $mcpdelivering set by HandleMCP
# $salongreport set by SA::Checks (longest version of SA report)
# @spamarchive set by HandleHamAndSpam, list of places we have
# quarantined spam/mcp message. Used later to
# delete infected spam from spam quarantine.
# $dontdeliver set by HandleHamAndSpam, true if the message was put
# in the spam/mcp archive, but still needs to be
# virus-scanned so we can remove it again if
# necessary. But it doesn't need repairing, as we
# won't be delivering it anyway.
# $datenumber set by new
# $datestring set by new
# $messagedisarmed set by DisarmHTMLTree
# @disarmedtags All the HTML tags (incl. phishing) that we found
# and disarmed or highlighted.
# $quarantinedinfectionsset by QuarantineInfections, has this message already
# been quarantined, so doesn't need quarantining
# in QuarantineModifiedBodies.
# $actions set by HandleHamAndSpam, saves action list.
# $ret set by new, true if BarricadeMX RET hash is valid
#
# Constructor.
# Takes id.
# Takes options $fake which is just used for making an object for
# the command-line testing.
# This isn't specific to the MTA at all, so is all done here.
sub new {
my $type = shift;
my($id, $queuedirname, $fake) = @_;
my $this = {};
my($mta, $addr, $user, $domain);
my($archiveplaces);
#print STDERR "Creating message $id\n";
$this->{id} = $id;
@{$this->{archiveplaces}} = ();
@{$this->{spamarchive}} = ();
@{$this->{quarantineplaces}} = ();
if ($fake) {
bless $this, $type;
return $this;
}
# Create somewhere to store the message
$this->{store} = new MailScanner::SMDiskStore($id, $queuedirname);
# Try to open and exclusive-lock this message. Return undef if failed.
#print STDERR "Trying to lock message " . $this->{id} . "\n";
$this->{store}->Lock() or return undef;
#print STDERR "Locked message\n";
# Now try to fill as much of the structure as possible
$this->{size} = $this->{store}->size();
$global::MS->{mta}->ReadQf($this) or return 'INVALID'; # Return empty if fails
# Work out the user @ domain components
($user, $domain) = address2userdomain($this->{from});
$this->{fromuser} = $user;
$this->{fromdomain} = $domain;
foreach $addr (@{$this->{to}}) {
($user, $domain) = address2userdomain($addr);
push @{$this->{touser}}, $user;
push @{$this->{todomain}}, $domain;
}
# BarricadeMX mods
# Automatically detect if BarricadeMX is in use (clientip=127.0.0.1) and
# the second Received header contains 'ret-id'. If this is true then:
# 1) Override $this->{clientip} with the IP from the 2nd Received header.
# 2) If 'ret-id pass' is in the 2nd Received header, set $this->{ret}.
#
# Example:
#
# Received: from xxx.xxx.com (localhost.localdomain [127.0.0.1])
# by mail.fsg.com (8.13.1/8.13.1) with SMTP id xxxxxxxxxxxxxx
# for <xxx@xxx.com>; Sat, 13 Jan 2007 17:02:49 -0500
# Received: from xxxxxxxxxx.net (xxxxxxxx.xxxxxxxxxx.xxx [111.111.11.11])
# by xxxx.xxx.com (xxxx.xxx.com [192.168.111.11])
# id xxxxxxxxxxxxxxxxxx ret-id none; Sat, 13 Jan 2007 17:03:09 -0500
#
$this->{ret} = 0;
if($this->{clientip} eq '127.0.0.1') {
my($header_line, $last_rcvd, $last_rcvd_ip);
my($rcvd_count) = 0;
foreach $header_line (@{$this->{headers}}) {
# print STDERR "DEBUG: Header line: $header_line\n";
if($header_line =~ /ret-id/ && $rcvd_count == 2) {
$this->{clientip} = $last_rcvd_ip if ($last_rcvd_ip);
# print STDERR "DEBUG: Using received header $rcvd_count - IP: $last_rcvd_ip\n";
$this->{ret} = 1 if($header_line =~ /ret-id pass/i);
last;
}
if($header_line =~ /Received:/) {
$rcvd_count++;
$last_rcvd = $header_line;
my($rcvd_ip) = $last_rcvd =~ /\(.*\[(.+)\]\)/;
# print STDERR "DEBUG: $last_rcvd - IP: $rcvd_ip\n";
$last_rcvd_ip = $rcvd_ip;
last if $rcvd_count > 2;
}
}
}
# Reset the infection counters to 0
$this->{virusinfected} = 0;
$this->{nameinfected} = 0;
$this->{otherinfected} = 0;
$this->{sizeinfected} = 0;
$this->{stillwarn} = 0;
# Set the date string and number
$this->{datestring} = scalar localtime;
my($day, $month, $year, $date);
($day, $month, $year) = (localtime)[3,4,5];
$date = sprintf("%04d%02d%02d", $year+1900, $month+1, $day);
$this->{datenumber} = $date;
# Work out where to archive/copy this message.
# Could do all the archiving in a different separate place.
$archiveplaces = MailScanner::Config::Value('archivemail', $this);
if ($archiveplaces =~ /_DATE_/) {
# Only do the work for the date substitution if we really have to
$archiveplaces =~ s/_DATE_/$date/g;
#print STDERR "Archive location is $archiveplaces\n";
}
@{$this->{archiveplaces}} = ((defined $archiveplaces)?split(" ", $archiveplaces):());
# Decide if we want to scan this message at all
$this->{scanmail} = MailScanner::Config::Value('scanmail', $this);
$this->{scanmail} = 1 if $this->{scanmail} !~ /^[0\s]+$/;
bless $this, $type;
return $this;
}
# Take an email address. Return (user, domain).
sub address2userdomain {
my($addr) = @_;
my($user, $domain);
$addr = lc($addr);
$addr =~ s/^<\s*//; # Delete leading and
$addr =~ s/\s*>$//; # trailing <>
$user = $addr;
$domain = $addr;
if ($addr =~ /@/) {
$user =~ s/@[^@]*$//;
$domain =~ s/^[^@]*@//;
}
return ($user, $domain);
}
# Print a message
sub print {
my $this = shift;
print STDERR "Message " . $this->{id} . "\n";
print STDERR " Size = " . $this->{size} . "\n";
print STDERR " From = " . $this->{from} . "\n";
print STDERR " To = " . join(',',@{$this->{to}}) . "\n";
print STDERR " Subj = " . $this->{subject} . "\n";
}
# Get/Set "scanme" flag
sub NeedsScanning {
my($this, $value) = @_;
$this->{scanme} = $value if @_ > 1;
return $this->{scanme};
}
# Write the file containing all the message headers.
# Called by the MessageBatch constructor.
# Notes: assumes the directories required already exist.
sub WriteHeaderFile {
my $this = shift;
#my @headers;
my $header = new FileHandle;
my $filename = $global::MS->{work}->{dir} . '/' . $this->{id} . '.header';
$this->{headerspath} = $filename;
MailScanner::Lock::openlock($header, ">$filename", "w")
or MailScanner::Log::DieLog("Cannot create + lock headers file %s, %s",
$filename, $!);
#@headers = $global::MS->{mta}->OriginalMsgHeaders($this);
#print STDERR "Headers are " . join(', ', @headers) . "\n";
#foreach (@headers) {
foreach ($global::MS->{mta}->OriginalMsgHeaders($this)) {
tr/\r/\n/; # Work around Outlook [Express] bug allowing viruses in headers
print $header "$_\n";
}
print $header "\n";
MailScanner::Lock::unlockclose($header);
# Set the owner of the header file
chown $global::MS->{work}->{uid}, $global::MS->{work}->{gid}, $filename
if $global::MS->{work}->{changeowner};
}
# Is this message spam? Try to build the spam report and store it in
# the message.
sub IsSpam {
my $this = shift;
my($includesaheader, $iswhitelisted, $usegsscanner);
my $spamheader = "";
my $rblspamheader = "";
my $gsreport = "";
my $saspamheader = "";
my $RBLsaysspam = 0;
my $rblcounter = 0;
my $LogSpam = MailScanner::Config::Value('logspam');
my $LogNonSpam = MailScanner::Config::Value('lognonspam');
my $LocalSpamText = MailScanner::Config::LanguageValue($this, 'spam');
my $LocalNotSpamText = MailScanner::Config::LanguageValue($this, 'notspam');
# Construct a pretty list of all the unique domain names for logging
my(%todomain, $todomain);
foreach $todomain (@{$this->{todomain}}) {
$todomain{$todomain} = 1;
}
$todomain = join(',', keys %todomain);
my $recipientcount = @{$this->{to}};
# $spamwhitelisted set by IsSpam
# $spamblacklisted set by IsSpam
# $isspam set by IsSpam
# $ishigh set by IsSpam
# $spamreport set by IsSpam
$this->{spamwhitelisted} = 0;
$this->{spamblacklisted} = 0;
$this->{isspam} = 0;
$this->{ishigh} = 0;
$this->{spamreport} = "";
$this->{sascore} = 0;
# Work out if they always want the SA header
$includesaheader = MailScanner::Config::Value('includespamheader', $this);
# If they want the GS scanner then we must carry on too
$usegsscanner = MailScanner::Config::Value('gsscanner', $this);
# Do the whitelist check before the blacklist check.
# If anyone whitelists it, then everyone gets the message.
# If no-one has whitelisted it, then consider the blacklist.
$iswhitelisted = 0;
my $maxrecips = MailScanner::Config::Value('whitelistmaxrecips');
$maxrecips = 999999 unless $maxrecips;
# BarricadeMX mods
# Skip SpamAssassin if a valid RET hash is found ($this->{ret} == true)
if ($this->{ret}) {
MailScanner::Log::InfoLog("Valid RET hash found in Message %s, skipping Spam Checks",$this->{id});
return 0;
}
if ($recipientcount<=$maxrecips) {
if (MailScanner::Config::Value('spamwhitelist', $this)) {
# Whitelisted, so get out unless they want SA header
#print STDERR "Message is whitelisted\n";
MailScanner::Log::InfoLog("Message %s from %s (%s) is whitelisted",
$this->{id}, $this->{clientip}, $this->{from})
if $LogSpam || $LogNonSpam;
$iswhitelisted = 1;
$this->{spamwhitelisted} = 1;
# whitelisted and doesn't want SA header so get out
return 0 unless $includesaheader || $usegsscanner;
}
} else {
# Had too many recipients, ignoring the whitelist
MailScanner::Log::InfoLog("Message %s from %s (%s) ignored whitelist, " .
"had %d recipients (>%d)", $this->{id},
$this->{clientip}, $this->{from},
$recipientcount, $maxrecips)
if $LogSpam || $LogNonSpam;
}
# If it's a blacklisted address, don't bother doing any checks at all
if (!$iswhitelisted && MailScanner::Config::Value('spamblacklist', $this)) {
$this->{spamblacklisted} = 1;
$this->{isspam} = 1;
$this->{ishigh} = 1
if MailScanner::Config::Value('blacklistedishigh', $this);
$this->{spamreport} = $LocalSpamText . ' (' .
MailScanner::Config::LanguageValue($this, 'blacklisted') .
')';
MailScanner::Log::InfoLog("Message %s from %s (%s) to %s" .
" is spam (blacklisted)",
$this->{id}, $this->{clientip},
$this->{from}, $todomain)
if $LogSpam;
return 1;
}
my $whitelistreport = '';
if ($iswhitelisted) {
$whitelistreport = ' (' .
MailScanner::Config::LanguageValue($this, 'whitelisted') .
')';
}
#
# Check to see if message is too large to be likely to be spam.
#
my $maxtestsize = MailScanner::Config::Value('maxspamchecksize',$this);
if ($this->{size} > $maxtestsize) {
$this->{spamreport} = MailScanner::Config::LanguageValue($this, 'skippedastoobig');
$this->{spamreport} = $this->ReflowHeader(
MailScanner::Config::Value('spamheader',$this),
$this->{spamreport});
MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is too big for spam checks (%d > %d bytes)",
$this->{id}, $this->{clientip},
$this->{from}, $todomain,
$this->{size}, $maxtestsize);
return 0;
}
if (!$iswhitelisted) {
# Not whitelisted, so do the RBL checks
$0 = 'MailScanner: checking with Spam Lists';
($rblcounter, $rblspamheader) = MailScanner::RBLs::Checks($this);
my $rblthreshold = MailScanner::Config::Value('normalrbls', $this);
my $highrblthreshold = MailScanner::Config::Value('highrbls', $this);
$rblthreshold = 1 if $rblthreshold <= 1;
$highrblthreshold = 1 if $highrblthreshold <= 1;
$RBLsaysspam = 1 if $rblcounter >= $rblthreshold;
# Add leading "spam, " if RBL says it is spam. This will be at the
# front of the spam report.
$this->{isspam} = 1 if $RBLsaysspam;
$this->{isrblspam} = 1 if $RBLsaysspam;
$this->{ishigh} = 1 if $rblcounter >= $highrblthreshold;
}
# rblspamheader is useful start to spamreport if RBLsaysspam.
# Do the Custom Spam Checker
my($gsscore, $gsreport);
#print STDERR "In Message.pm about to look at gsscanner\n";
if ($usegsscanner) {
#print STDERR "In Message.pm about to run gsscanner\n";
($gsscore, $gsreport) = MailScanner::GenericSpam::Checks($this);
#print STDERR "In Message.pm we got $gsscore, $gsreport\n";
$this->{gshits} = $gsscore;
$this->{gsreport} = $gsreport;
$this->{sascore} = $gsscore; # Add the score
MailScanner::Log::InfoLog("Custom Spam Scanner for message %s from %s " .
"(%s) to %s report is %s %s",
$this->{id}, $this->{clientip},
$this->{from}, $todomain, $gsscore, $gsreport)
if $LogSpam && ($gsscore!=0 || $gsreport ne "");
}
# Don't do the SA checks if they have said no.
unless (MailScanner::Config::Value('usespamassassin', $this)) {
$this->{spamwhitelisted} = $iswhitelisted;
$this->{isspam} = 1
if $gsscore+0.0 >=
MailScanner::Config::Value('reqspamassassinscore',$this)+0.0;
$this->{ishigh} = 1
if $gsscore+0.0 >=
MailScanner::Config::Value('highspamassassinscore',$this)+0.0;
MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s",
$this->{id}, $this->{clientip},
$this->{from}, $todomain, $rblspamheader)
if $RBLsaysspam && $LogSpam;
# Replace start of report if it wasn't spam from rbl but now is.
$this->{spamreport} = ($this->{isspam})?$LocalSpamText:$LocalNotSpamText;
$this->{spamreport} .= $whitelistreport;
$this->{spamreport} .= ', ' if $this->{spamreport};
$this->{spamreport} .= $rblspamheader if $rblspamheader;
$this->{spamreport} .= ', ' if $this->{spamreport} && $rblspamheader;
$this->{spamreport} .= $gsscore+0.0 if $gsscore!=0;
$this->{spamreport} .= ', ' if $this->{spamreport} && $gsscore!=0;
$this->{spamreport} .= $gsreport if $gsreport ne "";
$this->{spamreport} = $this->ReflowHeader(
MailScanner::Config::Value('spamheader',$this),
$this->{spamreport});
return $this->{isspam};
}
# If it's spam and they dont want to check SA as well
if ($this->{isspam} &&
!MailScanner::Config::Value('checksaifonspamlist', $this)) {
$this->{spamwhitelisted} = $iswhitelisted;
MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s",
$this->{id}, $this->{clientip},
$this->{from}, $todomain, $rblspamheader)
if $RBLsaysspam && $LogSpam;
# Replace start of report if it wasn't spam from rbl but now is.
$this->{spamreport} = ($this->{isspam})?$LocalSpamText:$LocalNotSpamText;
$this->{spamreport} .= $whitelistreport;
$this->{spamreport} .= ', ' if $this->{spamreport};
$this->{spamreport} .= $rblspamheader if $rblspamheader;
$this->{spamreport} .= ', ' if $this->{spamreport} && $rblspamheader;
$this->{spamreport} .= $gsscore+0.0 if $gsscore!=0;
$this->{spamreport} .= ', ' if $this->{spamreport} && $gsscore!=0;
$this->{spamreport} .= $gsreport if $gsreport ne "";
$this->{spamreport} = $this->ReflowHeader(
MailScanner::Config::Value('spamheader',$this),
$this->{spamreport});
return $RBLsaysspam;
}
# They must want the SA checks doing.
my $SAsaysspam = 0;
my $SAHighScoring = 0;
my $saheader = "";
my $sascore = 0;
my $salongreport = "";
$0 = 'MailScanner: checking with SpamAssassin';
($SAsaysspam, $SAHighScoring, $saheader, $sascore, $salongreport)
= MailScanner::SA::Checks($this);
$this->{sascore} += $sascore; # Save the actual figure for use later...
# Trim all the leading rubbish off the long SA report and turn it back
# into a multi-line string, then store it in the message properties.
$salongreport =~ s/^.* pts rule name/ pts rule name/;
$salongreport =~ tr/\0/\n/;
$this->{salongreport} = $salongreport;
#print STDERR $salongreport . "\n";
# Fix the return values
$SAsaysspam = 0 unless $saheader; # Solve bug with empty SAreports
$saheader =~ s/\s+$//g if $saheader; # Solve bug with trailing space
#print STDERR "SA report is \"$saheader\"\n";
#print STDERR "SAsaysspam = $SAsaysspam\n";
$saheader = MailScanner::Config::LanguageValue($this, 'spamassassin') .
" ($saheader)" if $saheader;
# The message really is spam if SA says so (unless it's been whitelisted)
unless ($iswhitelisted) {
$this->{isspam} |= $SAsaysspam;
$this->{issaspam} = $SAsaysspam;
}
# If it's spam...
if ($this->{isspam}) {
#print STDERR "It is spam\nInclude SA = $includesaheader\n";
#print STDERR "SAHeader = $saheader\n";
# If it's SA spam as well, or they always want the SA header
if ($SAsaysspam || $includesaheader) {
#print STDERR "Spam or Add SA Header\n";
$this->{ishigh} = 1 if $SAHighScoring;
$this->{spamreport} = ($this->{isspam})?$LocalSpamText:$LocalNotSpamText;
$this->{spamreport} .= $whitelistreport;
$this->{spamreport} .= ', ' if $this->{spamreport};
$this->{spamreport} .= $rblspamheader if $rblspamheader;
$this->{spamreport} .= ', ' if $this->{spamreport} && $rblspamheader;
$this->{spamreport} .= $gsscore+0.0 if $gsscore!=0;
$this->{spamreport} .= ', ' if $this->{spamreport} && $gsscore!=0;
$this->{spamreport} .= $gsreport if $gsreport ne "";
$this->{spamreport} .= ', ' if $this->{spamreport} && $gsreport;
$this->{spamreport} .= $saheader if $saheader ne "";
}
} else {
# It's not spam...
#print STDERR "It's not spam\n";
#print STDERR "SAHeader = $saheader\n";
$this->{spamreport} = ($this->{isspam})?$LocalSpamText:$LocalNotSpamText;
$this->{spamreport} .= $whitelistreport;
$this->{spamreport} .= ', ' if $this->{spamreport};
$this->{spamreport} .= $rblspamheader if $rblspamheader;
$this->{spamreport} .= ', ' if $this->{spamreport} && $rblspamheader;
$this->{spamreport} .= $gsscore+0.0 if $gsscore!=0;
$this->{spamreport} .= ', ' if $this->{spamreport} && $gsscore!=0;
$this->{spamreport} .= $gsreport if $gsreport ne "";
$this->{spamreport} .= ', ' if $this->{spamreport} && $gsreport;
$this->{spamreport} .= $saheader if $saheader ne "";
}
# Do the spam logging here so we can log high-scoring spam too
if (($LogSpam && $this->{isspam}) || ($LogNonSpam && !$this->{isspam})) {
my $ReportText = $this->{spamreport};
$ReportText =~ s/\s+/ /sg;
MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s",
$this->{id}, $this->{clientip},
$this->{from}, $todomain, $ReportText);
}
# Now just reflow and log the results
if ($this->{spamreport} ne "") {
$this->{spamreport} = $this->ReflowHeader(
MailScanner::Config::Value('spamheader',$this),
$this->{spamreport});
}
return $this->{isspam};
}
# Do whatever is necessary with this message to deal with spam.
# We can assume the message passed is indeed spam (isspam==true).
# Call it with either 'spam' or 'nonspam'. Don't use 'ham'!
sub HandleHamAndSpam {
my($this, $HamSpam) = @_;
my($actions, $action, @actions, %actions);
my(@extraheaders, $actionscopy, $actionkey);
# Set default action for DMX/MailWatch reporting
$this->{actions} = 'deliver';
# Get a space-separated list of all the actions
if ($HamSpam eq 'nonspam') {
#print STDERR "Looking up hamactions\n";
$actions = MailScanner::Config::Value('hamactions', $this);
# Fast bail-out if it's just the simple "deliver" case that 99% of
# people will use
return if $actions eq 'deliver';
} else {
# It must be spam as it's not ham
if ($this->{ishigh}) {
#print STDERR "Looking up highscorespamactions\n";
$actions = MailScanner::Config::Value('highscorespamactions', $this);
} else {
#print STDERR "Looking up spamactions\n";
$actions = MailScanner::Config::Value('spamactions', $this);
}
}
# Find all the bits in quotes, with their spaces
$actionscopy = $actions;
#print STDERR "Actions = \'$actions\'\n";
while ($actions =~ s/\"([^\"]+)\"//) {
$actionkey = $1;
#print STDERR "ActionKey = $actionkey and $1\n";
push @extraheaders, $actionkey;
MailScanner::Log::WarnLog("Syntax error in \"header\" action in spam " .
"actions, missing \":\" in %s", $actionkey)
unless $actionkey =~ /:/;
}
@{$this->{extraspamheaders}} = @extraheaders;
$actions = lc($actions);
$actions =~ s/^\s*//;
$actions =~ s/\s*$//;
$actions =~ s/\s+/ /g;
#print STDERR "Actions after = \'$actions\'\n";
#print STDERR "Extra headers are \"" . join(',',@extraheaders) . "\"\n";
MailScanner::Log::WarnLog('Syntax error: missing " in spam actions %s',
$actionscopy) if $actions =~ /\"/;
$actions =~ tr/,//d; # Remove all commas in case they put any in
@actions = split(" ", $actions);
#print STDERR "Actions are $actions\n";
# The default action if they haven't specified anything is to
# deliver spam like normal mail.
return unless @actions;
# If they have just specified a filename, then something is wrong
if ($#actions==0 && $actions[0] =~ /\//) {
MailScanner::Log::WarnLog('Your spam actions "%s" looks like a filename.' .
' If this is a ruleset filename, it must end in .rule or .rules',
$actions[0]);
$actions[0] = 'deliver';
}
#print STDERR "Message: HandleHamSpam has actions " . join(',',@actions) .
# "\n";
# Save actions for DMX/MailWatch reporting
$this->{actions} = join(',', @actions);
my %lintoptions;
foreach $action (@actions) {
$lintoptions{$action} = 1;
# If the message is a MCP message then don't do the ham/spam "deliver"
# as the MCP actions will have provided a "deliver" if they want one.
next if $this->{ismcp} && $action eq 'deliver';
$actions{$action} = 1;
#print STDERR "Message: HandleSpam action is $action\n";
if ($action =~ /\@/) {
#print STDERR "Message " . $this->{id} . " : HandleSpam() adding " .
# "$action to archiveplaces\n";
push @{$this->{archiveplaces}}, $action;
$actions{'forward'} = 1;
delete $lintoptions{$action}; # Can't syntax-check email addresses
}
}
# Do the syntax check
delete $lintoptions{'deliver'};
delete $lintoptions{'delete'};
delete $lintoptions{'store'};
delete $lintoptions{'bounce'};
delete $lintoptions{'forward'};
delete $lintoptions{'striphtml'};
delete $lintoptions{'attachment'};
delete $lintoptions{'notify'};
delete $lintoptions{'header'};
my $lintstring = join(' ',keys %lintoptions);
if ($lintstring ne '') {
my $lints = ($lintstring =~ / /)?'s':'';
my $linttype;
if ($HamSpam eq 'nonspam') {
$linttype = 'Non-Spam';
} else {
if ($this->{ishigh}) {
$linttype = 'High-Scoring Spam';
} else {
$linttype = 'Spam';
}
}
MailScanner::Log::WarnLog("Message %s produced illegal %s Action%s " .
"\"%s\", so message is being delivered",
$this->{id}, $linttype, $lints, $lintstring);
#print STDERR sprintf("Message %s produced illegal %s Action%s " .
# "\"%s\", so message is being delivered\n",
# $this->{id}, $linttype, $lints, $lintstring);
# We found an error so fail-safe by delivering the message
$actions{'deliver'} = 1;
}
# Now we are left with deliver, bounce, delete, store and striphtml.
#print STDERR "Archive places are " . join(',', keys %actions) . "\n";
# Split this job into 2.
# 1) The message is being delivered to at least 1 address,
# 2) The message is not being delivered to anyone.
# The extra addresses for forward it to have already been added.
if ($actions{'deliver'} || $actions{'forward'} || $this->{mcpdelivering}) {
#
# Message is going to original recipient and/or extra recipients
#
MailScanner::Log::NoticeLog("Spam Actions: message %s actions are %s",
$this->{id}, join(',', keys %actions))
if $HamSpam eq 'spam' && MailScanner::Config::Value('logspam');
# Delete the original recipient if they are only forwarding it
$global::MS->{mta}->DeleteRecipients($this) if !$actions{'deliver'};
# Delete action is over-ridden as we are sending it somewhere
delete $actions{'delete'};
# Message still exists, so it will be delivered to its new recipients
} else {
#
# Message is not going to be delivered anywhere
#
MailScanner::Log::NoticeLog("Spam Actions: message %s actions are %s",
$this->{id}, join(',', keys %actions))
if $HamSpam eq 'spam' && MailScanner::Config::Value('logspam');
# Mark the message so it won't get cleaned up or delivered, but just dropped
#print STDERR "Setting DontDeliver for " . $this->{id} . "\n";
$this->{dontdeliver} = 1;
# Optimisation courtesy of Yavor.Trapkov@wipo.int
$this->{deleted} = 1 if (keys %actions) == 1 && $actions{'delete'};
## Mark the message as deleted, so it won't get delivered
#$this->{deleted} = 1;
}
# All delivery will now happen correctly.
# Bounce a message back to the sender if they want that
if ($actions{'bounce'}) {
if ($HamSpam eq 'nonspam') {
MailScanner::Log::WarnLog("Does not make sense to bounce non-spam");
} else {
#MailScanner::Log::WarnLog('The "bounce" Spam Action no longer exists');
if ($this->{ishigh}) {
MailScanner::Log::NoticeLog("Will not bounce high-scoring spam")
} else {
$this->HandleSpamBounce()
if MailScanner::Config::Value('enablespambounce', $this);
}
}
}
# Notify the recipient if they want that
if ($actions{'notify'}) {
if ($HamSpam eq 'nonspam') {
MailScanner::Log::WarnLog("Does not make sense to notify recipient about non-spam");
} else {
$this->HandleSpamNotify();
}
}
# Store it if they want that
if ($actions{'store'}) {
my($dir, $dir2, $spamdir, $uid, $gid, $changeowner);
$uid = $global::MS->{quar}->{uid};
$gid = $global::MS->{quar}->{gid};
$changeowner = $global::MS->{quar}->{changeowner};
$dir = MailScanner::Config::Value('quarantinedir', $this);
#$dir2 = $dir . '/' . MailScanner::Quarantine::TodayDir();
$dir2 = $dir . '/' . $this->{datenumber};
$spamdir = $dir2 . '/' . $HamSpam;
#print STDERR "dir = $dir\ndir2 = $dir2\nspamdir = $spamdir\n";
umask $global::MS->{quar}->{dirumask};
unless (-d $dir) {
mkdir $dir, 0777;
chown $uid, $gid, $dir if $changeowner;
}
unless (-d $dir2) {
mkdir $dir2, 0777;
chown $uid, $gid, $dir2 if $changeowner;
}
unless (-d $spamdir) {
mkdir $spamdir, 0777;
chown $uid, $gid, $spamdir if $changeowner;
}
#print STDERR "Storing spam to $spamdir/" . $this->{id} . "\n";
#print STDERR "uid=$uid gid=$gid changeowner=$changeowner\n";
umask $global::MS->{quar}->{fileumask};
my @paths = $this->{store}->CopyEntireMessage($this, $spamdir, $this->{id},
$uid, $gid, $changeowner);
# Remember where we have stored the spam in an archive, so we never
# archive infected messages
#print STDERR "Added " . join(',', @paths) . " to spamarchive\n";
push @{$this->{spamarchive}}, @paths;
chown $uid, $gid, "$spamdir/" . $this->{id}; # Harmless if this fails
}
umask 0077; # Safety net
# If they want to strip the HTML tags out of it,
# then just tag it as we can only do this later.
$this->{needsstripping} = 1 if $actions{'striphtml'};
# If they want to encapsulate the message in an RFC822 part,
# then tag it so we can do this later.
$this->{needsencapsulating} = 1 if $actions{'attachment'};
}
# We want to send a message back to the sender saying that their junk
# email has been rejected by our site.
# Send a message back to the sender which has the local postmaster as
# the header sender, but <> as the envelope sender. This means it
# cannot bounce.
# Now have 3 different message file settings:
# 1. Is spam according to RBL's
# 2. Is spam according to SpamAssassin
# 3. Is spam according to both
sub HandleSpamBounce {
my $this = shift;
my($from,$to,$subject,$date,$spamreport,$longspamreport,$hostname);
my($emailmsg, $line, $messagefh, $filename, $localpostmaster, $id);
my($postmastername);
$from = $this->{from};
# Don't ever send a message to "" or "<>"
return if $from eq "" || $from eq "<>";
# Do we want to send the sender a warning at all?
# If nosenderprecedence is set to non-blank and contains this
# message precedence header, then just return.
my(@preclist, $prec, $precedence, $header);
@preclist = split(" ",
lc(MailScanner::Config::Value('nosenderprecedence', $this)));
$precedence = "";
foreach $header (@{$this->{headers}}) {
$precedence = lc($1) if $header =~ /^precedence:\s+(\S+)/i;
}
if (@preclist && $precedence ne "") {
foreach $prec (@preclist) {
if ($precedence eq $prec) {
MailScanner::Log::InfoLog("Skipping sender of precedence %s",
$precedence);
return;
}
}
}
# Setup other variables they can use in the message template
$id = $this->{id};
#$to = join(', ', @{$this->{to}});
$localpostmaster = MailScanner::Config::Value('localpostmaster', $this);
$postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner');
$hostname = MailScanner::Config::Value('hostname', $this);
$subject = $this->{subject};
$date = $this->{datestring}; # scalar localtime;
$spamreport = $this->{spamreport};
$longspamreport = $this->{salongreport};
#print STDERR "longspamreport = \"$longspamreport\"\n";
my($to, %tolist);
foreach $to (@{$this->{to}}) {
$tolist{$to} = 1;
}
$to = join(', ', sort keys %tolist);
# Delete everything in brackets after the SA report, if it exists
$spamreport =~ s/(spamassassin)[^(]*\([^)]*\)/$1/i;
# Work out which of the 3 spam reports to send them.
$filename = "";
if ($this->{isrblspam} && !$this->{issaspam}) {
$filename = MailScanner::Config::Value('senderrblspamreport', $this);
MailScanner::Log::NoticeLog("Spam Actions: (RBL) Bounce to %s", $from)
if MailScanner::Config::Value('logspam');
} elsif ($this->{issaspam} && !$this->{isrblspam}) {
$filename = MailScanner::Config::Value('sendersaspamreport', $this);
MailScanner::Log::NoticeLog("Spam Actions: (SpamAssassin) Bounce to %s",
$from)
if MailScanner::Config::Value('logspam');
}
if ($filename eq "") {
$filename = MailScanner::Config::Value('senderbothspamreport', $this);
MailScanner::Log::NoticeLog("Spam Actions: (RBL,SpamAssassin) Bounce to %s",
$from)
if MailScanner::Config::Value('logspam');
}
$messagefh = new FileHandle;
$messagefh->open($filename)
or MailScanner::Log::WarnLog("Cannot open message file %s, %s",
$filename, $!);
$emailmsg = "X-MailScanner-Bounce: yes\n";
while(<$messagefh>) {
chomp;
s#"#\\"#g;
s#@#\\@#g;
# Boring untainting again...
/(.*)/;
# Bug fix by Martin Hepworth
$line = eval "\"$1\"";
$emailmsg .= MailScanner::Config::DoPercentVars($line) . "\n";
}
$messagefh->close();
if (MailScanner::Config::Value('bouncespamasattachment', $this)) {
$this->HandleSpamBounceAttachment($emailmsg);
} else {
# Send the message to the spam sender, but ensure the envelope
# sender address is "<>" so that it can't be bounced.
$global::MS->{mta}->SendMessageString($this, $emailmsg, '<>')
or MailScanner::Log::WarnLog("Could not send sender spam bounce, %s", $!);
}
}
# Like encapsulating and sending a message to the recipient, take the
# passed text as the text and headers of an email message and attach
# the original message as an rfc/822 attachment.
sub HandleSpamBounceAttachment {
my($this, $plaintext) = @_;
my $parser = MIME::Parser->new;
my $explodeinto = $global::MS->{work}->{dir} . '/' . $this->{id};
#print STDERR "Extracting spam bounce message into $explodeinto\n";
my $filer = MIME::Parser::FileInto->new($explodeinto);
$parser->filer($filer);
my $bounce = eval { $parser->parse_data(\$plaintext) };
if (!$bounce) {
MailScanner::Log::WarnLog("Cannot parse spam bounce report, %s", $!);
return;
}
#print STDERR "Successfully parsed bounce report\n";
# Now make it multipart and push the report into a child
$bounce->make_multipart('report');
# Now turn the original message into a string and attach it
my(@original);
#my $original = $this->{entity}->stringify;
@original = $global::MS->{mta}->OriginalMsgHeaders($this, "\n");
push(@original, "\n");
$this->{store}->ReadBody(\@original, MailScanner::Config::Value(
'maxspamassassinsize'));
$bounce->add_part(MIME::Entity->build(Type => 'message/rfc822',
Disposition => 'attachment',
Top => 0,
'X-Mailer' => undef,
Data => \@original));
# Prune all the dead branches off the tree
PruneEntityTree($bounce);
# Stringify the message and send it -- this could be VERY large!
my $bouncetext = $bounce->stringify;
#print STDERR "Spam bounce message is this:\n$bouncetext";
if ($bouncetext) {
$global::MS->{mta}->SendMessageString($this, $bouncetext, '<>')
or MailScanner::Log::WarnLog(
"Could not send sender spam bounce attachment, %s", $!);
} else {
MailScanner::Log::WarnLog(
"Failed to create sender spam bounce attachment, %s", $!);
}
}
# We want to send a message to the recipient saying that their spam
# mail has not been delivered.
# Send a message to the recipients which has the local postmaster as
# the sender.
sub HandleSpamNotify {
my $this = shift;
my($from,$to,$subject,$date,$spamreport,$hostname,$day,$month,$year);
my($emailmsg, $line, $messagefh, $filename, $localpostmaster, $id);
my($postmastername);
$from = $this->{from};
# Don't ever send a message to "" or "<>"
return if $from eq "" || $from eq "<>";
# Do we want to send the sender a warning at all?
# If nosenderprecedence is set to non-blank and contains this
# message precedence header, then just return.
my(@preclist, $prec, $precedence, $header);
@preclist = split(" ",
lc(MailScanner::Config::Value('nosenderprecedence', $this)));
$precedence = "";
foreach $header (@{$this->{headers}}) {
$precedence = lc($1) if $header =~ /^precedence:\s+(\S+)/i;
}
if (@preclist && $precedence ne "") {
foreach $prec (@preclist) {
if ($precedence eq $prec) {
MailScanner::Log::InfoLog("Skipping sender of precedence %s",
$precedence);
return;
}
}
}
# Setup other variables they can use in the message template
$id = $this->{id};
$localpostmaster = MailScanner::Config::Value('localpostmaster', $this);
$postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner');
$hostname = MailScanner::Config::Value('hostname', $this);
$subject = $this->{subject};
$date = $this->{datestring}; # scalar localtime;
$spamreport = $this->{spamreport};
# And let them put the date number in there too
#($day, $month, $year) = (localtime)[3,4,5];
#$month++;
#$year += 1900;
#my $datenumber = sprintf("%04d%02d%02d", $year, $month, $day);
my $datenumber = $this->{datenumber};
my($to, %tolist);
foreach $to (@{$this->{to}}) {
$tolist{$to} = 1;
}
$to = join(', ', sort keys %tolist);
# Delete everything in brackets after the SA report, if it exists
$spamreport =~ s/(spamassassin)[^(]*\([^)]*\)/$1/i;
# Work out which of the 3 spam reports to send them.
$filename = MailScanner::Config::Value('recipientspamreport', $this);
MailScanner::Log::NoticeLog("Spam Actions: Notify %s", $to)
if MailScanner::Config::Value('logspam');
$messagefh = new FileHandle;
$messagefh->open($filename)
or MailScanner::Log::WarnLog("Cannot open message file %s, %s",
$filename, $!);
$emailmsg = "";
while(<$messagefh>) {
chomp;
s#"#\\"#g;
s#@#\\@#g;
# Boring untainting again...
/(.*)/;
$line = eval "\"$1\"";
$emailmsg .= MailScanner::Config::DoPercentVars($line) . "\n";
}
$messagefh->close();
# Send the message to the spam sender, but ensure the envelope
# sender address is "<>" so that it can't be bounced.
$global::MS->{mta}->SendMessageString($this, $emailmsg, $localpostmaster)
or MailScanner::Log::WarnLog("Could not send sender spam notify, %s", $!);
}
sub RejectMessage {
my $this = shift;
my($from,$to,%tolist,$subject,$date,$hostname);
my($emailmsg, $line, $messagefh, $filename, $localpostmaster, $id);
my($postmastername);
$from = $this->{from};
# Don't ever send a message to "" or "<>"
return if $from eq "" || $from eq "<>";
# Setup other variables they can use in the message template
$id = $this->{id};
$localpostmaster = MailScanner::Config::Value('localpostmaster', $this);
$postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner');
$hostname = MailScanner::Config::Value('hostname', $this);
$subject = $this->{subject};
$date = $this->{datestring}; # scalar localtime;
foreach $to (@{$this->{to}}) {
$tolist{$to} = 1;
}
$to = join(', ', sort keys %tolist);
# Work out which of the 3 spam reports to send them.
$filename = MailScanner::Config::Value('rejectionreport', $this);
MailScanner::Log::NoticeLog("Reject message %s from %s with report %s",
$id, $from, $filename);
return if $filename eq "";
#print STDERR "Rejecting message $id with $filename\n";
$messagefh = new FileHandle;
$messagefh->open($filename)
or MailScanner::Log::WarnLog("Cannot open message file %s, %s",
$filename, $!);
$emailmsg = "X-MailScanner-Rejected: yes\n";
while(<$messagefh>) {
chomp;
s#"#\\"#g;
s#@#\\@#g;
# Boring untainting again...
/(.*)/;
$line = eval "\"$1\"";
$emailmsg .= MailScanner::Config::DoPercentVars($line) . "\n";
}
$messagefh->close();
#print STDERR "Rejection is:\n-----SNIP-----\n$emailmsg-----SNIP-----\n";
# Send the message to the spam sender, but ensure the envelope
# sender address is "<>" so that it can't be bounced.
$global::MS->{mta}->SendMessageString($this, $emailmsg, '<>')
or MailScanner::Log::WarnLog("Could not send rejection report for %s, %s",
$id, $!);
$this->{deleted} = 1;
$this->{dontdeliver} = 1;
}
# Like encapsulating and sending a message to the recipient, take the
# Deliver a message that doesn't want to be touched at all in any way.
# Take an out queue dir.
sub DeliverUntouched {
my $this = shift;
my($OutQ) = @_;
return if $this->{deleted};
#my $OutQ = MailScanner::Config::Value('outqueuedir', $this);
my $store = $this->{store};
# Link the queue data file from in to out
$store->LinkData($OutQ);
# Add the headers onto the metadata in the message store
$global::MS->{mta}->AddHeadersToQf($this);
# Add the secret archive recipients
my($extra, @extras);
foreach $extra (@{$this->{archiveplaces}}) {
# Email archive recipients include a '@'
next if $extra =~ /^\//;
next unless $extra =~ /@/;
push @extras, $extra;
}
$global::MS->{mta}->AddRecipients($this, @extras) if @extras;
# Write the new qf file, delete originals and unlock the message
$store->WriteHeader($this, $OutQ);
unless ($this->{gonefromdisk}) {
$store->DeleteUnlock();
$this->{gonefromdisk} = 1;
}
# Note this does not kick the MTA into life here any more
}
# Deliver a message that doesn't need scanning at all
# Takes an out queue dir.
sub DeliverUnscanned {
my $this = shift;
my($OutQ) = @_;
return if $this->{deleted};
#my $OutQ = MailScanner::Config::Value('outqueuedir', $this);
my $store = $this->{store};
# Link the queue data file from in to out
$store->LinkData($OutQ);
# Add the headers onto the metadata in the message store
$global::MS->{mta}->AddHeadersToQf($this);
# Remove duplicate subject: lines
$global::MS->{mta}->UniqHeader($this, 'Subject:');
# Add the information/help X- header
my $infoheader = MailScanner::Config::Value('infoheader', $this);
if ($infoheader) {
my $infovalue = MailScanner::Config::Value('infovalue', $this);
$global::MS->{mta}->ReplaceHeader($this, $infoheader, $infovalue);
}
# Add the Unscanned X- header
if (MailScanner::Config::Value('signunscannedmessages', $this)) {
$global::MS->{mta}->AddMultipleHeader($this, 'mailheader',
MailScanner::Config::Value('unscannedheader', $this), ', ');
}
# Remove any headers we don't want in the message
my(@removeme, $remove);
@removeme = split(/[,\s]+/, MailScanner::Config::Value('removeheaders', $this));
foreach $remove (@removeme) {
# Add a : if there isn't one already, it's needed for DeleteHeader()
$remove .= ':' unless $remove =~ /:$/;
$global::MS->{mta}->DeleteHeader($this, $remove);
}
# Leave old content-length: headers as we aren't changing body.
# Add the MCP headers if necessary
$global::MS->{mta}->AddMultipleHeader($this, 'mcpheader',
$this->{mcpreport}, ', ')
if $this->{ismcp} ||
MailScanner::Config::Value('includemcpheader', $this);
# Add spam header if it's spam or they asked for it
#$global::MS->{mta}->AddHeader($this,
# MailScanner::Config::Value('spamheader',$this),
# $this->{spamreport})
# JKF 3/10/2005
$global::MS->{mta}->AddMultipleHeader($this, 'spamheader',
$this->{spamreport}, ', ')
if MailScanner::Config::Value('includespamheader', $this) ||
($this->{spamreport} && $this->{isspam});
# Add the spam stars if they want that. Limit it to 60 characters to avoid
# a potential denial-of-service attack.
my($stars,$starcount,$scoretext,$minstars,$scorefmt);
$starcount = int($this->{sascore}) + 0;
$starcount = 0 if $this->{spamwhitelisted}; # 0 stars if white-listed
$scorefmt = MailScanner::Config::Value('scoreformat', $this);
$scorefmt = '%d' if $scorefmt eq '';
$scoretext = sprintf($scorefmt, $this->{sascore}+0);
$minstars = MailScanner::Config::Value('minstars', $this);
$starcount = $minstars if $this->{isrblspam} && $minstars &&
$starcount<$minstars;
if (MailScanner::Config::Value('spamscorenotstars', $this)) {
$stars = $scoretext; # int($starcount);
} else {
$starcount = 60 if $starcount>60;
$stars = MailScanner::Config::Value('spamstarscharacter') x $starcount;
}
if (MailScanner::Config::Value('spamstars', $this) =~ /1/ && $starcount>0) {
$global::MS->{mta}->AddMultipleHeader($this, 'spamstarsheader',
$stars, ', ');
}
# Add the Envelope to and from headers
AddFromAndTo($this);
# Repair the subject line
$global::MS->{mta}->ReplaceHeader($this, 'Subject:', $this->{safesubject})
if $this->{subjectwasunsafe};
# Modify the subject line for Disarming
my $disarmtag = MailScanner::Config::Value('disarmsubjecttext',$this);
#if ($this->{messagedisarmed} &&
# MailScanner::Config::Value('disarmprependsubject',$this) =~ /1/ &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' ');
#}
if ($this->{messagedisarmed}) {
#print STDERR "Message has been disarmed at 1346.\n";
my $where = MailScanner::Config::Value('disarmmodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $disarmtag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $disarmtag, ' ');
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' ');
}
}
# Modify the subject line for spam
# if it's spam AND they want to modify the subject line AND it's not
# already been modified by another of your MailScanners.
my $spamtag = MailScanner::Config::Value('spamsubjecttext', $this);
$spamtag =~ s/_SCORE_/$scoretext/;
$spamtag =~ s/_STARS_/$stars/i;
#if ($this->{isspam} && !$this->{ishigh} &&
# MailScanner::Config::Value('spamprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
#}
if ($this->{isspam} && !$this->{ishigh}) {
my $where = MailScanner::Config::Value('spammodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' ');
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
}
}
# If it is high-scoring spam, then add a different bit of text
$spamtag = MailScanner::Config::Value('highspamsubjecttext', $this);
$spamtag =~ s/_SCORE_/$scoretext/;
$spamtag =~ s/_STARS_/$stars/i;
#if ($this->{isspam} && $this->{ishigh} &&
# MailScanner::Config::Value('highspamprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
#}
if ($this->{isspam} && $this->{ishigh}) {
my $where = MailScanner::Config::Value('highspammodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' ');
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
}
}
# Modify the subject line for MCP
# if it's MCP AND they want to modify the subject line AND it's not
# already been modified by another of your MailScanners.
$starcount = int($this->{mcpsascore}) + 0;
$starcount = 0 if $this->{mcpwhitelisted}; # 0 stars if white-listed
$scorefmt = MailScanner::Config::Value('scoreformat', $this);
$scorefmt = '%d' if $scorefmt eq '';
$scoretext = sprintf($scorefmt, $this->{mcpsascore}+0);
my $mcptag = MailScanner::Config::Value('mcpsubjecttext', $this);
$mcptag =~ s/_SCORE_/$scoretext/;
$mcptag =~ s/_STARS_/$stars/i;
#if ($this->{ismcp} && !$this->{ishighmcp} &&
# MailScanner::Config::Value('mcpprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
#}
if ($this->{ismcp} && !$this->{ishighmcp}) {
my $where = MailScanner::Config::Value('mcpmodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' ');
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
}
}
# If it is high-scoring MCP, then add a different bit of text
$mcptag = MailScanner::Config::Value('highmcpsubjecttext', $this);
$mcptag =~ s/_SCORE_/$scoretext/;
$mcptag =~ s/_STARS_/$stars/i;
#if ($this->{ismcp} && $this->{ishighmcp} &&
# MailScanner::Config::Value('highmcpprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
#}
if ($this->{ismcp} && $this->{ishighmcp}) {
my $where = MailScanner::Config::Value('highmcpmodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' ');
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
}
}
# Add the extra headers they want for MCP and spam messages
my(@extraheaders, $extraheader);
my($key, $value);
@extraheaders = @{$this->{extramcpheaders}} if $this->{extramcpheaders};
push @extraheaders, @{$this->{extraspamheaders}} if $this->{extraspamheaders};
foreach $extraheader (@extraheaders) {
next unless $extraheader =~ /:/;
($key, $value) = split(/:\s*/, $extraheader, 2);
$global::MS->{mta}->AddMultipleHeaderName($this, $key . ':', $value, ', ');
}
# Add the secret archive recipients
my($extra, @extras);
foreach $extra (@{$this->{archiveplaces}}) {
# Email archive recipients include a '@'
next if $extra =~ /^\//;
next unless $extra =~ /@/;
push @extras, $extra;
}
$global::MS->{mta}->AddRecipients($this, @extras) if @extras;
# Write the new qf file, delete originals and unlock the message
$store->WriteHeader($this, $OutQ);
unless ($this->{gonefromdisk}) {
$store->DeleteUnlock();
$this->{gonefromdisk} = 1;
}
# Note this does not kick the MTA into life here any more
}
# Add the X-Envelope-From and X-Envelope-To headers
sub AddFromAndTo {
my $this = shift;
my($to, %tolist, $from, $envtoheader);
# Do they all want the From header
if (MailScanner::Config::Value('addenvfrom', $this) !~ /0/) {
$from = $this->{from};
$global::MS->{mta}->ReplaceHeader($this,
MailScanner::Config::Value('envfromheader', $this),
$from);
}
# Do they all want the To header
if (MailScanner::Config::Value('addenvto', $this) =~ /^[1\s]+$/) {
# Get the actual text for the header value
foreach $to (@{$this->{to}}) {
$tolist{$to} = 1;
}
$to = join(', ', sort keys %tolist);
$envtoheader = MailScanner::Config::Value('envtoheader', $this);
# Now reflow the To list in case it is very long
$to = $this->ReflowHeader($envtoheader, $to);
$global::MS->{mta}->ReplaceHeader($this, $envtoheader, $to);
}
}
# Replace the attachments of the message with a zip archive
# containing them all.
sub ZipAttachments {
my $this = shift;
return if $this->{deleted};
return unless MailScanner::Config::Value('zipattachments', $this) =~ /1/;
my $workarea = $global::MS->{work};
my $explodeinto = $workarea->{dir} . "/" . $this->{id};
print STDERR "Processing files in $explodeinto\n";
chdir $explodeinto;
my $dir = new DirHandle $explodeinto;
unless ($dir) {
MailScanner::Log::WarnLog("Error: could not open message dir %s", $explodeinto);
return;
}
# Build a list of attachment filenames
my($file,@files,$entity);
while (defined($file = $dir->read)) {
next if $file =~ /^\.+$/;
next unless -f "$explodeinto/$file";
print STDERR "Possibly adding file $file\n";
$entity = $this->{file2entity}{$this->{safefile2file}{$file}};
print STDERR "Entity is $entity\n";
next unless $entity;
# Don't add the file if it's the winmail.dat file
unless ($entity eq $this->{tnefentity} && $this->{tnefentity}) {
# Add the file if it is an attachment, not an inline file
if ($entity->head->mime_attr("content-disposition") =~ /attachment/i) {
unless ($file =~ /\.zip$|\.rar$|\.gz$/i) {
push @files, $file;
print STDERR "Added $file to attachment list\n";
}
}
}
}
# If no files in the archive, don't create it.
return unless @files;
# Find the name of the new zip file, if there is one
my $newzipname = MailScanner::Config::Value('attachzipname', $this);
return unless $newzipname;
# Create a new zip archive
my $zip = Archive::Zip->new();
foreach $file (@files) {
$zip->addFile("$explodeinto/$file", $file);
}
my $safezipname = $this->MakeNameSafe($newzipname, $explodeinto);
print STDERR "Writing to zip $safezipname\n";
my $result = $zip->writeToFileNamed($explodeinto . '/' . $safezipname);
unless($result == AZ_OK) {
print STDERR "Error: Zip file could not be created!\n";
MailScanner::Log::WarnLog("Zip file %s for message %s could not be created",
$safezipname, $this->{id});
return;
}
# Add the new zipfile entity
$entity = $this->{entity};
$entity->make_multipart;
my $newentity = MIME::Entity->build(Path => "$explodeinto/$safezipname",
Type => "application/zip",
Encoding => "base64",
Filename => $newzipname,
Disposition => "attachment");
$entity->add_part($newentity);
$this->{bodymodified} = 1;
# Create all the Helpers for the new attachment
$this->{entity2file}{$newentity} = $newzipname;
$this->{entity2parent}{$newentity} = 0;
$this->{file2entity}{$newzipname} = $newentity;
$this->{name2entity}{scalar($newentity)} = $newentity;
$this->{file2safefile}{$newzipname} = $safezipname;
$this->{safefile2file}{$safezipname} = $newzipname;
# Delete the old attachments' entities
my($attachfile, $attachentity);
foreach $file (@files) {
$attachfile = $this->{safefile2file}{$file};
$attachentity = $this->{file2entity}{$attachfile};
$this->DeleteEntity($entity, $attachentity);
# And the files themselves
unlink("$explodeinto/$file");
}
}
# Explode a message into its MIME structure and attachments.
# Pass in the workarea where it should go.
sub Explode {
my $this = shift;
# $handle is Sendmail only
my($entity, $pipe, $handle, $pid, $workarea, $mailscannername);
return if $this->{deleted};
# Get the translation of MailScanner, we use it a lot
$mailscannername = MailScanner::Config::LanguageValue($this, 'mailscanner');
# Set up something so that the hash exists
$this->{file2parent}{""} = "";
# df file is already locked
$workarea = $global::MS->{work};
my $explodeinto = $workarea->{dir} . "/" . $this->{id};
#print STDERR "Going to explode message " . $this->{id} .
# " into $explodeinto\n";
# Setup everything for the MIME parser
my $parser = MIME::Parser->new;
my $filer = MIME::Parser::FileInto->new($explodeinto);
# Over-ride the default default character set handler so it does it
# much better than the MIME-tools default handling.
MIME::WordDecoder->default->handler('*' => \&WordDecoderKeep7Bit);
#print STDERR "Exploding message " . $this->{id} . " into " .
# $explodeinto . "\n";
$parser->filer($filer);
$parser->extract_uuencode(1); # uue is off by default
$parser->output_to_core('NONE'); # everything into files
# The whole parsing thing is totally different for sendmail & Exim for speed.
# Many thanks for those who know themselves for this great improvement!
if (MailScanner::Config::Value('mta') =~ /sendmail|exim|postfix|zmailer/i) {
#
# This is for sendmail and Exim systems
#
$handle = IO::File->new_tmpfile;
binmode($handle);
$this->{store}->ReadMessageHandle($this, $handle) or return;
## Do the actual parsing
my $maxparts = MailScanner::Config::Value('maxparts', $this) || 200;
MIME::Entity::ResetMailScannerCounter($maxparts);
# Inform MIME::Parser about our maximum
$parser->max_parts($maxparts * 3);
$entity = eval { $parser->parse($handle) };
# close and delete tmpfile
close($handle);
if (!$entity && !MIME::Entity::MailScannerCounter()>=$maxparts) {
unless ($this->{dpath}) {
# It probably ran out of disk space, drop this message from the batch
MailScanner::Log::WarnLog("Failed to create message structures for %s" .
", dropping it from the batch", $this->{id});
my @toclear = ( $this->{id} );
$workarea->ClearIds(\@toclear); # Delete attachments we might have made
$this->DropFromBatch();
return;
}
MailScanner::Log::WarnLog("Cannot parse " . $this->{headerspath} . " and " .
$this->{dpath} . ", $@");
$this->{entity} = $entity; # In case it failed due to too many attachments
$this->{cantparse} = 1;
$this->{otherinfected} = 1;
return;
}
# Too many attachments in the message?
if ($maxparts>0 && MIME::Entity::MailScannerCounter()>=$maxparts) {
#print STDERR "Found an error!\n";
#Not with sendmail: $pipe->close();
#Not with sendmail: kill 9, $pid; # Make sure we are reaping a dead'un
#Not with sendmail: waitpid $pid, 0;
MailScanner::Log::WarnLog("Too many attachments (%d) in %s",
MIME::Entity::MailScannerCounter(), $this->{id});
$this->{entity} = $entity; # In case it failed due to too many attachments
$this->{toomanyattach} = 1;
$this->{otherinfected} = 1;
return;
}
# Closing the pipe this way will reap the child, apparently!
#Not with sendmail: $pipe->close;
#Not with sendmail: kill 9, $pid; # Make sure we are reaping a dead'un
$this->{entity} = $entity;
} else {
#
# This is for non-sendmail/Postfix systems
#
# Create the message stream
# NOTE: This still uses the real path of the message body file.
($pipe,$pid) = $this->{store}->ReadMessagePipe($this) or return;
# Do the actual parsing
my $maxparts = MailScanner::Config::Value('maxparts', $this) || 200;
MIME::Entity::ResetMailScannerCounter($maxparts);
# Inform MIME::Parser about our maximum
$parser->max_parts($maxparts * 3);
$entity = eval { $parser->parse($pipe) };
if (!$entity && !MIME::Entity::MailScannerCounter()>=$maxparts) {
#print STDERR "Found an error!\n";
$pipe->close() if $pipe; # Don't close a pipe that failed to exist
waitpid $pid, 0;
unless ($this->{dpath}) {
# It probably ran out of disk space, drop this message from the batch
MailScanner::Log::WarnLog("Failed to create message structures for %s" .
", dropping it from the batch", $this->{id});
my @toclear = ( $this->{id} );
$workarea->ClearIds(\@toclear); # Delete attachments we might have made
$this->DropFromBatch();
return;
}
MailScanner::Log::WarnLog("Cannot parse " . $this->{headerspath} .
" and " . $this->{dpath} . ", $@");
$this->{entity} = $entity;# In case it failed due to too many attachments
$this->{cantparse} = 1;
$this->{otherinfected} = 1;
return;
}
# Too many attachments in the message?
if ($maxparts>0 && MIME::Entity::MailScannerCounter()>=$maxparts) {
#print STDERR "Found an error!\n";
$pipe->close();
kill 9, $pid; # Make sure we are reaping a dead'un
waitpid $pid, 0;
MailScanner::Log::WarnLog("Too many attachments (%d) in %s",
MIME::Entity::MailScannerCounter(), $this->{id});
$this->{entity} = $entity; # In case it failed due to too many attachments
$this->{toomanyattach} = 1;
$this->{otherinfected} = 1;
return;
}
# Closing the pipe this way will reap the child, apparently!
$pipe->close;
kill 9, $pid; # Make sure we are reaping a dead'un
$this->{entity} = $entity;
}
# Now handle TNEF files. They should be the only attachment to the message.
$this->{tnefentity} = MailScanner::TNEF::FindTNEFFile($entity)
if MailScanner::Config::Value('expandtnef');
# Look for winmail.dat files in each attachment directory $path.
# When we find one explode it into its files and store the root MIME
# entity into $IsTNEF{$id} so we can handle it separately later.
# Pattern to match is actually winmail(digits).dat(digits) as that copes
# with forwarded or bounced messages from mail packages that download
# all attachments into 1 directory, adding numbers to their filenames.
# Only delete original tnef if no-one wants to not replace it nor use it
my $DeleteTNEF = 0;
$DeleteTNEF = 1
if MailScanner::Config::Value('replacetnef', $this) !~ /[01]/;
#print STDERR "ReplaceTNEF = " . MailScanner::Config::Value('replacetnef', $this) . "\n";
if (MailScanner::Config::Value('tnefexpander') && $this->{tnefentity}) {
my($tneffile, @tneffiles);
# Find all the TNEF files called winmail.dat
my $outputdir = new DirHandle;
$outputdir->open($explodeinto)
or MailScanner::Log::WarnLog("Failed to open dir " . $explodeinto .
" while scanning for TNEF files, %s", $!);
@tneffiles = map { /(winmail\d*\.dat\d*)/i } $outputdir->read();
$outputdir->close();
#print STDERR "TNEF Entity is " . $this->{tnefentity} . "\n";
#print STDERR "TNEF files are " . join(',',@tneffiles) . "\n";
#print STDERR "Tree is \n" . $this->{entity}->dump_skeleton;
foreach $tneffile (@tneffiles) {
my $result;
MailScanner::Log::InfoLog("Expanding TNEF archive at %s/%s",
$explodeinto, $tneffile);
$result = MailScanner::TNEF::Decoder($explodeinto, $tneffile, $this);
if ($result) {
# If they want to replace the TNEF rather than add to it,
# then delete the original winmail.dat-style attachment
# and remove the flag saying it is a TNEF message at all.
#print STDERR "***** Found TNEF Attachments = " . $this->{foundtnefattachments} . "\n";
if ($DeleteTNEF && $this->{foundtnefattachments}) {
$this->DeleteEntity($this->{entity}, $this->{tnefentity});
unlink "$explodeinto/$tneffile";
delete $this->{tnefentity};
MailScanner::Log::InfoLog("Message %s has had TNEF %s removed",
$this->{id}, $tneffile);
}
} else {
MailScanner::Log::WarnLog("Corrupt TNEF %s that cannot be " .
"analysed in message %s", $tneffile,
$this->{id});
$this->{badtnef} = 1;
$this->{otherinfected} = 1;
}
}
}
unless(chdir $explodeinto) {
MailScanner::Log::WarnLog("Could not chdir to %s just before unpacking " .
"extra message parts", $explodeinto);
return;
}
# -------------------------------
# If the MIME boundary exists and is "" then remove the entire message.
# The top level must be multipart/mixed
if (defined($entity) && $entity->head) {
if ($entity->is_multipart || $entity->head->mime_type =~ /^multipart/i) {
my $boundary = $entity->head->multipart_boundary;
#print STDERR "Boundary is \"$boundary\"\n";
if ($boundary eq "" || $boundary eq "\"\"" || $boundary =~ /^\s/) {
my $cantparse = MailScanner::Config::LanguageValue($this,
'cantanalyze');
$this->{allreports}{""} .= "$mailscannername: $cantparse\n";
$this->{alltypes}{""} .= 'c';
$this->{otherinfected}++;
#print STDERR "Found error\n";
}
}
}
# -------------------------------
# Now try to extract messages from text files as they might be things
# we didn't manage to extract first time around.
# And try to expand .tar.gz .tar.z .tgz .zip files.
# We will then scan everything from inside them.
my($allowpasswords, $couldnotreadmesg, $passwordedmesg, $toodeepmesg);
$allowpasswords = MailScanner::Config::Value('allowpasszips', $this);
$allowpasswords = ($allowpasswords !~ /0/)?1:0;
$couldnotreadmesg = MailScanner::Config::LanguageValue($this,
'unreadablearchive');
$passwordedmesg = MailScanner::Config::LanguageValue($this,
'passwordedarchive');
$toodeepmesg = MailScanner::Config::LanguageValue($this,
'archivetoodeep');
$this->ExplodePartAndArchives($explodeinto,
MailScanner::Config::Value('maxzipdepth', $this),
$allowpasswords, $couldnotreadmesg,
$passwordedmesg, $toodeepmesg,
$mailscannername);
# Check we haven't filled the disk. Remove this message if we have, so
# that we can continue processing the other messages.
my $dir = MailScanner::Config::Value("incomingworkdir");
my $df = df($dir, 1024);
if ($df) {
my $freek = $df->{bavail};
if (defined($freek) && $freek<100 && $freek>=0) {
MailScanner::Log::WarnLog("Message %s is too big for available disk space in %s, skipping it", $this->{id}, $dir);
my @toclear = ( $this->{id} );
$workarea->ClearIds(\@toclear); # Delete attachments we might have made
$this->DropFromBatch();
return;
}
}
# Set the owner and group on all the extracted files
chown $workarea->{uid}, $workarea->{gid}, grep { -f } glob "$explodeinto/* $explodeinto/.*"
if $workarea->{changeowner};
}
# Delete a given entity from the MIME entity tree.
# Have to walk the entire tree to do this.
# Bail out as soon as we've found it.
# Return 0 if DeleteEntity fell off a leaf node.
# Return 1 if DeleteEntity hit the TNEF node.
# Return 2 if DeleteEntity is just walking back up the tree.
sub DeleteEntity {
my($message, $entity, $tnef) = @_;
my(@parts, $part, @keep);
#print STDERR "In DeleteEntity\n";
# If we have a no-body message then replace the TNEF entity with an
# empty attachment. Special case.
if (scalar($message->{entity}) eq $tnef) {
#print STDERR "Found message with no body but a TNEF attachment.\n";
$part = MIME::Entity->build(Type => "text/plain",
Encoding => "quoted-printable",
Data => ["\n"]);
push @keep, $part;
$message->{entity}->parts(\@keep);
$message->{bodymodified} = 1;
#print STDERR "Replaced single part with empty text/plain attachment\n";
return 2;
}
# Fallen off a leaf node?
return 0 unless $entity && defined($entity->head);
if ($entity && !$entity->parts) { # FIX FIX FIX !$entity->is_multipart) {
# Found the TNEF entity at a leaf node?
#(print STDERR "Found TNEF entity at a leaf node $entity\n"),return 1 if scalar($entity) eq $tnef;
#(print STDERR "Not found TNEF entity at a leaf node $entity\n"),return 2;
return 1 if scalar($entity) eq $tnef;
return 2;
}
@parts = $entity->parts;
#print STDERR "Parts are " . join(',',@parts) . "\n";
foreach $part (@parts) {
my $foundit = DeleteEntity($message, $part, $tnef);
#print STDERR "DeleteEntity = $foundit\n";
push @keep, $part unless $foundit == 1;
}
# Make sure there is always at least 1 part.
#print STDERR "Keep is " . join(',',@keep) . "\n";
unless (@keep) {
#print STDERR "Adding an empty text/plain\n";
$part = MIME::Entity->build(Type => "text/plain",
Encoding => "quoted-printable",
Data => ["\n"]);
push @keep, $part;
}
$entity->parts(\@keep);
$message->{bodymodified} = 1;
# If there are no parts left, make this entity a singlepart entity
$entity->make_singlepart unless scalar(@keep);
return 2;
}
# Quietly drop a message from the batch. Used when we run out of disk
# space.
sub DropFromBatch {
my($message) = @_;
$message->{deleted} = 1;
$message->{gonefromdisk} = 1; # Don't try to delete the original
$message->{store}->Unlock(); # Unlock it so other processes can pick it up
}
# Try to recursively unpack tar (with or without gzip) files and zip files.
# Extracts to a given maximum unpacking depth.
sub ExplodePartAndArchives {
my($this, $explodeinto, $maxlevels, $allowpasswords,
$couldnotreadmesg, $passwordedmesg, $toodeepmesg, $msname) = @_;
my($dir, $file, $part, @parts, $buffer);
my(%seenbefore, %seenbeforesize, $foundnewfiles);
my($size, $level, $ziperror, $tarerror, $silentviruses, $noisyviruses);
my($allziperrors, $alltarerrors, $textlevel, $failisokay);
my($linenum, $foundheader, $prevline, $line, $position, $prevpos, $nextpos);
my($cyclecounter, $rarerror);
$dir = new DirHandle;
$file = new FileHandle;
$level = 0; #-1;
$textlevel = 0;
$cyclecounter = 0;
$ziperror = 0;
$tarerror = 0;
# Do they only want encryption checking and nothing else?
my $onlycheckencryption;
$onlycheckencryption = 0;
# More robust way of saying maxlevels==0 && allowpasswords==0;
$onlycheckencryption = 1 if !$maxlevels && !$allowpasswords;
$silentviruses = ' '. MailScanner::Config::Value('silentviruses', $this) .' ';
$noisyviruses = ' ' . MailScanner::Config::Value('noisyviruses', $this) .' ';
$dir->open($explodeinto);
# $cyclecounter is a sanity check to ensure we don't loop forever
OUTER: while($cyclecounter<30) {
$cyclecounter++;
$textlevel++;
last if $level>$maxlevels; # && $textlevel>1;
$foundnewfiles = 0;
$dir->rewind();
@parts = $dir->read();
#print STDERR "Level = $level\n";
foreach $part (@parts) {
next if $part eq '.' || $part eq '..';
# Skip the entire loop if it's not what we are looking for
# JKF I really haven't the faintest idea why I wrote the next line :-)
#next unless $part =~
# /(^msg.*txt$)|(\.(tar\.g?z|taz|tgz|tz|zip|exe|rar)$)/i;
$size = -s "$explodeinto/$part";
#print STDERR "Checking $part $size bytes\n";
next if $seenbefore{$part} &&
$seenbeforesize{$part} == $size;
$seenbefore{$part} = 1;
$seenbeforesize{$part} = $size;
#print STDERR "$level/$maxlevels Found new file $part\n";
#print STDERR "Reading $part\n";
if ($part =~ /^msg.*txt/ && $textlevel<=2) {
# Try and find hidden messages in the text files
#print STDERR "About to read $explodeinto/$part\n";
$file->open("$explodeinto/$part") or next;
# Try reading the first few lines to see if they look like mail headers
$linenum = 0;
$foundheader = 0;
$prevline = "";
$prevpos = 0;
$nextpos = 0;
$line = undef;
for ($linenum=0; $linenum<30; $linenum++) {
#$position = $file->getpos();
$line = <$file>;
last unless defined $line;
$nextpos += length $line;
# Must have 2 lines of header
# prevline looks like Header:
# line looks like setting
# or Header:
if ($prevline =~ /^[^:\s]+: / && $line =~ /(^\s+\S)|(^[^:\s]+: )/) { #|(^\s+.*=)/) {
#print STDERR "Found header start at \"$prevline\"\n and \"$line\"\n";
$foundheader = 1;
last;
}
$prevline = $line;
$prevpos = $position;
$position = $nextpos;
}
if ($foundheader) {
# Check all lines are header lines up to next blank line
my($num, $reallyfoundheader);
$reallyfoundheader = 0;
# Check for a maximum of 30 lines of headers
foreach $num (0..30) {
$line = <$file>;
last unless defined $line;
# Must have a valid header line
#print STDERR "Examining: \"$line\"\n";
next if $line =~ /(^\s+\S)|(^[^:\s]+: )/;
#print STDERR "Not a header line\n";
# Or a blank line
if ($line =~ /^[\r\n]*$/) {
$reallyfoundheader = 1;
last;
}
#print STDERR "Not a blank line\n";
# Non-header line, so it isn't a valid message part
$reallyfoundheader = 0;
last;
}
#print STDERR "Really found header = $reallyfoundheader\n";
if ($reallyfoundheader) {
# Rewind to the start of the header
#$file->setpos($prevpos);
seek $file, $prevpos, 0;
#print STDERR "First line is \"" . <$file> . "\"\n";
# Setup everything for the MIME parser
my $parser = MIME::Parser->new;
my $filer = MIME::Parser::FileInto->new($explodeinto);
# Over-ride the default default character set handler so it does it
# much better than the MIME-tools default handling.
MIME::WordDecoder->default->handler('*' => \&WordDecoderKeep7Bit);
#print STDERR "Exploding message " . $this->{id} . " into " .
# $explodeinto . "\n";
$parser->filer($filer);
$parser->extract_uuencode(1); # uue is off by default
$parser->output_to_core('NONE'); # everything into files
# Do the actual parsing
#print STDERR "About to parse\n";
my $entity = eval { $parser->parse($file) };
#print STDERR "Done the parse\n";
# We might have created new files that need parsing
$foundnewfiles = 1;
next OUTER;
}
}
$file->close;
}
# Not got anything to do?
next if !$maxlevels && $allowpasswords;
#$level++;
next if $level > $maxlevels;
# Find all the zip files
#print STDERR "Looking at $explodeinto/$part\n";
#next if MailScanner::Config::Value('filecommand', $this) eq "";
next unless $file->open("$explodeinto/$part");
#print STDERR "About to read 4 bytes\n";
unless (read($file, $buffer, 4) == 4) {
#print STDERR "Very short file $part\n";
$file->close;
next;
}
my $uudfilename = "";
$uudfilename = FindUUEncodedFile($file)
if MailScanner::Config::Value('lookforuu', $this) =~ /1/;
#$file->close;
$failisokay = 0;
if ($buffer =~ /^MZ/) {
$failisokay = 1;
}
$file->close, next unless $buffer eq "PK\003\004" ||
$buffer eq "Rar!" ||
$part =~ /\.rar$/ ||
defined($uudfilename) ||
$failisokay;
#print STDERR "Found a zip or rar file\n" ;
$file->close, next unless MailScanner::Config::Value('findarchivesbycontent', $this) ||
$part =~ /\.(tar\.g?z|taz|tgz|tz|zip|exe|rar|uu|uue)$/i;
$foundnewfiles = 1;
#print STDERR "Unpacking $part at level $level\n";
if ($uudfilename ne "") {
# It cannot be a zip or a rar, so skip the checks for them.
# Oh yes it can! Do all the checks.
# Ignore the return value, don't care if uudecode fails, it was
# probably just a false positive on the uuencoded-data locator.
#print STDERR "About to unpackuue $part into $uudfilename\n";
$this->UnpackUUE($part, $explodeinto, $file, $uudfilename);
}
$file->close;
# Is it a zip file, in which case unpack the zip
$ziperror = "";
#print STDERR "About to unpackzip $part\n";
$ziperror = $this->UnpackZip($part, $explodeinto, $allowpasswords,
$onlycheckencryption);
#print STDERR "* * * * * * * Unpackzip $part returned $ziperror\n";
# If unpacking as a zip failed, try it as a rar
$rarerror = "";
if ($part =~ /\.rar$/i || $buffer eq "Rar!" or $buffer =~ /^MZ[P]?/) {
$rarerror = $this->UnpackRar($part, $explodeinto, $allowpasswords,
$onlycheckencryption);
}
$tarerror = "";
$tarerror = 0 # $this->UnpackTar($part, $explodeinto, $allowpasswords)
if $ziperror || $part =~ /(tar\.g?z|tgz)$/i;
#print STDERR "In inner: \"$part\"\n";
if ($ziperror eq "password" || $rarerror eq "password") {
MailScanner::Log::WarnLog("Password-protected archive (%s) in %s",
$part, $this->{id});
$this->{allreports}{$part} .= "$msname: $passwordedmesg\n";
$this->{alltypes}{$part} .= 'c';
$this->{passwordprotected} = 1;
$this->{otherinfected} = 1;
$this->{cantdisinfect} = 1; # Don't even think about disinfecting this!
$this->{silent}=1 if $silentviruses =~ / Zip-Password | All-Viruses /i;
$this->{noisy} =1 if $noisyviruses =~ / Zip-Password /i;
} elsif ($ziperror && $tarerror && $rarerror && !$failisokay) {
MailScanner::Log::WarnLog("Unreadable archive (%s) in %s",
$part, $this->{id});
$this->{allreports}{$part} .= "$msname: $couldnotreadmesg\n";
$this->{alltypes}{$part} .= 'c';
$this->{otherinfected} = 1;
}
}
#print STDERR "In outer: \"$part\"\n";
last if !$foundnewfiles || $level>$maxlevels;
$dir->rewind;
#print STDERR "Rewinding, Incrementing level from $level to " . ($level+1) . "\n";
$level++;
}
#print STDERR "Level=$level($maxlevels)\n";
#print STDERR "Onlycheckencryption=$onlycheckencryption\n";
if ($level>$maxlevels && !$onlycheckencryption && $maxlevels) {
MailScanner::Log::WarnLog("Files hidden in very deeply nested archive " .
"in %s", $this->{id});
$this->{allreports}{""} .= "$msname: $toodeepmesg\n";
$this->{alltypes}{""} .= 'c';
$this->{otherinfected}++;
}
}
# Search the given filehandle for signs that this could contain uu-encoded data
# Return the filename if found, undef otherwise. Also return the open file
# handle.
sub FindUUEncodedFile {
my $fh = shift;
my($mode, $file);
my $linecounter = 0;
seek $fh, 0, 0; # Rewind the file to the start
while (<$fh>) {
if (/^begin(.*)/) {
my $modefile = $1;
if ($modefile =~ /^(\s+(\d+))?(\s+(.*?\S))?\s*\Z/) {
($mode, $file) = ($2, $4);
}
last;
}
$linecounter++;
seek($fh, 0, 0), return undef if $linecounter>50;
}
return $file;
}
# We now have a uuencoded file to decode. We have a target filename we have
# read from the uuencode header.
sub UnpackUUE {
my $this = shift;
my($uuencoded, $explodeinto, $uuehandle, $uudecoded) = @_;
MailScanner::Log::DebugLog("Unpacking UU-encoded file %s", $uuencoded);
# Set up all the tree structures for cross-referencing
my $safename = $this->MakeNameSafe($uudecoded,$explodeinto);
$this->{file2parent}{$uudecoded} = $uuencoded;
$this->{file2parent}{$safename} = $uuencoded;
$this->{file2safefile}{$uudecoded} = $safename;
$this->{safefile2file}{$safename} = $uudecoded;
$safename = "$explodeinto/$safename";
my $out = new FileHandle;
unless ($out->open("> $safename")) {
MailScanner::Log::WarnLog("Unpacking UU-encoded file %s, could not create target file %s", $this->MakeNameSafe($uuencoded,$explodeinto), $safename);
return;
}
while (<$uuehandle>) {
last if /^end/;
next if /[a-z]/;
next unless int((((ord() - 32) & 077) + 2) / 3) == int(length() / 4);
$out->print(unpack('u', $_));
}
$out->close;
}
# Unpack a rar file into the named directory.
# Return 1 if an error occurred, else 0.
# Return 0 on success.
# Return "password" if a member was password-protected.
# Very much like UnpackZip except it uses the external "unrar" command.
sub UnpackRar {
my($this, $zipname, $explodeinto, $allowpasswords, $onlycheckencryption) = @_;
my($zip, @members, $member, $name, $fh, $safename, $memb, $check, $junk,
$unrar,$IsEncrypted, $PipeTimeOut, $PipeReturn,$NameTwo, $HasErrors,
$member2, $Stuff, $BeginInfo, $EndInfo, $ParseLine, $what);
# Timeout value for unrar is currently the same as that of the file
# command + 20. Julian, when you add the filetimeout to the config file
# perhaps you should think about adding a maxcommandexecutetime setting
# as well
$PipeTimeOut = MailScanner::Config::Value('unrartimeout');
$unrar = MailScanner::Config::Value('unrarcommand');
return 1 unless $unrar && -x $unrar;
#MailScanner::Log::WarnLog("UnPackRar Testing : %s", $zipname);
# This part lists the archive contents and makes the list of
# file names within. "This is a list verbose option"
$memb = SafePipe("$unrar v -p- '$explodeinto/$zipname' 2>&1",
$PipeTimeOut);
$junk = "";
$Stuff = "";
$BeginInfo = 0;
$EndInfo = 0;
$ParseLine = 1;
$memb =~ s/\r//gs;
my @test = split /\n/, $memb;
$memb = '';
# Have to parse the output from the 'v' command and parse the information
# between the ----------------------------- lines
foreach $what (@test) {
#print STDERR "Processing \"$what\"\n";
# If we haven't hit any ------- lines at all, and we are prompted for
# a password, then the whole archive is password-protected.
unless ($BeginInfo || $EndInfo) {
if ($what =~ /^Encrypted file:/i && !$allowpasswords) {
MailScanner::Log::WarnLog("Password Protected RAR Found");
return "password";
}
}
# Have we already hit the beginng and now find another ------ string?
# If so then we are at the end
$EndInfo = 1 if $what =~ /-{40,}$/ && $BeginInfo;
# if we are after the begning but haven't reached the end,
# then process this line
if ($BeginInfo && !$EndInfo) {
# If we are on line one then it's the file name with full path
# otherwise we are on the info line containing the attributes
if ($ParseLine eq 1) {
$junk = $what;
$junk =~ s/^\s+|\s+$//g;
chomp($junk);
$ParseLine = 2;
} else {
$Stuff = $what;
$Stuff =~ s/^\s+|\s+$//g;
# Need to remove redundant spaces from our info line and
# split it into it's components
chomp($Stuff);
$Stuff =~ s/\s{2,}/ /g;
my ($RSize,$RPacked,$RRatio,$RDate,$RTime,$RAttrib,$RCrc,$RMeth,$RVer)
= split /\s/, $Stuff;
# If RAttrib doesn't begin with d then it's a file and we
# add it to our $memb string, otherwise we ignore the directory
# only entries
#MailScanner::Log::WarnLog("UnPackRar InfoLine :%s:", $Stuff);
#MailScanner::Log::WarnLog("UnPackRar Looking at ATTRIB :->%s<-:",
# $RAttrib);
$memb .= "$junk\n" if $RAttrib !~ /^d|^.D/;
$junk = '';
$Stuff = '';
$ParseLine = 1;
}
}
# If we have a line full of ---- and $BeginInfo is not set then
# we are at the first and we need to set $BeginInfo so next pass
# begins processing file information
if ($what =~ /-{40,}$/ && ! $BeginInfo) {
$BeginInfo = 1;
}
}
# Remove returns from the output string, exit if the archive is empty
# or the output is empty
$memb =~ s/\r//gs;
return 1 if $memb ne '' &&
$memb =~ /(No files to extract|^COMMAND_TIMED_OUT$)/si;
return 0 if $memb eq ''; # JKF If no members it probably wasn't a Rar self-ext
#MailScanner::Log::DebugLog("Unrar : Archive Testing Completed On : %s",
# $memb);
@members = split /\n/, $memb;
$fh = new FileHandle;
foreach $member2 (@members) {
$IsEncrypted = 0;
$HasErrors = 0;
#MailScanner::Log::InfoLog("Checking member %s",$member2);
# Test the current file name to see if it's password protected
# and capture the output. If the command times out, then return
next if $member2 eq "";
$member = quotemeta $member2;
#print STDERR "Member is ***$member***\n";
$check = SafePipe(
"$unrar t -p- -idp '$explodeinto/$zipname' $member 2>&1",
$PipeTimeOut);
#print STDERR "Point 1\n";
return 1 if $check =~ /^COMMAND_TIMED_OUT$/;
# Check for any error with this file. Format is FileName - Error string
if ($check =~ /$member\s+-\s/i){
MailScanner::Log::WarnLog("Unrar: Error in file: %s -> %s",
$zipname,$member);
$HasErrors = 1;
}
$check =~ s/\n/:/gsi;
#MailScanner::Log::WarnLog("Got : %s", $check);
# If we get the string Encrypted then we have found a password
# protected archive and we handle it the same as zips are handled
if ($check =~ /\bEncrypted file:\s.+\(password incorrect/si) {
$IsEncrypted = 1;
MailScanner::Log::WarnLog("Password Protected RAR Found");
#print STDERR "Checking member " . $member . "\n";
#print STDERR "******** Encryption = " . $IsEncrypted . "\n";
return "password" if !$allowpasswords && $IsEncrypted;
}
# If they don't want to extract, but only check for encryption,
# then skip the rest of this as we don't actually want the files
# checked against the file name/type rules
next if $onlycheckencryption;
$name = $member2;
#print STDERR "UnPackRar : Making Safe Name from $name\n";
# There is no facility to change the output name for a rar file
# but we can rename rename the files inside the archive
# prefer to use $NameTwo because there is no path attached
# $safename is guaranteed not to exist, but NameTwo gives us the
# filename without any directory information, which we use later.
$safename = $this->MakeNameSafe($name,$explodeinto);
$NameTwo = $safename;
$NameTwo = $1 if $NameTwo =~ /([^\/]+)$/;
#MailScanner::Log::InfoLog("UnPackRar: Member : %s", $member);
#print STDERR "UnPackRar : Safe Name is $safename\n";
#MailScanner::Log::InfoLog("UnPackRar: SafeName : %s", $safename);
$this->{file2parent}{$name} = $zipname;
$this->{file2parent}{$safename} = $zipname;
$this->{file2safefile}{$name} = $safename;
$this->{safefile2file}{$safename} = $name;
#print STDERR "Archive member \"$name\" is now \"$safename\"\n";
#$this->{file2entity}{$name} = $this->{entity};
$this->{file2safefile}{$name} = $zipname;
#$this->{safefile2file}{$safename} = $zipname;
$safename = "$explodeinto/$safename";
$PipeReturn = '';
$? = 0;
if (!$IsEncrypted && !$HasErrors) {
#print STDERR "Expanding ***$member***\ninto ***$NameTwo***\n";
$PipeReturn = SafePipe(
"$unrar p -y -inul -p- -idp '$explodeinto/$zipname' $member > \"$NameTwo\"",
$PipeTimeOut);
unless ("$?" == 0 && $PipeReturn ne 'COMMAND_TIMED_OUT'){
# The rename operation failed!, so skip the extraction of a
# potentially bad file name.
# JKF Temporary testing code
#MailScanner::Log::WarnLog("UnPackRar: RC: %s PipeReturn : ",$?,$PipeReturn);
MailScanner::Log::WarnLog("UnPackRar: Could not rename or use " .
"safe name in Extract, NOT Unpacking file %s", $safename);
next;
}
#MailScanner::Log::InfoLog("UnPackRar: Done...., got %d and %s", $?, $PipeReturn);
}
#MailScanner::Log::WarnLog("RC = %s : Encrypt = %s : PipeReturn = %s",
# $?,$IsEncrypted,$PipeReturn );
unless ("$?" == 0 && !$HasErrors && !$IsEncrypted &&
$PipeReturn ne 'COMMAND_TIMED_OUT') {
# If we got an error, or this file is encrypted create a zero-length
# file so the filename tests will still work.
MailScanner::Log::WarnLog("Unrar : Encrypted Or Extract Error Creating" .
" 0 length %s",$NameTwo);
$fh->open(">$safename") && $fh->close();
}
}
return 0;
}
# Modified Julian's code from SweepOther.pm
# Changed to allow execution of any given command line with a time
# control. This could replace any call to system or use of backticks
#
# $Cmd = command line to execute
# $timeout = max time in seconds to allow execution
#
sub SafePipe {
my ($Cmd, $TimeOut) = @_;
my($Kid, $pid, $TimedOut, $Str);
$Kid = new FileHandle;
$TimedOut = 0;
#print STDERR "SafePipe : Command : $Cmd\n";
#print STDERR "SafePipe : TimeOut : $TimeOut\n";
$? = 0; # Make sure there's no junk left in here
eval {
die "Can't fork: $!" unless defined($pid = open($Kid, '-|'));
if ($pid) {
# In the parent
# Set up a signal handler and set the alarm time to the timeout
# value passed to the function
local $SIG{ALRM} = sub { $TimedOut = 1; die "Command Timed Out" };
alarm $TimeOut;
# while the command is running we will collect it's output
# in the $Str variable. We don't process it in any way here so
# whatever called us will get back exactly what they would have
# gotten with a system() or backtick call
#MailScanner::Log::DebugLog("SafePipe : Processing %s", $Cmd);
while(<$Kid>) {
$Str .= $_;
#print STDERR "SafePipe : Processing line \"$_\"\n";
}
#MailScanner::Log::DebugLog("SafePipe : Completed $Cmd");
#print STDERR "SafePipe : Returned $PipeReturnCode\n";
$pid = 0; # 2.54
alarm 0;
# Workaround for bug in perl shipped with Solaris 9,
# it doesn't unblock the SIGALRM after handling it.
eval {
my $unblockset = POSIX::SigSet->new(SIGALRM);
sigprocmask(SIG_UNBLOCK, $unblockset)
or die "Could not unblock alarm: $!\n";
};
} else {
# In the child
POSIX::setsid();
# Execute the command via an exec call, bear in mind this will only
# capture STDIN so if you need STDERR, or both you have to handle, for
# example, 2>&1 as part of the command line just as you would with
# system() or backticks
#
#the line following the
# call should *never* be reached unless the call it's self fails
#print STDERR "SafePipe in child exec $Cmd\n";
my @args = ( "$Cmd" );
#exec $Cmd or print STDERR "SafePipe : failed to execute $Cmd\n";
open STDIN, "< /dev/null";
exec @args
or MailScanner::Log::WarnLog("SafePipe : failed to execute %s", $Cmd);
#MailScanner::Log::DebugLog("SafePipe in Message.pm : exec failed " .
# "for $Cmd");
exit 1;
}
};
alarm 0; # 2.53
#MailScanner::Log::DebugLog("SafePipe in Message.pm : Completed $Cmd");
#MailScanner::Log::WarnLog("Returned Code : %d", $?);
# Catch failures other than the alarm
MailScanner::Log::WarnLog("SafePipe in Message.pm : $Cmd failed with real error: $@")
if $@ and $@ !~ /Command Timed Out/;
#print STDERR "SafePipe : pid = $pid and \@ = $@\n";
# In which case any failures must be the alarm
if ($@ or $pid>0) {
# Kill the running child process
my($i);
kill -15, $pid;
# Wait for up to 5 seconds for it to die
for ($i=0; $i<5; $i++) {
sleep 1;
waitpid($pid, &POSIX::WNOHANG);
($pid=0),last unless kill(0, $pid);
kill -15, $pid;
}
# And if it didn't respond to 11 nice kills, we kill -9 it
if ($pid) {
kill -9, $pid;
waitpid $pid, 0; # 2.53
}
}
# If the command timed out return the string below, otherwise
# return the command output in $Str
return $Str unless $TimedOut;
MailScanner::Log::WarnLog("Safepipe in Message.pm : %s timed out!", $Cmd);
return "COMMAND_TIMED_OUT";
}
# Unpack a zip file into the named directory.
# Return 1 if an error occurred, else 0.
# Return 0 on success.
# Return "password" if a member was password-protected.
sub UnpackZip {
my($this, $zipname, $explodeinto, $allowpasswords, $onlycheckencryption) = @_;
my($zip, @members, $member, $name, $fh, $safename);
#print STDERR "Unpacking $zipname\n";
return 1 if -s "$explodeinto/$zipname" == 4_237_4; # zip of death?
return 1 unless $zip = Archive::Zip->new("$explodeinto/$zipname");
return 1 unless @members = $zip->members();
$fh = new FileHandle;
foreach $member (@members) {
#print STDERR "Checking member " . $member->fileName() . "\n";
#print STDERR "******** Encryption = " . $member->isEncrypted() . "\n";
return "password" if !$allowpasswords && $member->isEncrypted();
# If they don't want to extract, but only check for encryption,
# then skip the rest of this as we don't actually want the files.
next if $onlycheckencryption;
$name = $member->fileName();
$safename = $this->MakeNameSafe($name, $explodeinto);
$this->{file2parent}{$name} = $zipname;
$this->{file2parent}{$safename} = $zipname;
$this->{file2safefile}{$name} = $safename;
$this->{safefile2file}{$safename} = $name;
#print STDERR "Archive member \"$name\" is now \"$safename\"\n";
#$this->{file2entity}{$name} = $this->{entity};
$this->{file2safefile}{$name} = $zipname;
#$this->{safefile2file}{$safename} = $zipname;
$safename = "$explodeinto/$safename";
#print STDERR "About to extract $member to $safename\n";
unless ($zip->extractMemberWithoutPaths($member, $safename) == AZ_OK) {
# Create a zero-length file if extraction failed
# so the filename tests will still work.
#print STDERR "Done passworded extraction of $member to $safename\n";
$fh->open(">$safename") && $fh->close();
}
#print STDERR "Done extraction of $member to $safename\n";
}
return 0;
}
# Is this filename evil?
sub IsNameEvil {
my($this, $name, $dir) = @_;
#print STDERR "Testing \"$name\" to see if it is evil\n";
return 1 if (!defined($name) or ($name eq '')); ### empty
return 1 if ($name =~ m{(^\s)|(\s+\Z)}); ### leading/trailing whitespace
return 1 if ($name =~ m{^\.+\Z}); ### dots
return 1 if ($name =~ tr{ \%\(\)\+\,\-\.0-9\=A-Z_a-z\{\}\x80-\xFF}{}c);
return 1 if (length($name) > 50);
return 'exists' if (-e "$dir/$name");
#print STDERR "It is okay\n";
#$self->debug("it's ok");
0;
}
# Make this filename safe and return the safe version
sub MakeNameSafe {
my($self, $fname, $dir) = @_;
### Isolate to last path element:
my $last = $fname; $last =~ s{^.*[/\\\[\]:]}{};
if ($last and !$self->IsNameEvil($last, $dir)) {
#$self->debug("looks like I can use the last path element");
#print STDERR "MakeNameSafe: 1 $fname,$last\n";
return $last;
}
# Try removing leading whitespace, trailing whitespace and all
# dangerous characters to start with.
$last =~ s/^\s+//;
$last =~ s/\s+\Z//;
$last =~ tr/ \%\(\)\+\,\-\.0-9\=A-Z_a-z\{\}\x80-\xFF//cd;
#print STDERR "MakeNameSafe: 2 $fname,$last\n";
return $last unless $self->IsNameEvil($last, $dir);
### Break last element into root and extension, and truncate:
my ($root, $ext) = (($last =~ /^(.*)\.([^\.]+)\Z/)
? ($1, $2)
: ($last, ''));
# JKF Delete leading and trailing whitespace
$root =~ s/^\s+//;
$ext =~ s/\s+$//;
$root = substr($root, 0, ($self->{MPF_TrimRoot} || 14));
$ext = substr($ext, 0, ($self->{MPF_TrimExt} || 3));
$ext =~ /^\w+$|^$/ or $ext = "dat";
my $trunc = $root . ($ext ? ".$ext" : '');
if (!$self->IsNameEvil($trunc, $dir)) {
#$self->debug("looks like I can use the truncated last path element");
#print STDERR "MakeNameSafe: 3 $fname,$trunc\n";
return $trunc;
}
# It is still evil, but probably just because it exists
if ($self->IsNameEvil($trunc, $dir) eq 'exists') {
my $counter = 0;
$trunc = $trunc . '0';
do {
$counter++;
$trunc = $root . $counter . ($ext ? ".$ext" : '');
} while $self->IsNameEvil($trunc, $dir) eq 'exists';
return $trunc;
}
### Hope that works:
#print STDERR "MakeNameSafe: 4 $fname,:-(\n";
undef;
}
# Unpack a tar file into the named directory.
# Return 1 if an error occurred, else 0.
sub UnpackTar {
my($this, $tarname, $explodeinto) = @_;
return 1; # Not yet implemented
}
# Try to parse all the text bits of each message, looking to see if they
# can be parsed into files which might be infected.
# I then throw these sections back to the MIME parser.
sub ExplodePart {
my($this, $explodeinto) = @_;
my($dir, $file, $part, @parts);
$dir = new DirHandle;
$file = new FileHandle;
$dir->open($explodeinto);
@parts = $dir->read();
$dir->close();
my($linenum, $foundheader, $prevline, $line, $position, $prevpos, $nextpos);
foreach $part (@parts) {
#print STDERR "Reading $part\n";
next unless $part =~ /^msg.*txt/;
# Try and find hidden messages in the text files
#print STDERR "About to read $explodeinto/$part\n";
$file->open("$explodeinto/$part") or next;
# Try reading the first few lines to see if they look like mail headers
$linenum = 0;
$foundheader = 0;
$prevline = "";
$prevpos = 0;
$nextpos = 0;
$line = undef;
for ($linenum=0; $linenum<30; $linenum++) {
#$position = $file->getpos();
$line = <$file>;
last unless defined $line;
$nextpos += length $line;
# Must have 2 lines of header
if ($prevline =~ /^[^:\s]+: / && $line =~ /(^\s+)|(^[^:]+ )|(^\s+.*=)/) {
#print STDERR "Found header start at \"$prevline\"\n and \"$line\"\n";
$foundheader = 1;
last;
}
$prevline = $line;
$prevpos = $position;
$position = $nextpos;
}
unless ($foundheader) {
$file->close();
next;
}
# Rewind to the start of the header
#$file->setpos($prevpos);
seek $file, $prevpos, 0;
#print STDERR "First line is \"" . <$file> . "\"\n";
# Setup everything for the MIME parser
my $parser = MIME::Parser->new;
#my $filer = MIME::Parser::FileInto::MailScanner->new($explodeinto);
my $filer = MIME::Parser::FileInto->new($explodeinto);
# Over-ride the default default character set handler so it does it
# much better than the MIME-tools default handling.
MIME::WordDecoder->default->handler('*' => \&WordDecoderKeep7Bit);
#print STDERR "Exploding message " . $this->{id} . " into " .
# $explodeinto . "\n";
$parser->filer($filer);
$parser->extract_uuencode(1); # uue is off by default
$parser->output_to_core('NONE'); # everything into files
# Do the actual parsing
my $entity = eval { $parser->parse($file) };
$file->close;
}
}
# Print the infection reports for this message
sub PrintInfections {
my $this = shift;
my($filename, $report, $type);
print STDERR "Virus reports for " . $this->{id} . ":\n";
foreach $filename (keys %{$this->{virusreports}}) {
print STDERR " ";
print STDERR $filename . "\t" . $this->{virusreports}{$filename} . "\n";
print STDERR " " . $this->{virustypes}{$filename} . "\n";
}
print STDERR "Name reports for " . $this->{id} . ":\n";
foreach $filename (keys %{$this->{namereports}}) {
print STDERR " ";
print STDERR $filename . "\t" . $this->{namereports}{$filename} . "\n";
print STDERR " " . $this->{nametypes}{$filename} . "\n";
}
print STDERR "Other reports for " . $this->{id} . ":\n";
foreach $filename (keys %{$this->{otherreports}}) {
print STDERR " ";
print STDERR $filename . "\t" . $this->{otherreports}{$filename} . "\n";
print STDERR " " . $this->{othertypes}{$filename} . "\n";
}
print STDERR "Entity reports for " . $this->{id} . ":\n";
foreach $filename (keys %{$this->{entityreports}}) {
print STDERR " ";
print STDERR $filename . "\t" . $this->{entityreports}{$filename} . "\n";
}
print STDERR "All reports for " . $this->{id} . ":\n";
foreach $filename (keys %{$this->{allreports}}) {
print STDERR " ";
print STDERR $filename . "\t" . $this->{allreports}{$filename} . "\n";
}
print STDERR "Message is TNEF? " . ($this->{tnefentity}?"Yes":"No") . "\n";
print STDERR "Message is bad TNEF? " . ($this->{badtnef}?"Yes":"No") . "\n";
print STDERR "Message has " . $this->{virusinfected} . " virus infections\n";
print STDERR "Message has " . $this->{sizeinfected} . " size problems\n";
print STDERR "Message has " . $this->{otherinfected} . " other problems\n";
print STDERR "\n";
}
# Create the Entity2Parent and Entity2File hashes for a message
# $message->CreateEntitiesHelpers($this->{entity2parent},
# $this->{entity2file});
sub CreateEntitiesHelpers {
my $this = shift;
#my($Entity2Parent, $Entity2File) = @_;
return undef unless $this->{entity};
$this->{numberparts} = CountParts($this->{entity}) || 1;
# Put something useless in the 2 hashes so that they exist.
$this->{entity2file}{""} = 0;
$this->{entity2parent}{""} = 0;
$this->{file2entity}{""} = $this->{entity}; # Root of this message
$this->{name2entity}{""} = 0;
$this->{file2safefile}{""} = "";
$this->{safefile2file}{""} = "";
BuildFile2EntityAndEntity2File($this->{entity},
$this->{file2entity},
$this->{file2safefile},
$this->{safefile2file},
$this->{entity2file},
$this->{name2entity});
#print STDERR "In CreateEntitiesHelpers, this = $this\n";
#print STDERR "In CreateEntitiesHelpers, this entity = " .
# $this->{entity} . "\n";
#print STDERR "In CreateEntitiesHelpers, parameters are " .
# scalar($this->{entity2file}) . " and " .
# scalar($this->{entity2parent}) . "\n";
BuildEntity2Parent($this->{entity}, $this->{entity2parent}, undef);
}
# For the MIME entity given, work out the number of message parts.
# Recursive. This is a class function, not a normal method.
sub CountParts {
my($entity) = @_;
my(@parts, $total, $part);
return 0 unless $entity;
@parts = $entity->parts;
$total += int(@parts);
foreach $part (@parts) {
$total += CountParts($part);
}
return $total;
}
# Build the file-->entity and entity-->file mappings for a message.
# This will let us replace infected entities later. Key is the filename,
# value is the entity.
# This is recursive. This is a class function, not a normal method.
sub BuildFile2EntityAndEntity2File {
my($entity, $file2entity, $file2safefile, $safefile2file, $entity2file,
$name2entity) = @_;
# Build the conversion hash from scalar(entity) --> real entity object
# Need to do this as objects cannot be hash keys.
$name2entity->{scalar($entity)} = $entity;
my(@parts, $body, $headfile, $part, $path);
# Find the body for this entity
$body = $entity->bodyhandle;
if (defined($body) && defined($body->path)) { # data is on disk:
$path = $body->path;
$path =~ s#^.*/([^/]*)$#$1#;
$file2entity->{$path} = $entity;
$entity2file->{$entity} = $path;
#print STDERR "Path is $path\n";
}
# And the head, which is where the recommended filename is stored
# This is so we can report infections in the filenames which are
# recommended, even if they are evil and we hence haven't used them.
$headfile = $entity->head->recommended_filename || $path;
#print STDERR "rec filename for \"$headfile\" is \"" . $entity->head->recommended_filename . "\"\n";
#print STDERR "headfile is $headfile\n";
if ($headfile) {
$file2entity->{$headfile} = $entity if !$file2entity->{$headfile};
$file2safefile->{$headfile} = $path;
$safefile2file->{$path} = $headfile;
#print STDERR "File2SafeFile (\"$headfile\") = \"$path\"\n";
}
# And for all its children
@parts = $entity->parts;
foreach $part (@parts) {
BuildFile2EntityAndEntity2File($part, $file2entity, $file2safefile,
$safefile2file, $entity2file, $name2entity);
}
}
# Build a hash that gives the parent of any entity
# (except for root ones which will be undef).
# This is recursive.
sub BuildEntity2Parent {
my($entity, $Entity2Parent, $parent) = @_;
my(@parts, $part);
$Entity2Parent->{$entity} = $parent;
@parts = $entity->parts;
foreach $part (@parts) {
#print STDERR "BuildEntity2Parent: Doing part $part\n";
$Entity2Parent->{$part} = $entity;
BuildEntity2Parent($part, $Entity2Parent, $entity);
}
}
# Combine the virus reports and the other reports, as otherwise the
# cleaning code is really messy. I might combine them when I create
# them some time later, but I wanted to keep them separate if possible
# in case anyone wanted a feature in the future which would be easier
# with separate reports.
# If safefile2file does not map for a filename, ban the whole message
# to be on the safe side.
sub CombineReports {
my $this = shift;
my($file, $text, $Name);
my(%reports, %types);
#print STDERR "Combining reports for " . $this->{id} . "\n";
# If they want to include the scanner name in the reports, then also
# include the translation of "MailScanner" in the filename/type/content
# reports.
# If they set "MailScanner = " in languages.conf then this string will
# *not* be inserted at the start of the reports.
$Name = MailScanner::Config::LanguageValue($this, 'mailscanner')
if MailScanner::Config::Value('showscanner', $this);
$Name .= ': ' if $Name ne "" && $Name !~ /:/;
# Or the flags together
$this->{infected} = $this->{virusinfected} |
$this->{nameinfected} |
$this->{sizeinfected} |
$this->{otherinfected} ;
# Combine all the reports and report-types
while (($file, $text) = each %{$this->{virusreports}}) {
#print STDERR "Adding file $file report $text\n";
$this->{allreports}{$file} .= $text;
$reports{$file} .= $text;
}
while (($file, $text) = each %{$this->{virustypes}}) {
#print STDERR "Adding file $file type $text\n";
$this->{alltypes}{$file} .= $text;
$types{$file} .= $text;
}
while (($file, $text) = each %{$this->{namereports}}) {
#print STDERR "Adding file \"$file\" report \"$text\"\n";
# Next line not needed as we prepend the $Name anyway
#$text =~ s/\n(.)/\n$Name: NEWSTABLE $1/g if $Name; # Make sure name is at the front of this
#print STDERR "report is now \"$text\"\n";
$this->{allreports}{$file} .= $Name . $text;
$reports{$file} .= $Name . $text;
}
while (($file, $text) = each %{$this->{nametypes}}) {
#print STDERR "Adding file $file type $text\n";
$this->{alltypes}{$file} .= $text;
$types{$file} .= $text;
}
while (($file, $text) = each %{$this->{otherreports}}) {
#print STDERR "Adding file $file report $text\n";
$this->{allreports}{$file} .= $Name . $text;
$reports{$file} .= $Name . $text;
}
while (($file, $text) = each %{$this->{othertypes}}) {
#print STDERR "Adding file $file type $text\n";
$this->{alltypes}{$file} .= $text;
$types{$file} .= $text;
}
# Now try to map all the reports onto their parents as far as possible
#print STDERR "About to combine reports\n";
my($key, $value, $parent, %foundparent);
while(($key, $value) = each %reports) {
$parent = $this->{file2parent}{$key};
#print STDERR "Looking at report for $key (son of $parent)\n";
#if (defined $parent && exists($this->{safefile2file}{$parent})) {
# #print STDERR "Found parent of $key is $parent\n";
# $foundparent{$key} = 1;
# $this->{allreports}{$parent} .= $value;
# $this->{alltypes}{$parent} .= $types{$key};
#} else {
# #print STDERR "Promoting report for $key\n";
# delete $this->{allreports}{$key};
# delete $this->{alltypes}{$key};
# $this->{allreports}{""} .= $value;
# $this->{alltypes}{""} .= $types{$key};
#}
if (defined $parent && exists($this->{safefile2file}{$parent}) &&
$parent ne "") {
#print STDERR "Found parent of $key is $parent\n";
$foundparent{$key} = 1;
$this->{allreports}{$parent} .= $value;
$this->{alltypes}{$parent} .= $types{$key};
} else {
#print STDERR "Promoting report for $key\n";
if($parent eq "" and exists($this->{safefile2file}{$key})) {
$foundparent{$key} = 1;
delete $this->{allreports}{$key};
delete $this->{alltypes}{$key};
$this->{allreports}{$key} .= $value;
$this->{alltypes}{$key} .= $types{$key};
} else {
delete $this->{allreports}{$key};
delete $this->{alltypes}{$key};
$this->{allreports}{""} .= $value;
$this->{alltypes}{""} .= $types{$key};
}
}
}
# And delete the records for members we have found.
#foreach $key (keys %foundparent) {
# print STDERR "Deleting report for $key\n";
# delete $this->{allreports}{$key};
# delete $this->{alltypes}{$key};
#}
# Now look for the reports we can't match anywhere and make them
# map to the entire message.
#while(($key, $value) = each %reports) {
# if (!defined $foundparent{$key} || !exists($this->{safefile2file}{$key})) {
# #print STDERR "Promoting report for $key\n";
# delete $this->{allreports}{$key};
# delete $this->{alltypes}{$key};
# $this->{allreports}{""} .= $value;
# $this->{alltypes}{""} .= $types{$key};
# }
#}
#print STDERR "Finished combining reports\n";
#$this->PrintInfections();
}
# Clean the message. This involves removing all the infected or
# troublesome sections of the message and replacing them with
# nice little text files explaining what happened.
# We do not do true macro-virus disinfection here.
# Also mark the message as having had its body modified.
sub Clean {
my $this = shift;
#print STDERR "\n\n\nStart Of Clean\n\n";
#$this->PrintInfections();
# Get out if nothing to do
#print STDERR "Have we got anything to do?\n";
return unless ($this->{allreports} && %{$this->{allreports}}) ||
($this->{entityreports} && %{$this->{entityreports}});
#print STDERR "Yes we have\n";
my($file, $text, $entity, $parent, $filename, $everyreport, %AlreadyCleaned);
# Work out whether infected bits of this message should be stored
my $storeme = 0;
$storeme = 1
if MailScanner::Config::Value('quarantineinfections', $this) =~ /1/;
# Cancel the storage if it is silent and no-one wants it quarantined
$storeme = 0 if $this->{silent} && !$this->{noisy} &&
MailScanner::Config::Value('quarantinesilent', $this) !~ /1/;
# Construct a string of all the reports, which is used if there is
# cleaning needing doing on the whole message
$everyreport = join("\n", values %{$this->{allreports}});
# Construct a hash of all the entities we will clean,
# so we clean parents in preference to their children.
my(%EntitiesWeClean);
$EntitiesWeClean{scalar($this->{tnefentity})} = 1 if $this->{tnefentity};
while(($file, $text) = each %{$this->{allreports}}) {
$entity = $this->{file2entity}{"$file"};
# If we are a child, push the parent on the list
$entity = $this->{file2entity}{$this->{file2parent}{$file}} if !$entity;
# If there isn't a parent either, push the whole message on the list
$entity = $this->{entity} if !$entity;
$EntitiesWeClean{scalar $entity} = 1;
}
# Work through each filename-based report in turn, 1 per attachment
while(($file, $text) = each %{$this->{allreports}}) {
#print STDERR "Cleaning $file which had a report of $text\n";
$this->{bodymodified} = 1; # This message body has been changed in memory
# If it's a TNEF message, then use the entity of the winmail.dat
# file, else use the entity of the infected file.
my $tnefentity = $this->{tnefentity};
#print STDERR "It's a TNEF message\n" if $tnefentity;
if ($file eq "") {
#print STDERR "It's a whole body infection, entity = ".$this->{entity}."\n";
$entity = $this->{entity};
} else {
#print STDERR "It's just 1 file, which is $file\n";
if ($tnefentity) {
$entity = $tnefentity;
} else {
$entity = $this->{file2entity}{"$file"};
# Skip this report if we are reporting this entity's parent
$parent = scalar($this->{file2entity}{$this->{file2parent}{$file}});
next if !$entity && $parent && $EntitiesWeClean{$parent};
#print STDERR "Cleaning $file which is entity $entity\n";
# Try to find a matching entity, may involve querying the parent
if (!$entity) {
$entity = $parent; #$this->{file2entity}{$this->{file2parent}{$file}};
#print STDERR "Parent of $file is " . $this->{file2parent}{$file} . "\n";
#print STDERR "Entity was blank, cleaning $entity\n";
}
# Could not find parent, give up and zap whole message
if (!$entity) {
$entity = $this->{entity};
#print STDERR "Could not find entity, doing whole message\n";
}
}
}
# Avoid cleaning the same entity twice as it will clean the wrong thing!
next if $AlreadyCleaned{$entity};
$AlreadyCleaned{$entity} = 1;
# Work out which message to replace the attachment with.
# As there may be multiple types for 1 file, find them in
# in decreasing order of importance.
my $ModificationOnly = 0; # Is this just an "m" modification?
my $type = $this->{alltypes}{"$file"};
#print STDERR "In Clean message, type = $type and quar? = $storeme\n";
if ($type =~ /v/i) {
# It's a virus. Either delete or store it.
if ($storeme) {
$filename = MailScanner::Config::Value('storedvirusmessage',
$this);
} else {
$filename = MailScanner::Config::Value('deletedvirusmessage',
$this);
}
} elsif ($type =~ /f/i) {
# It's a filename trap. Either delete or store it.
if ($storeme) {
$filename = MailScanner::Config::Value('storedfilenamemessage',
$this);
} else {
$filename = MailScanner::Config::Value('deletedfilenamemessage',
$this);
}
} elsif ($type =~ /c/i) {
# It's dangerous content, either delete or store it.
if ($storeme) {
$filename = MailScanner::Config::Value('storedcontentmessage',
$this);
} else {
$filename = MailScanner::Config::Value('deletedcontentmessage',
$this);
}
} elsif ($type =~ /s/i) {
# It's dangerous content, either delete or store it.
if ($storeme) {
$filename = MailScanner::Config::Value('storedsizemessage',
$this);
} else {
$filename = MailScanner::Config::Value('deletedsizemessage',
$this);
}
} elsif ($type eq 'm') {
# The only thing wrong here is that the MIME structure has been
# modified, so the message must be re-built. Nothing needs to
# be removed from the message.
$ModificationOnly = 1;
} else {
# Treat it like a virus anyway, to be on the safe side.
if ($storeme) {
$filename = MailScanner::Config::Value('storedvirusmessage',
$this);
} else {
$filename = MailScanner::Config::Value('deletedvirusmessage',
$this);
}
}
# If entity is null then there was a parsing problem with the message,
# so don't try to walk its tree as it will fail.
next unless $entity;
# MIME structure has been modified, so the message must be rebuilt.
# Nothing needs to be cleaned though.
next if $ModificationOnly;
# If it's a silent virus, then only generate the report if anyone
# wants a copy of it in the quarantine. Or else it won't be quarantined
# but they will still get a copy of the report.
#print STDERR "\n\nSilent = " . $this->{silent} . " and Noisy = " . $this->{noisy} . "\n";
$filename = "" if $this->{silent} && !$this->{noisy} &&
!MailScanner::Config::Value('deliversilent', $this); # &&
# MailScanner::Config::Value('quarantinesilent', $this) !~ /1/;
# Do the actual attachment replacement
#print STDERR "File = \"$file\"\nthis = \"$this\"\n";
#print STDERR "Entity to clean is $entity\n" .
# "root entity is " . $this->{entity} . "\n";
if ($file eq "") {
# It's a report on the whole message, so use all the reports
# This is a virus disinfection on the *whole* message, so the
# cleaner needs to know not to generate any mime parts.
#print STDERR "Calling CleanEntity for whole message\n";
$this->CleanEntity($entity, $everyreport, $filename);
} else {
# It's a report on 1 section, so just use the report for that
#print STDERR "About to call CleanEntity of $filename, $text\n";
$this->CleanEntity($entity, $text, $filename);
}
}
# Now do the entity reports. These are for things like unparsable tnef
# files, partial messages, external-body messages, things like that
# which are always just errors.
# Work through each report in turn, 1 per attachment
#print STDERR "Entity reports are " . $this->{entityreports} . "\n";
while(($entity, $text) = each %{$this->{entityreports}}) {
#print STDERR "Cleaning $entity which had a report of $text\n";
# Find rogue entity reports that should point to tnefentity but don't
$entity = $this->{tnefentity} if $this->{badtnef} && !$entity;
next unless $entity; # Skip rubbish in the reports
# Turn the text name of the entity into the object itself
$entity = $this->{name2entity}{scalar($entity)};
$this->{bodymodified} = 1; # This message body has been changed in memory
#print STDERR "In Clean message, quar? = $storeme and entity = $entity\n";
# It's always an error, so handle it like a virus.
# Either delete or store it.
if ($storeme) {
$filename = MailScanner::Config::Value('storedvirusmessage', $this);
} else {
$filename = MailScanner::Config::Value('deletedvirusmessage', $this);
}
# Do the actual attachment replacement
#print STDERR "About to try to clean $entity, $text, $filename\n";
$this->CleanEntity($entity, $text, $filename);
}
# Sign the top of the message body with a text/html warning if they want.
if (MailScanner::Config::Value('markinfectedmessages',$this) =~ /1/ &&
!$this->{signed}) {
#print STDERR "In Clean message, about to sign message " . $this->{id} .
# "\n";
$this->SignWarningMessage($this->{entity});
$this->{signed} = 1;
}
#print STDERR "\n\n\nAfter Clean()\n";
#$this->PrintInfections();
}
# Do the actual attachment replacing
sub CleanEntity {
my $this = shift;
my($entity, $report, $reportname) = @_;
my(@parts, $Warning, $Disposition, $warningfile, $charset, $i);
# Find the parent as that's what you have to change
#print STDERR "CleanEntity: In ".$this->{id}." entity is $entity and " .
# "its parent is " . $this->{entity2parent}{$entity} . "\n";
my $parent = $this->{entity2parent}{$entity};
$warningfile = MailScanner::Config::Value('attachmentwarningfilename', $this);
$charset = MailScanner::Config::Value('attachmentcharset', $this);
#print STDERR "Cleaning entity whose report is $report\n";
# Infections applying to the entire message cannot be simply disinfected.
# Have to replace the entire message with a text/plain error.
unless ($parent) {
#print STDERR "Doing the whole message\n";
$Warning = $this->ConstructWarning(
MailScanner::Config::LanguageValue($this, 'theentiremessage'),
$report, $this->{id}, $reportname);
#print STDERR "Warning message is $Warning\n";
#031118 if ($this->{entity} eq $entity) {
if ($entity->bodyhandle) {
#print STDERR "Really doing the whole message\n";
#print STDERR "Really doing Whole message\n";
# Replacing the whole message as the main body text of the message
# contained a virus (e.g. the text of EICAR) without any proper
# MIME structure at all.
#print STDERR "Entity in CleanEntity is $entity\n";
#print STDERR "Bodyhandle is " . $entity->bodyhandle . "\n";
#031118 $entity->bodyhandle or return undef;
# Output message back into body
my($io, $filename, $temp);
$io = $entity->open("w");
$io->print($Warning . "\n");
$io->close;
# Set the MIME type if it was wrong
$filename = MailScanner::Config::Value('attachmentwarningfilename',
$this);
$temp = $entity->head->mime_attr('content-type');
$entity->head->mime_attr('Content-Type', 'text/plain') if
$temp && $temp ne 'text/plain';
# Set the charset if there was already a Content-type: header
$entity->head->mime_attr('Content-type.charset', $charset) if $temp;
$temp = $entity->head->mime_attr('content-type.name');
$entity->head->mime_attr('Content-type.name', $filename) if $temp;
$temp = $entity->head->mime_attr('content-disposition');
$entity->head->mime_attr('content-disposition', 'inline') if $temp;
$temp = $entity->head->mime_attr('content-disposition.filename');
$entity->head->mime_attr('content-disposition.filename', $filename)
if $temp;
return;
} else {
# If the message is multipart but the boundary is "" then it won't
# have any parts() which makes it impossible to overwrite without
# first forcing it to throw away all the structure by becoming
# single-part.
$entity->make_singlepart
if $entity->is_multipart && $entity->head &&
$entity->head->multipart_boundary eq "";
$parts[0] = MIME::Entity->build(
Type => 'text/plain',
Filename => $warningfile,
Disposition => 'inline',
Data => $Warning,
Encoding => 'quoted-printable',
Charset => $charset,
Top => 0);
$entity->make_multipart()
if $entity->head && $entity->head->mime_attr('content-type') eq "";
$entity->parts(\@parts);
return;
}
}
# Now know that the infection only applies to one part of the message,
# so replace that part with an error message.
@parts = $parent->parts;
# Find the infected part
my $tnef = $this->{tnefentity};
#print STDERR "TNEF entity is " . scalar($tnef) . "\n";
my $infectednum = -1;
#print STDERR "CleanEntity: Looking for entity $entity\n";
for ($i=0; $i<@parts; $i++) {
#print STDERR "CleanEntity: Comparing " . scalar($parts[$i]) .
# " with $entity\n";
if (scalar($parts[$i]) eq scalar($entity)) {
#print STDERR "Found it in part $i\n";
$infectednum = $i;
last;
}
if ($tnef && (scalar($parts[$i]) eq scalar($tnef))) {
#print STDERR "Found winmail.dat in part $i\n";
$infectednum = $i;
last;
}
}
#MailScanner::Log::WarnLog(
# "Oh bother, missed infected entity in message %s :-(", $this->{id}), return
# if $infectednum<0;
# Now to actually do something about it...
#print STDERR "About to constructwarning from $report\n";
$Warning = $this->ConstructWarning($this->{entity2file}{$entity},
$report, $this->{id}, $reportname);
#print STDERR "Reportname is \"$reportname\"\n";
#print STDERR "Warning is \"$Warning\"\n";
# If the warning is now 0 bytes, don't add it, just remove the virus
if ($Warning ne "") {
$Disposition = MailScanner::Config::Value('warningisattachment',$this)
?'attachment':'inline';
$parts[$infectednum] = build MIME::Entity
Type => 'text/plain',
Filename => $warningfile,
Disposition => $Disposition,
Data => $Warning,
Encoding => 'quoted-printable',
Charset => $charset,
Top => 0;
} else {
# We are just deleting the part, not replacing it
# @parts = splice @parts, $infectednum, 1;
$parts[$infectednum] = undef; # We prune the tree just during delivery
}
$parent->parts(\@parts);
# And make the parent a multipart/mixed if it's a multipart/alternative
# or multipart/related or message/partial
$parent->head->mime_attr("Content-type" => "multipart/mixed")
if ($parent->is_multipart) &&
($parent->head->mime_attr("content-type") =~
/multipart\/(alternative|related)/i);
if ($parent->head->mime_attr("content-type") =~ /message\/partial/i) {
$parent->head->mime_attr("Content-type" => "multipart/mixed");
# $parent->make_singlepart();
}
}
# Construct a warning message given an attachment filename, a copy of
# what the virus scanner said, the message id and a message filename to parse.
# The id is passed in purely for substituting into the warning message file.
sub ConstructWarning {
my $this = shift;
my($attachmententity, $scannersaid, $id, $reportname) = @_;
# If there is no report file then we create no warning
return "" unless $reportname;
my $date = $this->{datestring}; # scalar localtime;
my $textfh = new FileHandle;
my $dir = $global::MS->{work}{dir}; # Get the working directory
my $localpostmaster = MailScanner::Config::Value('localpostmaster', $this);
my $postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner');
#print STDERR "ConstructWarning for $attachmententity. Scanner said \"" .
# "$scannersaid\", message id $id, file = $reportname\n";
# Reformat the virus scanner report a bit, and optionally remove dirs
$scannersaid =~ s/^/ /gm;
if (MailScanner::Config::Value('hideworkdir',$this)) {
my $pattern = '(' . quotemeta($global::MS->{work}->{dir}) . "|\\\.)/";
#print STDERR "In replacement, regexp is \"$pattern\"\n";
$scannersaid =~ s/$pattern//g; #m # Remove the work dir
$scannersaid =~ s/\/?$id\/?//g; # Remove the message id
}
#print STDERR "After replacement, scanner said \"$scannersaid\"\n";
my $output = "";
my $result = "";
# These are all the variables that are allowed to appear
# in the report template.
my $filename = ($attachmententity ||
MailScanner::Config::LanguageValue($this, 'notnamed'));
#my $date = scalar localtime; Already defined above
my $report = $scannersaid;
my $hostname = MailScanner::Config::Value('hostname',$this);
my $linkhostname = lc($hostname);
$linkhostname =~ tr/a-z0-9_-//dc;
my $quarantinedir = MailScanner::Config::Value('quarantinedir', $this);
# And let them put the date number in there too
my($day, $month, $year);
#($day, $month, $year) = (localtime)[3,4,5];
#$month++;
#$year += 1900;
#my $datenumber = sprintf("%04d%02d%02d", $year, $month, $day);
my $datenumber = $this->{datenumber};
# # Do we want to hide the directory and message id from the report path?
# if (MailScanner::Config::Value('hideworkdir', $this)) {
# my $pattern = "(" . quotemeta($global::MS->{work}->{dir}) . "|\.)/$id/";
# $report =~ s/$pattern//gm;
# }
open($textfh, $reportname)
or MailScanner::Log::WarnLog("Cannot open message file %s, %s",
$reportname, $!);
my $line;
while(defined ($line = <$textfh>)) {
chomp $line;
#$line =~ s/"/\\"/g; # Escape any " characters
#$line =~ s/@/\\@/g; # Escape any @ characters
$line =~ s/([\(\)\[\]\.\?\*\+\^"'@])/\\$1/g; # Escape any regex characters
# Untainting joy...
$line =~ $1 if $line =~ /(.*)/;
$result = eval "\"$line\"";
$output .= MailScanner::Config::DoPercentVars($result) . "\n";
}
$output;
}
# Sign the body of the message with a text or html warning message
# directing users to read the VirusWarning.txt attachment.
# Return 0 if nothing was signed, true if it signed something.
sub SignWarningMessage {
my $this = shift;
my $top = shift;
#print STDERR "Top is $top\n";
return 0 unless $top;
# If multipart, try to sign our first part
if ($top->is_multipart) {
my $sigcounter = 0;
#print STDERR "It's a multipart message\n";
$sigcounter += $this->SignWarningMessage($top->parts(0));
$sigcounter += $this->SignWarningMessage($top->parts(1))
if $top->head and $top->effective_type =~ /multipart\/alternative/i;
if ($sigcounter == 0) {
# If we haven't signed anything by now, it must be a multipart
# message containing only things we can't sign. So add a text/plain
# section on the front and sign that.
my $text = $this->ReadVirusWarning('inlinetextwarning') . "\n\n";
my $newpart = build MIME::Entity
Type => 'text/plain',
Disposition => 'inline',
Data => $text,
Encoding => 'quoted-printable',
Top => 0;
$top->add_part($newpart, 0);
$sigcounter = 1;
}
return $sigcounter;
}
my $MimeType = $top->head->mime_type if $top->head;
#print STDERR "MimeType is $MimeType\n";
return 0 unless $MimeType =~ m{text/}i; # Won't sign non-text message.
# Won't sign attachments.
return 0 if $top->head->mime_attr('content-disposition') =~ /attachment/i;
# Get body data as array of newline-terminated lines
#print STDERR "Bodyhandle is " . $top->bodyhandle . "\n";
$top->bodyhandle or return undef;
my @body = $top->bodyhandle->as_lines;
#print STDERR "Signing message part\n";
# Output message back into body, followed by original data
my($line, $io, $warning);
$io = $top->open("w");
if ($MimeType =~ /text\/html/i) {
$warning = $this->ReadVirusWarning('inlinehtmlwarning');
#$warning = quotemeta $warning; # Must leave HTML tags alone!
foreach $line (@body) {
$line =~ s/\<html\>/$&$warning/i;
$io->print($line);
}
} else {
$warning = $this->ReadVirusWarning('inlinetextwarning');
$io->print($warning . "\n");
foreach $line (@body) { $io->print($line) }; # Original body data
}
(($body[-1]||'') =~ /\n\Z/) or $io->print("\n"); # Ensure final newline
$io->close;
# We signed something
return 1;
}
# Read the appropriate warning message to sign the top of cleaned messages.
# Passed in the name of the config variable that points to the filename.
# This is also used to read the inline signature added to the bottom of
# clean messages.
# Substitutions allowed in the message are
# $viruswarningfilename -- by default VirusWarning.txt
# $from
# $subject
# and $filename -- comma-separated list of infected attachments
sub ReadVirusWarning {
my $this = shift;
my($option) = @_;
my $file = MailScanner::Config::Value($option, $this);
my $viruswarningname = MailScanner::Config::Value('attachmentwarningfilename',
$this);
my($line);
#print STDERR "Reading virus warning message from $filename\n";
my $fh = new FileHandle;
$fh->open($file)
or (MailScanner::Log::WarnLog("Could not open inline file %s, %s",
$file, $!),
return undef);
# Work out the list of all the infected attachments, including
# reports applying to the whole message
my($attach, $text, %infected, $filename, $from, $subject, $id);
while (($attach, $text) = each %{$this->{allreports}}) {
# It affects the entire message if the entity of this file matches
# the entity of the entire message.
my $entity = $this->{file2entity}{"$attach"};
#if ($attach eq "") {
if ($this->{entity} eq $entity) {
$infected{MailScanner::Config::LanguageValue($this, "theentiremessage")}
= 1;
} else {
$infected{"$attach"} = 1;
}
}
# And don't forget the external bodies which are just entity reports
while (($attach, $text) = each %{$this->{entityreports}}) {
$infected{MailScanner::Config::LanguageValue($this, 'notnamed')} = 1;
}
$filename = join(', ', keys %infected);
$id = $this->{id};
$from = $this->{from};
$subject = $this->{subject};
my $result = "";
while (<$fh>) {
chomp;
s#"#\\"#g;
s#@#\\@#g;
# Boring untainting again...
/(.*)/;
$line = eval "\"$1\"";
$result .= MailScanner::Config::DoPercentVars($line) . "\n";
}
$fh->close();
$result;
}
# Sign the bottom of the message with a tag-line saying it is clean
# and MailScanner is wonderful :-)
# Have already checked that message is not infected, and that they want
# clean signatures adding to messages.
sub SignUninfected {
my $this = shift;
return if $this->{infected}; # Double-check!
my($entity, $scannerheader);
# Use the presence of an X-MailScanner: header to decide if the
# message will have already been signed by another MailScanner server.
$scannerheader = MailScanner::Config::Value('mailheader', $this);
$scannerheader =~ tr/://d;
#print STDERR "Signing uninfected message " . $this->{id} . "\n";
# Want to sign the bottom of the highest-level MIME entity
$entity = $this->{entity};
if (MailScanner::Config::Value('signalreadyscanned', $this) ||
(defined($entity) && !$entity->head->count($scannerheader))) {
$this->AppendSignCleanEntity($entity);
#$this->PrependSignCleanEntity($entity)
# if MailScanner::Config::Value('signtopaswell', $this);
$entity->head->add('MIME-Version', '1.0')
unless $entity->head->get('mime-version');
$this->{bodymodified} = 1;
}
}
# Sign the end of a message (which is an entity) with the given tag-line
sub PrependSignCleanEntity {
my $this = shift;
my($top) = @_;
my($MimeType, $signature, @signature);
return unless $top;
#print STDERR "In PrependSignCleanEntity, signing $top\n";
# If multipart, try to sign our first part
if ($top->is_multipart) {
my $sigcounter = 0;
# JKF Signed and encrypted multiparts must not be touched.
# JKF Instead put the sig in the epilogue. Breaks the RFC
# JKF but in a harmless way.
if ($top->effective_type =~ /multipart\/(signed|encrypted)/i) {
# Read the sig and put it in the epilogue, which may be ignored
$signature = $this->ReadVirusWarning('inlinetextpresig');
@signature = map { "$_\n" } split(/\n/, $signature);
unshift @signature, "\n";
$top->preamble(\@signature);
return 1;
}
$sigcounter += $this->PrependSignCleanEntity($top->parts(0));
$sigcounter += $this->PrependSignCleanEntity($top->parts(1))
if $top->head and $top->effective_type =~ /multipart\/alternative/i;
if ($sigcounter == 0) {
# If we haven't signed anything by now, it must be a multipart
# message containing only things we can't sign. So add a text/plain
# section on the front and sign that.
my $text = $this->ReadVirusWarning('inlinetextpresig') . "\n\n";
my $newpart = build MIME::Entity
Type => 'text/plain',
Charset =>
MailScanner::Config::Value('attachmentcharset', $this),
Disposition => 'inline',
Data => $text,
Encoding => 'quoted-printable',
Top => 0;
$top->add_part($newpart, 0);
$sigcounter = 1;
}
return $sigcounter;
}
$MimeType = $top->head->mime_type if $top->head;
return 0 unless $MimeType =~ m{text/}i; # Won't sign non-text message.
# Won't sign attachments.
return 0 if $top->head->mime_attr('content-disposition') =~ /attachment/i;
# Get body data as array of newline-terminated lines
$top->bodyhandle or return undef;
my @body = $top->bodyhandle->as_lines;
# Output original data back into body, followed by message
my($line, $io);
$io = $top->open("w");
if ($MimeType =~ /text\/html/i) {
$signature = $this->ReadVirusWarning('inlinehtmlpresig');
foreach $line (@body) {
$line =~ s/\<x?html\>/$&$signature/i;
$io->print($line);
}
#(($body[-1]||'') =~ /\n\Z/) or $io->print("\n"); # Ensure final newline
} else {
$signature = $this->ReadVirusWarning('inlinetextpresig');
$io->print("$signature\n");
foreach $line (@body) { $io->print($line) }; # Original body data
}
$io->close;
# We signed something
return 1;
}
# Sign the end of a message (which is an entity) with the given tag-line
sub AppendSignCleanEntity {
my $this = shift;
my($top) = @_;
my($MimeType, $signature, @signature);
return unless $top;
#print STDERR "In AppendSignCleanEntity, signing $top\n";
# If multipart, try to sign our first part
if ($top->is_multipart) {
my $sigcounter = 0;
# JKF Signed and encrypted multiparts must not be touched.
# JKF Instead put the sig in the epilogue. Breaks the RFC
# JKF but in a harmless way.
if ($top->effective_type =~ /multipart\/(signed|encrypted)/i) {
# Read the sig and put it in the epilogue, which may be ignored
$signature = $this->ReadVirusWarning('inlinetextsig');
@signature = map { "$_\n" } split(/\n/, $signature);
unshift @signature, "\n";
$top->epilogue(\@signature);
return 1;
}
$sigcounter += $this->AppendSignCleanEntity($top->parts(0));
$sigcounter += $this->AppendSignCleanEntity($top->parts(1))
if $top->head and $top->effective_type =~ /multipart\/alternative/i;
if ($sigcounter == 0) {
# If we haven't signed anything by now, it must be a multipart
# message containing only things we can't sign. So add a text/plain
# section on the front and sign that.
my $text = $this->ReadVirusWarning('inlinetextsig') . "\n\n";
my $newpart = build MIME::Entity
Type => 'text/plain',
Charset =>
MailScanner::Config::Value('attachmentcharset', $this),
Disposition => 'inline',
Data => $text,
Encoding => 'quoted-printable',
Top => 0;
$top->add_part($newpart, 0);
$sigcounter = 1;
}
return $sigcounter;
}
$MimeType = $top->head->mime_type if $top->head;
return 0 unless $MimeType =~ m{text/(html|plain)}i; # Won't sign non-text message.
# Won't sign attachments.
return 0 if $top->head->mime_attr('content-disposition') =~ /attachment/i;
# Get body data as array of newline-terminated lines
$top->bodyhandle or return undef;
my @body = $top->bodyhandle->as_lines;
# Output original data back into body, followed by message
my($line, $io, $FoundHTMLEnd);
$FoundHTMLEnd = 0; # If there is no </html> tag, still append the signature
$io = $top->open("w");
if ($MimeType =~ /text\/html/i) {
$signature = $this->ReadVirusWarning('inlinehtmlsig');
foreach $line (@body) {
$FoundHTMLEnd = 1 if $line =~ s/\<\/x?html\>/$signature$&/i;
$io->print($line);
}
$io->print($signature . "\n") unless $FoundHTMLEnd;
(($body[-1]||'') =~ /\n\Z/) or $io->print("\n"); # Ensure final newline
} else {
foreach $line (@body) { $io->print($line) }; # Original body data
$signature = $this->ReadVirusWarning('inlinetextsig');
$io->print("\n$signature\n");
}
$io->close;
# We signed something
return 1;
}
# Deliver an uninfected message. It is already signed as necessary.
# If the body has been modified then we need to reconstruct it from
# the MIME structure. If not modified, then just link it across to
# the outgoing queue.
sub DeliverUninfected {
my $this = shift;
if ($this->{bodymodified}) {
# The body of this message has been modified, so reconstruct
# it from the MIME structure and deliver that.
#print STDERR "Body modified\n";
$this->DeliverModifiedBody('cleanheader');
} else {
#print STDERR "Body not modified\n";
if (MailScanner::Config::Value('virusscan', $this) =~ /1/) {
#print STDERR "Message is scanned and clean\n";
$this->DeliverUnmodifiedBody('cleanheader');
} else {
#print STDERR "Message is unscanned\n";
$this->DeliverUnmodifiedBody('unscannedheader');
}
}
}
my($DisarmFormTag, $DisarmScriptTag, $DisarmCodebaseTag, $DisarmIframeTag,
$DisarmWebBug, $DisarmPhishing, $DisarmNumbers, $DisarmHTMLChangedMessage,
$DisarmWebBugFound, $DisarmPhishingFound, $PhishingSubjectTag,
$PhishingHighlight, $StrictPhishing, $WebBugWhitelist, $WebBugReplacement);
# Deliver a message which has not had its body modified in any way.
# This is a lot faster as it doesn't involve reconstructing the message
# body at all, it is just copied from the inqueue to the outqueue.
sub DeliverUnmodifiedBody {
my $this = shift;
my($headervalue) = @_;
#print STDERR "DisarmPhishingFound = " . $DisarmPhishingFound . " for message " . $this->{id} . "\n";
return if $this->{deleted}; # This should never happen
# Prune the entity tree to remove all undef values
PruneEntityTree($this->{entity},$this->{entity2file},$this->{file2entity});
#print STDERR "Delivering Unmodified Body message\n";
my $OutQ = MailScanner::Config::Value('outqueuedir', $this);
my $store = $this->{store};
# Link the queue data file from in to out
$store->LinkData($OutQ);
# Set up the output envelope with its (possibly modified) headers
# Used to do next line but it breaks text-only messages with no MIME
# structure as the MIME explosion will have created a MIME structure.
#$global::MS->{mta}->AddHeadersToQf($this, $this->{entity}->stringify_header);
$global::MS->{mta}->AddHeadersToQf($this);
# Remove duplicate subject: lines
$global::MS->{mta}->UniqHeader($this, 'Subject:');
# Add the information/help X- header
my $infoheader = MailScanner::Config::Value('infoheader', $this);
if ($infoheader) {
my $infovalue = MailScanner::Config::Value('infovalue', $this);
$global::MS->{mta}->ReplaceHeader($this, $infoheader, $infovalue);
}
$global::MS->{mta}->AddMultipleHeader($this, 'mailheader',
MailScanner::Config::Value($headervalue, $this), ', ');
# Delete all content length headers anyway. They are unsafe.
# No, leave them if nothing in the body has been modified.
#$global::MS->{mta}->DeleteHeader($this, 'Content-length:');
# Add the MCP header if necessary
$global::MS->{mta}->AddMultipleHeader($this, 'mcpheader',
$this->{mcpreport}, ', ')
if $this->{ismcp} ||
MailScanner::Config::Value('includemcpheader', $this);
# Add the spam header if they want that
#$global::MS->{mta}->AddHeader($this,
# MailScanner::Config::Value('spamheader',$this),
# $this->{spamreport})
# JKF 3/10/2005
$global::MS->{mta}->AddMultipleHeader($this, 'spamheader',
$this->{spamreport}, ', ')
if MailScanner::Config::Value('includespamheader', $this) ||
($this->{spamreport} && $this->{isspam});
# Add the spam stars if they want that. Limit it to 60 characters to avoid
# a potential denial-of-service attack.
my($stars,$starcount,$scoretext,$minstars,$scorefmt);
$starcount = int($this->{sascore}) + 0;
$starcount = 0 if $this->{spamwhitelisted}; # 0 stars if white-listed
$scorefmt = MailScanner::Config::Value('scoreformat', $this);
$scorefmt = '%d' if $scorefmt eq '';
$scoretext = sprintf($scorefmt, $this->{sascore}+0);
$minstars = MailScanner::Config::Value('minstars', $this);
$starcount = $minstars if $this->{isrblspam} && $minstars &&
$starcount<$minstars;
if (MailScanner::Config::Value('spamscorenotstars', $this)) {
$stars = $scoretext; # int($starcount);
} else {
$starcount = 60 if $starcount>60;
$stars = MailScanner::Config::Value('spamstarscharacter') x $starcount;
}
if (MailScanner::Config::Value('spamstars', $this) =~ /1/ && $starcount>0) {
$global::MS->{mta}->AddMultipleHeader($this, 'spamstarsheader',
$stars, ', ');
}
# Add the Envelope to and from headers
AddFromAndTo($this);
# Repair the subject line
$global::MS->{mta}->ReplaceHeader($this, 'Subject:', $this->{safesubject})
if $this->{subjectwasunsafe};
# Modify the subject line for Disarming
my $subjectchanged = 0;
my $disarmtag = MailScanner::Config::Value('disarmsubjecttext',$this);
my $phishingtag = MailScanner::Config::Value('phishingsubjecttag', $this);
#if ($this->{messagedisarmed}) {
# #print STDERR "Found messagedisarmed = " . join(',',@{$this->{disarmedtags}}) . "\n";
# if(MailScanner::Config::Value('disarmprependsubject',$this) =~ /1/ &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' ');
# $subjectchanged = 1;
# }
# if (grep /phishing/i, @{$this->{disarmedtags}}) {
# #print STDERR "Found a phishing disarmedtags\n";
# # We found it had a phishing link in it. Are we tagging phishing Subject?
# if (MailScanner::Config::Value('tagphishingsubject',$this) =~ /1/ &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $phishingtag)
#) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $phishingtag, ' ');
# $subjectchanged = 1;
# }
# }
#}
if ($this->{messagedisarmed}) {
#print STDERR "MessageDisarmed is set at 3878\n";
my $where = MailScanner::Config::Value('disarmmodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $disarmtag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $disarmtag, ' ');
$subjectchanged = 1;
#print STDERR "MessageDisarmed is set (end)\n";
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' ');
$subjectchanged = 1;
#print STDERR "MessageDisarmed is set (start)\n";
}
#print STDERR "disarmedtags = " . join(',',@{$this->{disarmedtags}}) . "\n";
}
#print STDERR "Hello from 3840\n";
if ($this->{disarmphishingfound}) { # grep /phishing/i, @{$this->{disarmedtags}}) {
# We found it had a phishing link in it. Are we tagging phishing Subject?
#print STDERR "DisarmPhishingFound at 3896!\n";
#print STDERR "ID = " . $this->{id} . "\n";
my $where = MailScanner::Config::Value('tagphishingsubject', $this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $phishingtag)) {
#print STDERR "end\n";
$global::MS->{mta}->AppendHeader($this, 'Subject:', $phishingtag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) {
#print STDERR "start\n";
$global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' ');
$subjectchanged = 1;
}
#}
}
# Modify the subject line for spam
# if it's spam AND they want to modify the subject line AND it's not
# already been modified by another of your MailScanners.
my $spamtag = MailScanner::Config::Value('spamsubjecttext', $this);
$spamtag =~ s/_SCORE_/$scoretext/;
$spamtag =~ s/_STARS_/$stars/i;
#if ($this->{isspam} && !$this->{ishigh} &&
# MailScanner::Config::Value('spamprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
# $subjectchanged = 1;
#}
if ($this->{isspam} && !$this->{ishigh}) {
my $where = MailScanner::Config::Value('spammodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
$subjectchanged = 1;
}
}
# If it is high-scoring spam, then add a different bit of text
$spamtag = MailScanner::Config::Value('highspamsubjecttext', $this);
$spamtag =~ s/_SCORE_/$scoretext/;
$spamtag =~ s/_STARS_/$stars/i;
#if ($this->{isspam} && $this->{ishigh} &&
# MailScanner::Config::Value('highspamprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
# $subjectchanged = 1;
#}
if ($this->{isspam} && $this->{ishigh}) {
my $where = MailScanner::Config::Value('highspammodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
$subjectchanged = 1;
}
}
# Modify the subject line for MCP
# if it's MCP AND they want to modify the subject line AND it's not
# already been modified by another of your MailScanners.
$starcount = int($this->{mcpsascore}) + 0;
$starcount = 0 if $this->{mcpwhitelisted}; # 0 stars if white-listed
$scorefmt = MailScanner::Config::Value('scoreformat', $this);
$scorefmt = '%d' if $scorefmt eq '';
$scoretext = sprintf($scorefmt, $this->{mcpsascore}+0);
my $mcptag = MailScanner::Config::Value('mcpsubjecttext', $this);
$mcptag =~ s/_SCORE_/$scoretext/;
#if ($this->{ismcp} && !$this->{ishighmcp} &&
# MailScanner::Config::Value('mcpprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
# $subjectchanged = 1;
#}
if ($this->{ismcp} && !$this->{ishighmcp}) {
my $where = MailScanner::Config::Value('mcpmodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
$subjectchanged = 1;
}
}
# If it is high-scoring MCP, then add a different bit of text
$mcptag = MailScanner::Config::Value('highmcpsubjecttext', $this);
$mcptag =~ s/_SCORE_/$scoretext/;
#if ($this->{ismcp} && $this->{ishighmcp} &&
# MailScanner::Config::Value('highmcpprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
# $subjectchanged = 1;
#}
if ($this->{ismcp} && $this->{ishighmcp}) {
my $where = MailScanner::Config::Value('highmcpmodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
$subjectchanged = 1;
}
}
# Modify the subject line for scanning -- but only do it if the
# subject hasn't already been modified by MailScanner for another reason.
my $modifscan = MailScanner::Config::Value('scannedmodifysubject', $this);
my $scantag = MailScanner::Config::Value('scannedsubjecttext', $this);
if ($modifscan =~ /start/ && !$subjectchanged &&
!$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $scantag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $scantag, ' ');
$subjectchanged = 1;
} elsif ($modifscan =~ /end|1/ && !$subjectchanged &&
!$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $scantag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $scantag, ' ');
$subjectchanged = 1;
}
# Remove any headers we don't want in the message
my(@removeme, $remove);
@removeme = split(/[,\s]+/, MailScanner::Config::Value('removeheaders', $this));
foreach $remove (@removeme) {
# Add a : if there isn't one already, it's needed for DeleteHeader()
$remove .= ':' unless $remove =~ /:$/;
$global::MS->{mta}->DeleteHeader($this, $remove);
}
# Add the extra headers they want for MCP and spam messages
my(@extraheaders, $extraheader);
my($key, $value);
@extraheaders = @{$this->{extramcpheaders}} if $this->{extramcpheaders};
push @extraheaders, @{$this->{extraspamheaders}} if $this->{extraspamheaders};
foreach $extraheader (@extraheaders) {
#print STDERR "Unmod Adding extra header $extraheader\n";
next unless $extraheader =~ /:/;
($key, $value) = split(/:\s*/, $extraheader, 2);
$global::MS->{mta}->AddMultipleHeaderName($this, $key . ':', $value, ', ');
}
# Add the secret archive recipients
my($extra, @extras);
foreach $extra (@{$this->{archiveplaces}}) {
next if $extra =~ /^\//;
next unless $extra =~ /@/;
push @extras, $extra;
}
$global::MS->{mta}->AddRecipients($this, @extras) if @extras;
# Write the new qf file, delete originals and unlock the message
$store->WriteHeader($this, $OutQ);
unless ($this->{gonefromdisk}) {
$store->DeleteUnlock();
$this->{gonefromdisk} = 1;
}
# Note this does not kick the MTA into life here any more
}
# Deliver a message which has had its body modified.
# This is slower as the message has to be reconstructed from all its
# MIME entities.
sub DeliverModifiedBody {
my $this = shift;
my($headervalue) = @_;
return if $this->{deleted}; # This should never happen
#print STDERR "Delivering Modified Body message with header \"$headervalue\"\n";
my $store = $this->{store};
# If there is no data structure at all for this message, then we
# can't sensibly deliver anything, so just delete it.
# The parsing must have failed completely.
my $entity = $this->{entity};
unless ($entity) {
#print STDERR "Deleting duff message\n";
unless ($this->{gonefromdisk}) {
$store->DeleteUnlock();
$this->{gonefromdisk} = 1;
}
return;
}
# Prune the entity tree to remove all undef values
#PruneEntityTree($this->{entity},$this->{entity2file},$this->{file2entity});
PruneEntityTree($entity,$this->{entity2file},$this->{file2entity});
my $OutQ = MailScanner::Config::Value('outqueuedir', $this);
# Write the new body file
#print STDERR "Writing the MIME body of $this, " . $this->{id} . "\n";
$store->WriteMIMEBody($this->{id}, $entity, $OutQ);
#print STDERR "Written the MIME body\n";
# Set up the output envelope with its (possibly modified) headers
$global::MS->{mta}->AddHeadersToQf($this, $this->{entity}->stringify_header);
# Remove duplicate subject: lines
$global::MS->{mta}->UniqHeader($this, 'Subject:');
# Add the information/help X- header
my $infoheader = MailScanner::Config::Value('infoheader', $this);
if ($infoheader) {
my $infovalue = MailScanner::Config::Value('infovalue', $this);
$global::MS->{mta}->ReplaceHeader($this, $infoheader, $infovalue);
}
# Add the clean/dirty header
#print STDERR "Adding clean/dirty header $headervalue\n";
$global::MS->{mta}->AddMultipleHeader($this, 'mailheader',
MailScanner::Config::Value($headervalue, $this), ', ');
# Delete all content length headers as the body has been modified.
$global::MS->{mta}->DeleteHeader($this, 'Content-length:');
# Add the MCP header if necessary
$global::MS->{mta}->AddMultipleHeader($this, 'mcpheader',
$this->{mcpreport}, ', ')
if $this->{ismcp} ||
MailScanner::Config::Value('includemcpheader', $this);
# Add the spam header if they want that
#$global::MS->{mta}->AddHeader($this,
# MailScanner::Config::Value('spamheader',$this),
# $this->{spamreport})
# JKF 3/10/2005
$global::MS->{mta}->AddMultipleHeader($this, 'spamheader',
$this->{spamreport}, ', ')
if MailScanner::Config::Value('includespamheader', $this) ||
($this->{spamreport} && $this->{isspam});
# Add the spam stars if they want that. Limit it to 60 characters to avoid
# a potential denial-of-service attack.
my($stars,$starcount,$scoretext,$minstars,$scorefmt);
$starcount = int($this->{sascore}) + 0;
$starcount = 0 if $this->{spamwhitelisted}; # 0 stars if white-listed
$scorefmt = MailScanner::Config::Value('scoreformat', $this);
$scorefmt = '%d' if $scorefmt eq '';
$scoretext = sprintf($scorefmt, $this->{sascore}+0);
$minstars = MailScanner::Config::Value('minstars', $this);
$starcount = $minstars if $this->{isrblspam} && $minstars &&
$starcount<$minstars;
if (MailScanner::Config::Value('spamscorenotstars', $this)) {
$stars = $scoretext; # int($starcount);
} else {
$starcount = 60 if $starcount>60;
$stars = MailScanner::Config::Value('spamstarscharacter') x $starcount;
}
if (MailScanner::Config::Value('spamstars', $this) =~ /1/ && $starcount>0) {
$global::MS->{mta}->AddMultipleHeader($this, 'spamstarsheader',
$stars, ', ');
}
# Add the Envelope to and from headers
AddFromAndTo($this);
# Repair the subject line
#print STDERR "Metadata is " . join("\n", @{$this->{metadata}}) . "\n";
$global::MS->{mta}->ReplaceHeader($this, 'Subject:', $this->{safesubject})
if $this->{subjectwasunsafe};
my $subjectchanged = 0;
# Modify the subject line for viruses or filename traps.
# Only use the filename trap test if it isn't infected by anything else.
my $nametag = MailScanner::Config::Value('namesubjecttext', $this);
my $contenttag = MailScanner::Config::Value('contentsubjecttext', $this);
my $sizetag = MailScanner::Config::Value('sizesubjecttext', $this);
#print STDERR "I have triggered a size trap\n" if $this->{sizeinfected};
if ($this->{nameinfected} && # Triggered a filename trap
!$this->{virusinfected} && # No other reports about it
!$this->{otherinfected} && # They want the tagging & not already tagged
!$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $nametag)) {
#if (MailScanner::Config::Value('nameprependsubject',$this)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $nametag, ' ');
# $subjectchanged = 1;
#}
my $where = MailScanner::Config::Value('namemodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $nametag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $nametag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $nametag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $nametag, ' ');
$subjectchanged = 1;
}
} elsif ($this->{sizeinfected} && # Triggered a size trap
!$this->{virusinfected} &&
!$this->{nameinfected}) { # &&
#!$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $sizetag)) {
#if (MailScanner::Config::Value('sizeprependsubject',$this)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $sizetag, ' ');
# $subjectchanged = 1;
#}
my $where = MailScanner::Config::Value('sizemodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $sizetag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $sizetag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $sizetag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $sizetag, ' ');
$subjectchanged = 1;
}
} elsif ($this->{otherinfected} && # Triggered a content trap
!$this->{virusinfected} && # No other reports about it
!$this->{nameinfected}) { #&& # They want the tagging & not already tagged
#!$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $contenttag)) {
#if (MailScanner::Config::Value('contentprependsubject',$this)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $contenttag, ' ');
# $subjectchanged = 1;
#}
my $where = MailScanner::Config::Value('contentmodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $contenttag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $contenttag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $contenttag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $contenttag, ' ');
$subjectchanged = 1;
}
} else {
# It may be really virus infected.
# Modify the subject line for viruses
# if it's infected AND they want to modify the subject line AND it's not
# already been modified by another of your MailScanners.
my $virustag = MailScanner::Config::Value('virussubjecttext', $this);
#print STDERR "I am infected\n" if $this->{infected};
#if ($this->{infected} &&
# MailScanner::Config::Value('virusprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $virustag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $virustag, ' ');
# $subjectchanged = 1;
#}
if ($this->{infected}) {
my $where = MailScanner::Config::Value('virusmodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $virustag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $virustag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $virustag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $virustag, ' ');
$subjectchanged = 1;
}
}
}
# Modify the subject line for Disarming
my $disarmtag = MailScanner::Config::Value('disarmsubjecttext',$this);
my $phishingtag = MailScanner::Config::Value('phishingsubjecttag', $this);
#print STDERR "phishingtag = $phishingtag\n";
if ($this->{messagedisarmed}) {
#print STDERR "DisarmPhishingFound is set at 4200\n";
#print STDERR "Message id = " . $this->{id} . "\n";
#print STDERR "Found messagedisarmed = " . join(',',@{$this->{disarmedtags}}) . "\n";
#if(MailScanner::Config::Value('disarmprependsubject',$this) =~ /1/ &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' ');
# $subjectchanged = 1;
#}
my $where = MailScanner::Config::Value('disarmmodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $disarmtag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $disarmtag, ' ');
$subjectchanged = 1;
#print STDERR "MessageDisarmed is set (end)\n";
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' ');
$subjectchanged = 1;
#print STDERR "MessageDisarmed is set (start)\n";
}
}
if ($this->{disarmphishingfound}) {
#print STDERR "disarmedtags = " . join(',',@{$this->{disarmedtags}}) . "\n";
#if (grep /phishing/i, @{$this->{disarmedtags}}) {
#print STDERR "Found phishing disarmedtags2\n";
# We found it had a phishing link in it. Are we tagging phishing Subject?
#if (MailScanner::Config::Value('tagphishingsubject',$this) =~ /1/ &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $phishingtag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $phishingtag, ' ');
# $subjectchanged = 1;
#}
# We found it had a phishing link in it. Are we tagging phishing Subject?
my $where = MailScanner::Config::Value('tagphishingsubject', $this);
#print STDERR "Where is $where\n";
#print STDERR "Subject tag check = " . $global::MS->{mta}->TextStartsHeader($this, 'Subject:', $phishingtag) . "***\n";
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $phishingtag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $phishingtag, ' ');
$subjectchanged = 1;
#print STDERR "end\n";
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $phishingtag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $phishingtag, ' ');
$subjectchanged = 1;
#print STDERR "start\n";
}
#}
}
# Modify the subject line for spam
# if it's spam AND they want to modify the subject line AND it's not
# already been modified by another of your MailScanners.
my $spamtag = MailScanner::Config::Value('spamsubjecttext', $this);
$spamtag =~ s/_SCORE_/$scoretext/;
$spamtag =~ s/_STARS_/$stars/i;
#if ($this->{isspam} && !$this->{ishigh} &&
# MailScanner::Config::Value('spamprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
# $subjectchanged = 1;
#}
if ($this->{isspam} && !$this->{ishigh}) {
my $where = MailScanner::Config::Value('spammodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
$subjectchanged = 1;
}
}
# If it is high-scoring spam, then add a different bit of text
$spamtag = MailScanner::Config::Value('highspamsubjecttext', $this);
$spamtag =~ s/_SCORE_/$scoretext/;
$spamtag =~ s/_STARS_/$stars/i;
#if ($this->{isspam} && $this->{ishigh} &&
# MailScanner::Config::Value('highspamprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
# $subjectchanged = 1;
#}
if ($this->{isspam} && $this->{ishigh}) {
my $where = MailScanner::Config::Value('highspammodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
$subjectchanged = 1;
}
}
# Modify the subject line for MCP
# if it's MCP AND they want to modify the subject line AND it's not
# already been modified by another of your MailScanners.
$starcount = int($this->{mcpsascore}) + 0;
$starcount = 0 if $this->{mcpwhitelisted}; # 0 stars if white-listed
$scorefmt = MailScanner::Config::Value('scoreformat', $this);
$scorefmt = '%d' if $scorefmt eq '';
$scoretext = sprintf($scorefmt, $this->{mcpsascore}+0);
my $mcptag = MailScanner::Config::Value('mcpsubjecttext', $this);
$mcptag =~ s/_SCORE_/$scoretext/;
#if ($this->{ismcp} && !$this->{ishighmcp} &&
# MailScanner::Config::Value('mcpprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
# $subjectchanged = 1;
#}
if ($this->{ismcp} && !$this->{ishighmcp}) {
my $where = MailScanner::Config::Value('mcpmodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
$subjectchanged = 1;
}
}
# If it is high-scoring MCP, then add a different bit of text
$mcptag = MailScanner::Config::Value('highmcpsubjecttext', $this);
$mcptag =~ s/_SCORE_/$scoretext/;
#if ($this->{ismcp} && $this->{ishighmcp} &&
# MailScanner::Config::Value('highmcpprependsubject',$this) &&
# !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
# $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
# $subjectchanged = 1;
#}
if ($this->{ismcp} && $this->{ishighmcp}) {
my $where = MailScanner::Config::Value('highmcpmodifysubject',$this);
if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' ');
$subjectchanged = 1;
} elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' ');
$subjectchanged = 1;
}
}
# Modify the subject line for scanning -- but only do it if the
# subject hasn't already been modified by MailScanner for another reason.
my $modifscan = MailScanner::Config::Value('scannedmodifysubject', $this);
my $scantag = MailScanner::Config::Value('scannedsubjecttext', $this);
if ($modifscan =~ /start/ && !$subjectchanged &&
!$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $scantag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $scantag, ' ');
} elsif ($modifscan =~ /end|1/ && !$subjectchanged &&
!$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $scantag)) {
$global::MS->{mta}->AppendHeader($this, 'Subject:', $scantag, ' ');
}
# Remove any headers we don't want in the message
my(@removeme, $remove);
@removeme = split(/[,\s]+/, MailScanner::Config::Value('removeheaders', $this));
foreach $remove (@removeme) {
# Add a : if there isn't one already, it's needed for DeleteHeader()
$remove .= ':' unless $remove =~ /:$/;
$global::MS->{mta}->DeleteHeader($this, $remove);
}
# Add the extra headers they want for MCP and spam messages
my(@extraheaders, $extraheader);
my($key, $value);
@extraheaders = @{$this->{extramcpheaders}} if $this->{extramcpheaders};
push @extraheaders, @{$this->{extraspamheaders}} if $this->{extraspamheaders};
foreach $extraheader (@extraheaders) {
#print STDERR "Mod Adding extra header $extraheader\n";
next unless $extraheader =~ /:/;
($key, $value) = split(/:\s*/, $extraheader, 2);
$global::MS->{mta}->AddMultipleHeaderName($this, $key . ':', $value, ', ');
}
# Add the secret archive recipients
my($extra, @extras);
foreach $extra (@{$this->{archiveplaces}}) {
next if $extra =~ /^\//;
next unless $extra =~ /@/;
push @extras, $extra;
}
$global::MS->{mta}->AddRecipients($this, @extras) if @extras;
# Write the new qf file, delete originals and unlock the message
#print STDERR "Writing the new qf file\n";
$store->WriteHeader($this, $OutQ);
unless ($this->{gonefromdisk}) {
$store->DeleteUnlock();
$this->{gonefromdisk} = 1;
}
# Note this does not kick the MTA into life here any more
}
# Prune all the undef branches out of an entity tree
sub PruneEntityTree {
my ($entity,$entity2file,$file2entity) = @_;
#print STDERR "Pruning $entity\n";
return undef unless $entity;
return $entity unless $entity->parts;
my(@newparts, $part, $newpart, $counter);
# Do a pre-traversal depth-first search of the tree
#print STDERR "Looking at $entity\n";
foreach $part ($entity->parts) {
#$counter++;
#print STDERR "$counter Going down to $part\n";
next unless $part;
#print STDERR "Non null $part\n";
$newpart = PruneEntityTree($part,$entity2file,$file2entity);
#$newpart = $newpart?PruneEntityTree($part,$entity2file,$file2entity):$part;
#print STDERR "Replacement is $newpart\n";
if ($newpart) {
#print STDERR "Adding replacement $newpart\n";
push @newparts, $newpart;
#print STDERR "Newparts = " . join(',',@newparts) . "\n";
#} else {
# my $file = $entity2file->{$newpart} if $entity2file;
# delete $entity2file->{$newpart} if $entity2file && $file;
# delete $file2entity->{$file} if $file2entity && $file;
}
#print STDERR "Coming up, added $newpart\n";
}
#print STDERR "About to return\n";
# Keep all the parts we found, prune as much as we can
if (@newparts) {
#print STDERR "Returning entity $entity with " . join(',',@newparts) . "\n";
$entity->parts(\@newparts);
return $entity;
} else {
#print STDERR "Returning undef\n";
return undef;
}
}
# Delete a message from the incoming queue
sub DeleteMessage {
my $this = shift;
#print STDERR "DeletingMessage " . $this->{id} . "\n";
unless ($this->{gonefromdisk}) {
$this->{store}->DeleteUnlock();
$this->{gonefromdisk} = 1;
}
$this->{deleted} = 1;
}
## Is this message from a local domain?
#sub IsFromLocalDomain {
# my $this = shift;
#
# #print STDERR "Deleting cleaned message " . $this->{id} . "\n";
# $this->{store}->Delete();
# $this->{store}->Unlock();
# $this->{deleted} = 1;
#}
# Work out if the message is infected with a "silent" virus such as Klez.
# Set the "silent" flag on all such messages.
# At the same time, find the "noisy" non-spoofing infections such as
# document macro viruses.
sub FindSilentAndNoisyInfections {
my $this = shift;
my(@silentin) = split(" ",MailScanner::Config::Value('silentviruses', $this));
my($silent, $silentin, @silent, $regexp, $allreports, $logstring, $allsilent);
my($virusreports);
my(@noisyin) = split(" ",MailScanner::Config::Value('noisyviruses', $this));
my($noisy, $noisyin, @noisy, $nregexp);
#print "-1 Silentin = \"" . join(',',@silentin) . "\"\n";
#print "-1 Noisy in = \"" . join(',',@noisyin) . "\"\n";
# Get out quickly if there's nothing to do
return unless @silentin || @noisyin;
# Turn each silent and noisy report into a regexp
$allsilent = 0;
foreach $silent (@silentin) {
if (lc($silent) eq 'all-viruses') {
$allsilent = 1;
next;
}
$silentin = quotemeta $silent;
push @silent, $silentin;
}
foreach $noisy (@noisyin) {
next if lc($noisy) eq 'all-viruses';
$noisyin = quotemeta $noisy;
push @noisy, $noisyin;
}
# Make 2 big regexps from them all
$regexp = "";
$nregexp = "";
$regexp = '(' . join(')|(', @silent) . ')' if @silent;
$nregexp = '(' . join(')|(', @noisy) . ')' if @noisy;
# Make 1 big string from all the reports
$allreports = join('', values %{$this->{allreports}});
$virusreports = join(' ', values %{$this->{virusreports}});
#print STDERR "FindSilentInfection: Looking for \"$regexp\" in \"" .
# $allreports . "\"\n";
#print STDERR "FindNoisyInfection: Looking for \"$nregexp\" in \"" .
# $allreports . "\"\n";
#$this->{silent} = 1 if @silentin && $allreports =~ /$regexp/i;
#$this->{noisy} = 1 if @noisyin && $allreports =~ /$nregexp/i;
# Do this with grep so I can extract the matching line.
$this->{silent} = 1 if $regexp && grep {$logstring .= "$_ " if /$regexp/i;}
values %{$this->{allreports}};
if ($allsilent && $virusreports) {
$this->{silent} = 1;
$logstring .= $virusreports;
}
$this->{noisy} = 1 if $nregexp && grep /$nregexp/i,
values %{$this->{allreports}};
#print STDERR "0 regexp = $nregexp and search = \"" . join('","',values %{$this->{allreports}}) . "\"\n";
#print STDERR "1 FindSilentInfection: Found it!\n" if $this->{silent};
#print STDERR "1 FindNoisyInfection: Found it!\n" if $this->{noisy};
return unless MailScanner::Config::Value('logsilentviruses', $this);
$logstring = join(',', values %{$this->{allreports}})
if !$logstring && $allsilent && $this->{silent} == 1;
$logstring =~ s/[\n,]+(.)/,$1/g;
MailScanner::Log::NoticeLog("Viruses marked as silent: %s", $logstring)
if $logstring;
#print STDERR "2 FindSilentInfection: Found it!\n" if $this->{silent};
#print STDERR "2 FindNoisyInfection: Found it!\n" if $this->{noisy};
}
# Deliver a cleaned message and remove it from the incoming queue
sub DeliverCleaned {
my $this = shift;
# The body of this message has been modified, so reconstruct
# it from the MIME structure and deliver that.
#print STDERR "Delivering cleaned up message " . $this->{id} . "\n";
$this->DeliverModifiedBody('dirtyheader');
}
# Send a warning message to the person who sent this message.
# Need to create variables for from, to, subject, date and report
# for use within the message.
sub WarnSender {
my $this = shift;
my($from,$to,$subject,$date,$allreports,$alltypes,$report,$type);
my($entityreports, @everyreportin, $entitytypes, @everytype);
my($emailmsg, $line, $messagefh, $msgname, $localpostmaster, $id);
my($hostname, $postmastername);
# Do we want to send the sender a warning at all?
# If nosenderprecedence is set to non-blank and contains this
# message precedence header, then just return.
my(@preclist, $prec, $precedence, $header);
@preclist = split(" ",
lc(MailScanner::Config::Value('nosenderprecedence', $this)));
$precedence = "";
foreach $header (@{$this->{headers}}) {
$precedence = lc($1) if $header =~ /^precedence:\s+(\S+)/i;
}
if (@preclist && $precedence ne "") {
foreach $prec (@preclist) {
if ($precedence eq $prec) {
MailScanner::Log::InfoLog("Skipping sender of precedence %s",
$precedence);
return;
}
}
}
# Now we know we want to send the message, it's not a bulk mail
$from = $this->{from};
# Don't ever send a message to "" or "<>"
return if $from eq "" || $from eq "<>";
# Setup other variables they can use in the message template
$id = $this->{id};
#$to = join(', ', @{$this->{to}});
$localpostmaster = MailScanner::Config::Value('localpostmaster', $this);
$postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner');
$hostname = MailScanner::Config::Value('hostname', $this);
$subject = $this->{subject};
$date = $this->{datestring}; # scalar localtime;
my($to, %tolist);
foreach $to (@{$this->{to}}) {
$tolist{$to} = 1;
}
$to = join(', ', sort keys %tolist);
$allreports = $this->{allreports};
$entityreports = $this->{entityreports};
push @everyreportin, values %$allreports;
push @everyreportin, values %$entityreports;
my $reportword = MailScanner::Config::LanguageValue($this, "report");
my($reportline, @everyreport);
foreach $reportline (@everyreportin) {
push @everyreport, map { ((/^$reportword: /m)?$_:"$reportword: $_") . "\n" }
split(/\n/, $reportline);
}
#print STDERR "Reports are \"" . join('", "', @everyreport) . "\"\n";
#$report = join('', @everyreport);
my %seen = ();
$report = join('', grep { ! $seen{$_} ++ } @everyreport);
#print STDERR "***Report to sender is***\n$report***END***\n";
$alltypes = $this->{alltypes};
$entitytypes = $this->{entitytypes};
push @everytype, values %$alltypes;
push @everytype, values %$entitytypes;
$type = join('', @everytype);
# Do we want to hide the directory and message id from the report path?
if (MailScanner::Config::Value('hideworkdir', $this)) {
my $pattern = "(" . quotemeta($global::MS->{work}->{dir}) . "|\\\.)/";
$report =~ s/$pattern//g; # m # Remove the work dir
$report =~ s/\/?$id\/?//g; # Remove the message id
}
# Set the report filename dependent on what triggered MailScanner, be it
# a virus, a filename trap, a Denial Of Service attack, or an parsing error.
if ($type =~ /v/i) {
$msgname = MailScanner::Config::Value('sendervirusreport', $this);
} elsif ($type =~ /f/i) {
$msgname = MailScanner::Config::Value('senderfilenamereport', $this);
} elsif ($type =~ /e/i) {
$msgname = MailScanner::Config::Value('sendererrorreport', $this);
} elsif ($type =~ /c/i) {
$msgname = MailScanner::Config::Value('sendercontentreport', $this);
} elsif ($type =~ /s/i) {
$msgname = MailScanner::Config::Value('sendersizereport', $this);
} else {
$msgname = MailScanner::Config::Value('sendervirusreport', $this);
}
#print STDERR "Report is $msgname\n";
# Work out the list of all the infected attachments, including
# reports applying to the whole message
my($attach, $text, %infected, $filename);
while (($attach, $text) = each %$allreports) {
if ($attach eq "") {
$infected{MailScanner::Config::LanguageValue($this, "theentiremessage")}
= 1;
} else {
$infected{"$attach"} = 1;
}
}
# And don't forget the external bodies which are just entity reports
while (($attach, $text) = each %$entityreports) {
$infected{MailScanner::Config::LanguageValue($this, 'notnamed')} = 1;
}
$filename = join(', ', keys %infected);
$messagefh = new FileHandle;
$messagefh->open($msgname)
or MailScanner::Log::WarnLog("Cannot open message file %s, %s",
$msgname, $!);
$emailmsg = "";
while(<$messagefh>) {
chomp;
s#"#\\"#g;
s#@#\\@#g;
# Boring untainting again...
/(.*)/;
$line = eval "\"$1\"";
$emailmsg .= MailScanner::Config::DoPercentVars($line) . "\n";
}
$messagefh->close();
# This did say $localpostmaster in the last parameter, but I changed
# it to '<>' so that the sender warnings couldn't bounce.
$global::MS->{mta}->SendMessageString($this, $emailmsg, '<>')
or MailScanner::Log::WarnLog("Could not send sender warning, %s", $!);
}
# Create the headers for a postmaster notification message.
# This is expensive so don't do it much!
sub CreatePostmasterHeaders {
my $this = shift;
my($to) = @_;
my($result, $charset);
# Make sure the Postmaster notice is in the right character set
$charset = MailScanner::Config::Value('attachmentcharset',$this);
$result = "From: \"" .
MailScanner::Config::Value('noticesfrom', $this) . "\" <" .
MailScanner::Config::Value('localpostmaster',$this) . ">\nTo: ";
#$to = MailScanner::Config::Value('noticerecipient',$this);
#$to =~ s/ +/, /g;
$result .= $to . "\nSubject: " .
MailScanner::Config::LanguageValue($this, 'noticesubject') . "\n";
$result .= "Content-type: text/plain; charset=$charset\n" if $charset;
return $result;
}
# Create the notification text for 1 email message.
sub CreatePostmasterNotice {
my $this = shift;
my(@everyrept);
push @everyrept, values %{$this->{allreports}};
push @everyrept, values %{$this->{entityreports}};
foreach (@everyrept) {
chomp;
s/\n/\n /g;
$_ .= "\n";
}
my $reportword = MailScanner::Config::LanguageValue($this, "report");
my $id = $this->{id};
my $from = $this->{from};
#my $to = join(', ', @{$this->{to}});
my $subj = $this->{subject};
my $ip = $this->{clientip};
my $rept = join(" $reportword: ", @everyrept);
#print STDERR "Rept is\n$rept\n";
# Build list of unique archive and quarantine storage locations
my @quarantines = grep /\//, @{$this->{archiveplaces}};
push @quarantines, grep /\//, @{$this->{quarantineplaces}};
my($quarantine, %quarantinelist);
foreach $quarantine (@quarantines) {
$quarantinelist{$quarantine} = 1;
}
$quarantine = join(', ', sort keys %quarantinelist);
# Build unique list of recipients. Avoids Postfix problem which has
# separate lists of real recipients and original recipients.
my($to, %tolist);
foreach $to (@{$this->{to}}) {
$tolist{$to} = 1;
}
$to = join(', ', sort keys %tolist);
my($result, $headers);
if (MailScanner::Config::Value('hideworkdirinnotice',$this)) {
my $pattern = '(' . quotemeta($global::MS->{work}->{dir}) . "|\\\.)/";
#print STDERR "In replacement, regexp is \"$pattern\"\n";
$rept =~ s/$pattern//g; #m # Remove the work dir
$rept =~ s/\/?$id\/?//g; # Remove the message id
}
my $reportspaces = 10 - length($reportword);
$reportword = ' ' x $reportspaces . $reportword if $reportspaces>0;
$result = "\n" .
" Sender: $from\n" .
"IP Address: $ip\n" .
" Recipient: $to\n" .
" Subject: $subj\n" .
" MessageID: $id\n" .
"Quarantine: $quarantine\n" .
"$reportword: $rept\n";
if (MailScanner::Config::Value('noticefullheaders', $this)) {
$headers = join("\n ", $global::MS->{mta}->OriginalMsgHeaders($this));
$result .= MailScanner::Config::LanguageValue($this, 'fullheadersare') .
":\n\n $headers\n\n";
}
$result;
}
# Find the attachments that have been disinfected and deliver them all
# in a new MIME message.
sub DeliverDisinfectedAttachments {
my $this = shift;
my(@list, $reports, $attachment);
$reports = $this->{oldviruses};
# Loop through every attachment in the original list
foreach $attachment (keys %$reports) {
#print STDERR "Looking to see if \"$attachment\" has been disinfected\n";
# Never attempt "whole body" disinfections
next if $attachment eq "";
# Skip messages that are in the new report list
next if defined $this->{virusreports}{"$attachment"};
# Don't disinfect files the disinfector renamed
if (!$global::MS->{work}->FileExists($this, $attachment)) {
#print STDERR "Skipping deleted/renamed attachment $attachment\n";
next;
}
# Add it to the list
#print STDERR "Adding $attachment to list of disinfected files\n";
push @list, $attachment;
}
# Is there nothing to do?
return unless @list;
#print STDERR "Have disinfected attachments " . join(',',@list) . "\n";
# Deliver a message to the original recipients containing the
# disinfected attachments. This is really a Sendmail-specific thing.
$global::MS->{work}->ChangeToMessage($this);
$this->DeliverFiles(@list);
}
# Create and deliver a new message from MailScanner about the
# disinfected files passed in @list.
sub DeliverFiles {
my $this = shift;
my(@files) = @_;
my($MaxSubjectLength, $from, $to, $subject, $newsubject, $top);
my($localpostmaster, $postmastername);
$MaxSubjectLength = 25;
$from = $this->{from};
#$to = join(', ', @{$this->{to}});
my($to, %tolist);
foreach $to (@{$this->{to}}) {
$tolist{$to} = 1;
}
$to = join(', ', sort keys %tolist);
$subject = $this->{subject};
$localpostmaster = MailScanner::Config::Value('localpostmaster', $this);
$postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner');
$newsubject = MailScanner::Config::LanguageValue($this, 'disinfected') .
": " . substr($subject, 0, $MaxSubjectLength);
$newsubject .= '...' if length($subject)>$MaxSubjectLength;
#print STDERR "About to deliver " . join(',',@files) . " to original " .
# "recipients after disinfection\n";
# Create the top-level MIME entity, just the headers
$top = MIME::Entity->build(Type => 'multipart/mixed',
From => "$postmastername <$localpostmaster>",
To => $to,
Subject => $newsubject,
'X-Mailer' => 'MailScanner',
MailScanner::Config::Value('mailheader', $this) =>
MailScanner::Config::Value('disinfectedheader', $this));
# Construct the text of the message body
my($textfh, $textfile, $output, $result, $attachment);
$textfh = new FileHandle;
$textfile = MailScanner::Config::Value('disinfectedreporttext', $this);
$textfh->open($textfile)
or MailScanner::Log::WarnLog("Cannot open disinfected report message " .
"file %s, %s", $textfile, $!);
$output = "";
my $line;
my $ea = qr/([\(\)\[\]\.\?\*\+\^"'@<>:])/;
while(<$textfh>) {
$line = chomp;
#s#"#\\"#g; # Escape any " characters
#s#@#\\@#g; # Escape any @ characters
$line =~ s/$ea/\\$1/g; # Escape any regex characters
# Untainting joy...
$line =~ /(.*)/;
$result = eval "\"$1\"";
$output .= MailScanner::Config::DoPercentVars($result) . "\n";
}
$textfh->close();
$top->attach(Data => $output);
# Construct all the attachments
foreach $attachment (@files) {
# Added "./" to start of next line to avoid potential DoS attack
$top->attach(Path => "./$attachment",
Type => "application/octet-stream",
Encoding => "base64",
Disposition => "attachment");
}
# Now send the message
$global::MS->{mta}->SendMessageEntity($this, $top, $localpostmaster)
or MailScanner::Log::WarnLog("Could not send disinfected message, %s",$!);
}
# Archive this message to any directories in its archiveplaces attribute
sub ArchiveToFilesystem {
my $this = shift;
my($dir, $todaydir, $target, $didanything);
$didanything = 0;
$todaydir = $this->{datenumber}; #MailScanner::Quarantine::TodayDir();
foreach $dir (@{$this->{archiveplaces}}) {
#print STDERR "Archive to $dir\n";
next unless $dir =~ /^\//; # Must be a pathname
# If it exists, and it's a file, then append the message to it
# in mbox format.
if (-f $dir) {
#print STDERR "It is a file\n";
$this->AppendToMbox($dir);
$didanything = 1;
next;
}
$target = "$dir/$todaydir";
unless (-d "$target") {
umask $global::MS->{quar}->{dirumask};
mkdir "$target",0777 or
MailScanner::Log::WarnLog("Cannot create directory %s", $target);
umask 0077;
}
#print STDERR "It is a dir\n";
umask $global::MS->{quar}->{fileumask};
$this->{store}->CopyToDir($target, $this->{id});
#print STDERR "Stored " . $this->{id} . " to $target\n";
umask 0077;
$didanything = 1;
}
return $didanything;
}
# Append a message to an mbox file
sub AppendToMbox {
my($this, $mbox) = @_;
my $fh = new IO::File "$mbox", "a";
if ($fh) {
# Print the mbox message header starting with a blank line and "From"
# From $from `date "+%a %b %d %T %Y"`
my($now, $recip);
$now = ctime();
$now =~ s/ (\d)/ 0$1/g; # Insert leading zeros where needed
print $fh "From " . $this->{from} . ' ' . $now . "\n";
foreach $recip (@{$this->{to}}) {
print $fh "X-MailScanner-Recipient: $recip\n";
}
$fh->flush;
# Write the entire message to this handle, then close.
$this->{store}->WriteEntireMessage($this, $fh);
print $fh "\n"; # Blank line at end of message to separate messages
$fh->close;
MailScanner::Log::InfoLog("Archived message %s to mbox file %s",
$this->{id}, $mbox);
} else {
MailScanner::Log::WarnLog("Failed to append message to pre-existing " .
"mbox file %s", $mbox);
}
}
sub ReflowHeader {
my($this, $key, $input) = @_;
my($output, $pos, $len, $firstline, @words, $word);
$output = "";
$pos = 0;
$firstline = 1;
@words = split(/,\s*/, $input);
foreach $word (@words) {
$len = length($word);
if ($firstline) {
$output = "$word";
$pos = $len + length($key)+1; # 1 = space between key and input
$firstline = 0;
next;
}
# Wrap at column 75 (pretty arbitrary number just less than 80)
if ($pos+$len < 75) {
$output .= ", $word";
$pos += 2 + $len;
} else {
$output .= ",\n\t$word";
$pos = 8 + $len;
}
}
return $output;
}
# Strip the HTML out of this message. All the checks have already
# been done, so just get on with it.
sub StripHTML {
my $this = shift;
#print STDERR "Stripping HTML from message " . $this->{id} . "\n";
$this->HTMLToText($this->{entity});
}
# Disarm some of the HTML tags in this message.
sub DisarmHTML {
my $this = shift;
#print STDERR "Tags to convert are " . $this->{tagstoconvert} . " on message " . $this->{id} . "\n";
# Set the disarm booleans for this message
$DisarmFormTag = 0;
$DisarmScriptTag = 0;
$DisarmCodebaseTag = 0;
$DisarmCodebaseTag = 0;
$DisarmIframeTag = 0;
$DisarmWebBug = 0;
$DisarmPhishing = 0;
$DisarmNumbers = 0;
$StrictPhishing = 0;
$DisarmWebBugFound = 0;
$PhishingSubjectTag= 0;
$PhishingHighlight = 0;
$DisarmFormTag = 1 if $this->{tagstoconvert} =~ /form/i;
$DisarmScriptTag = 1 if $this->{tagstoconvert} =~ /script/i;
$DisarmCodebaseTag = 1 if $this->{tagstoconvert} =~ /codebase/i;
$DisarmCodebaseTag = 1 if $this->{tagstoconvert} =~ /data/i;
$DisarmIframeTag = 1 if $this->{tagstoconvert} =~ /iframe/i;
$DisarmWebBug = 1 if $this->{tagstoconvert} =~ /webbug/i;
$PhishingSubjectTag= 1
if MailScanner::Config::Value('tagphishingsubject', $this) =~ /1/;
#print STDERR "PhishingSubjectTag = $PhishingSubjectTag\n";
$PhishingHighlight = 1
if MailScanner::Config::Value('phishinghighlight', $this) =~ /1/;
#print STDERR "PhishingHighlight = $PhishingHighlight\n";
$DisarmPhishingFound = 0;
$this->{disarmphishingfound} = 0;
$DisarmHTMLChangedMessage = 0;
if (MailScanner::Config::Value('findphishing', $this) =~ /1/) {
$DisarmPhishing = 1;
$DisarmNumbers = 1
if MailScanner::Config::Value('phishingnumbers', $this) =~ /1/;
$StrictPhishing = 1
if MailScanner::Config::Value('strictphishing', $this) =~ /1/;
}
# Construct the WebBugWhitelist - space and comma-separated list of words
$WebBugWhitelist = MailScanner::Config::Value('webbugwhitelist', $this);
$WebBugWhitelist =~ s/^\s+//;
$WebBugWhitelist =~ s/\s+$//;
$WebBugWhitelist =~ s/[\s,]+/|/g;
$WebBugReplacement = MailScanner::Config::Value('webbugurl', $this);
my($counter, @disarmedtags);
($counter, @disarmedtags) = $this->DisarmHTMLTree($this->{entity});
#print STDERR "disarmedtags = ". join(', ', @disarmedtags) . "\n";
# If the HTML checks found a real problem or there really was a phishing
# attack, only then should we log anything.
#print "DisarmPhishingFound = $DisarmPhishingFound on message " . $this->{id} . "\n";
$this->{disarmphishingfound} = 1 if $DisarmPhishingFound;
@disarmedtags = ('phishing') if $DisarmPhishingFound && $PhishingHighlight && !@disarmedtags; #JKF1 && $PhishingHighlight && !@disarmedtags;
#print STDERR "Found DisarmPhishingFound\n" if $DisarmPhishingFound;
MailScanner::Log::InfoLog('Content Checks: Detected and have disarmed ' .
join(', ', @disarmedtags) . ' tags in ' .
'HTML message in %s from %s',
$this->{id}, $this->{from})
if $DisarmHTMLChangedMessage || $DisarmPhishingFound;
# And save the results from the phishing trip
if ($DisarmPhishingFound) {
# Do we want this or not? I say no. $this->{otherinfected} = 1;
$this->{bodymodified} = 1;
#print STDERR "DisarmPhishingFound = $DisarmPhishingFound\n";
}
if ($DisarmHTMLChangedMessage) {
#print STDERR "Disarm Changed the message at 5132.\n";
$this->{bodymodified} = 1;
$this->{messagedisarmed} = 1;
} else {
$this->{messagedisarmed} = 0;
}
# Store all the tags we disarmed
#print STDERR "Storing " . join(',', @disarmedtags) . "\n";
@{$this->{disarmedtags}} = @disarmedtags;
}
# Search for a multipart/alternative.
# If found, change it to multipart/mixed and make all its members into
# suitable named attachments.
sub EncapsulateAttachments {
my($message, $searchtype, $entity, $filename) = @_;
# Reached a leaf node?
return 0 unless $entity && defined($entity->head);
my(@parts, $part, $type, $extension, $newname);
my $counter = 0;
$type = $entity->head->mime_attr('content-type');
if (!$searchtype || ($type && $type =~ /$searchtype/i)) {
#print STDERR "Found alternative message at entity $entity\n";
# Turn it into a multipart/mixed
$entity->head->mime_attr('content-type' => 'multipart/mixed')
if $searchtype;
# Change the parts into attachments
@parts = $entity->parts;
foreach $part (@parts) {
my $head = $part->head;
$type = $head->mime_attr('content-type') || 'text/plain';
$extension = '.dat';
$type =~ /\/([a-z0-9-]+)$/i and $extension = '.' . lc($1);
$extension = '.txt' if $type =~ /text\/plain/i;
$extension = '.html' if $type =~ /text\/html/i;
$newname = $filename . $extension;
$head->mime_attr('Content-Type' => $type);
$head->mime_attr('Content-Disposition' => 'attachment');
$head->mime_attr('Content-Disposition.filename' => $newname)
unless $head->mime_attr('Content-Disposition.filename');
$head->mime_attr('Content-Type.name' => $newname)
unless $head->mime_attr('Content-Type.name');
$counter++;
}
} else {
# Now try the same on all the parts
foreach $part (@parts) {
$counter += $message->EncapsulateAttachments($searchtype, $part,
$filename);
}
}
return $counter;
}
sub EncapsulateMessageHTML {
my $this = shift;
my($entity, $filename, $newpart);
$entity = $this->{entity};
$filename = MailScanner::Config::Value('originalmessage', $this);
$entity->make_multipart('mixed');
$this->EncapsulateAttachments('multipart/alternative', $entity, $filename)
or $this->EncapsulateAttachments(undef, $entity, $filename);
# Insert the new message part
$newpart = MIME::Entity->build(Type => "text/plain",
Disposition => undef,
Data => [ "Hello\n","There\n","Last line\n" ],
Filename => undef,
Top => 0,
'X-Mailer' => undef
);
$entity->add_part($newpart, 0); # Insert at the start of the message
# Clean up the message so spammers can't pollute me
$this->{entity}->preamble(undef);
$this->{entity}->epilogue(undef);
$this->{entity}->head->add('MIME-Version', '1.0')
unless $this->{entity}->head->get('mime-version');
$this->{bodymodified} = 1;
return;
}
# Encapsulate the message in an RFC822 structure so that it becomes a
# single atachment of the message. Need to build the spam report to put
# in as the text/plain body of the main message.
sub EncapsulateMessage {
my $this = shift;
my($entity, $rfc822, $mimeversion, $mimeboundary, @newparts);
my($messagefh, $filename, $emailmsg, $line, $charset);
my($id, $to, $from, $localpostmaster, $hostname, $subject, $date);
my($fullspamreport, $briefspamreport, $longspamreport, $sascore);
my($postmastername);
# For now, if there is no entity structure at all then just return,
# we cannot encapsulate a message without it.
# Unfortunately that means we can't encapsulate messages that are
# Virus Scanning = no ("yes" but also having "Virus Scanners=none" is
# fine, and works). The encapsulation will merely fail to do anything.
# Hopefully this will only be used by corporates who are virus scanning
# everything anyway.
# Workaround: Instead of using "Virus Scanning = no", use
# "Virus Scanners = none" and a set of filename rules that pass all files.
return unless $this->{entity};
# Construct the RFC822 attachment
$mimeversion = $this->{entity}->head->get('mime-version');
# Prune all the dead branches off the tree
PruneEntityTree($this->{entity},$this->{entity2file},$this->{file2entity});
$entity = $this->{entity};
$rfc822 = $entity->stringify;
# Setup variables they can use in the spam report that is inserted at
# the top of the message.
$id = $this->{id};
#$to = join(', ', @{$this->{to}});
my($to, %tolist);
foreach $to (@{$this->{to}}) {
$tolist{$to} = 1;
}
$to = join(', ', sort keys %tolist);
$from = $this->{from};
$localpostmaster = MailScanner::Config::Value('localpostmaster', $this);
$postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner');
$hostname = MailScanner::Config::Value('hostname', $this);
$subject = $this->{subject};
$date = $this->{datestring}; # scalar localtime;
$fullspamreport = $this->{spamreport};
$longspamreport = $this->{salongreport};
$sascore = $this->{sascore};
#$this->{salongreport} = ""; # Reset it so we don't ever insert it twice
# Delete everything in brackets after the SA report, if it exists
$briefspamreport = $fullspamreport;
$briefspamreport =~ s/(spamassassin)[^(]*\([^)]*\)/$1/i;
$charset = MailScanner::Config::Value('attachmentcharset', $this);
# Construct the spam report at the top of the message
$messagefh = new FileHandle;
$filename = MailScanner::Config::Value('inlinespamwarning', $this);
$messagefh->open($filename)
or MailScanner::Log::WarnLog("Cannot open inline spam warning file %s, %s",
$filename, $!);
$emailmsg = "";
while(<$messagefh>) {
chomp;
s#"#\\"#g;
s#@#\\@#g;
# Boring untainting again...
/(.*)/;
$line = eval "\"$1\"";
$emailmsg .= MailScanner::Config::DoPercentVars($line) . "\n";
}
$messagefh->close();
$newparts[0] = MIME::Entity->build(Type => 'text/plain',
Disposition => 'inline',
Encoding => 'quoted-printable',
Top => 0,
'X-Mailer' => undef,
Charset => $charset,
Data => $emailmsg);
$newparts[1] = MIME::Entity->build(Type => 'message/rfc822',
Disposition => 'attachment',
Top => 0,
'X-Mailer' => undef,
Data => $rfc822);
# If there was a multipart boundary, then create a new one so that
# the main message has a different boundary from the RFC822 attachment.
# Leave the RFC822 one alone, so we don't corrupt the original message,
# but make sure we create a new one instead.
# Keep generating random boundaries until we have definitely got a new one.
my $oldboundary = $entity->head->multipart_boundary;
do {
$mimeboundary = '======' . $$ . '==' . int(rand(100000)) . '======';
} while $mimeboundary eq $oldboundary;
# Put the new parts in place, hopefully it will correct all the multipart
# headers for me. Wipe the preamble and epilogue or else someone will use
# them to bypass the encapsulation process.
# Make it a report if it wasn't multipart already.
$entity->make_multipart("report"); # Used to be digest
# Try *real* hard to make it a digest.
$entity->head->mime_attr("Content-type" => "multipart/report"); # Used to be digest
$entity->head->mime_attr("Content-type.boundary" => $mimeboundary);
# Delete the "type" subfield which I don't think should be there
$entity->head->mime_attr("Content-type.type" => undef);
# JKF 09/11/2005 Added after bug report from Georg@hackt.net
$entity->head->mime_attr("Content-type.report-type" => 'spam-notification');
$entity->parts(\@newparts);
$entity->preamble(undef);
$entity->epilogue(undef);
$entity->head->add('MIME-Version', '1.0') unless $mimeversion;
$this->{bodymodified} = 1; # No infection but we changed the MIIME tree
}
sub DisarmHTMLTree {
my($this, $entity) = @_;
my $counter = 0; # Have we modified this message at all?
my @disarmed; # List of tags we have disarmed
#print STDERR "Disarming HTML Tree\n";
# Reached a leaf node?
return 0 unless $entity && defined($entity->head);
if ($entity->head->mime_attr('content-disposition') !~ /attachment/i &&
$entity->head->mime_attr('content-type') =~ /text\/html/i) {
#print STDERR "Found text/html message at entity $entity\n";
@disarmed = $this->DisarmHTMLEntity($entity);
#print STDERR "Disarmed = " . join(', ',@disarmed) . "\n";
if (@disarmed) {
$this->{bodymodified} = 1;
$DisarmHTMLChangedMessage = 1;
$counter++;
}
}
# Now try the same on all the parts
my(@parts, $part, $newcounter, @newtags);
@parts = $entity->parts;
foreach $part (@parts) {
($newcounter, @newtags) = $this->DisarmHTMLTree($part);
$counter += $newcounter;
@disarmed = (@disarmed, @newtags);
}
#print STDERR "Returning " . join(', ', @disarmed) . " from DisarmHTMLTree\n";
return ($counter, @disarmed);
}
# Walk the MIME tree, looking for text/html entities. Whenever we find
# one, create a new filename for a text/plain entity, and replace the
# part that pointed to the filename with a replacement that points to
# the new txt filename.
# Only replace inline sections, don't replace attachments, so that your
# users can still mail HTML attachments to each other.
# Then tag the message to say it has been modified, so that it is
# rebuilt from the MIME tree when it is delivered.
sub HTMLToText {
my($this, $entity) = @_;
my $counter; # Have we modified this message at all?
# Reached a leaf node?
return 0 unless $entity && defined($entity->head);
if ($entity->head->mime_attr('content-disposition') !~ /attachment/i &&
$entity->head->mime_attr('content-type') =~ /text\/html/i) {
#print STDERR "Found text/html message at entity $entity\n";
$this->HTMLEntityToText($entity);
MailScanner::Log::InfoLog('Content Checks: Detected and will convert ' .
'HTML message to plain text in %s',
$this->{id});
$this->{bodymodified} = 1; # No infection but we changed the MIIME tree
#$this->{otherreports}{""} .= "Converted HTML to plain text\n";
#$this->{othertypes}{""} .= "m"; # Modified body, but no infection
#$this->{otherinfected}++;
$counter++;
}
# Now try the same on all the parts
my(@parts, $part);
@parts = $entity->parts;
foreach $part (@parts) {
$counter += $this->HTMLToText($part);
}
return $counter;
}
# HTML::Parset callback function for normal text
my(%DisarmDoneSomething, $DisarmLinkText, $DisarmLinkURL, $DisarmAreaURL,
$DisarmInsideLink, $DisarmBaseURL);
# Convert 1 MIME entity from html to dis-armed HTML using HTML::Parser.
sub DisarmHTMLEntity {
my($this, $entity) = @_;
my($oldname, $newname, $oldfh, $outfh, $htmlparser);
#print STDERR "Disarming HTML $entity\n";
# Initialise all the variables we will use in the parsing, so nothing
# is inherited from old messages
$DisarmLinkText = "";
$DisarmLinkURL = "";
$DisarmInsideLink = 0;
$DisarmBaseURL = "";
$DisarmAreaURL = "";
%DisarmDoneSomething = ();
# Replace the filename with a new one
$oldname = $entity->bodyhandle->path();
#print STDERR "Path is $oldname\n";
$newname = $oldname;
$newname =~ s/\..?html?$//i; # Remove .htm .html .shtml
$newname .= '2.html'; # This should always pass the filename checks
$entity->bodyhandle->path($newname);
$outfh = new FileHandle;
unless ($outfh->open(">$newname")) {
MailScanner::Log::WarnLog('Could not create disarmed HTML file %s',
$newname);
return keys %DisarmDoneSomething;
}
# Set default output filehandle so we generate the new HTML
$oldfh = select $outfh;
# Process the old HTML file into the new one
if ($DisarmPhishing) {
HTML::Parser->new(api_version => 3,
start_h => [\&DisarmTagCallback, "tagname, text, attr, attrseq"],
end_h => [\&DisarmEndtagCallback, "tagname, text, '" . $this->{id} . "'"],
text_h => [\&DisarmTextCallback, "text"],
default_h => [ sub { print @_; }, "text"],
)
->parse_file($oldname)
or MailScanner::Log::WarnLog("HTML disarming, can't open file %s: %s",
$oldname, $!);
} else {
HTML::Parser->new(api_version => 3,
start_h => [\&DisarmTagCallback, "tagname, text, attr, attrseq"],
end_h => [\&DisarmEndtagCallback, "tagname, text, '" . $this->{id} . "'"],
default_h => [ sub { print @_; }, "text"],
)
->parse_file($oldname)
or MailScanner::Log::WarnLog("HTML disarming, can't open file %s: %s",
$oldname, $!);
}
select $oldfh;
$outfh->close();
# Tell the caller if we did anything
#print STDERR "Keys are " . join(', ', keys %DisarmDoneSomething) . "\n";
return keys %DisarmDoneSomething;
}
# HTML::Parser callback for text so we can collect the contents of links
sub DisarmTextCallback {
my($text) = @_;
unless ($DisarmInsideLink) {
print $text;
#print STDERR "DisarmText just printed \"$text\"\n";
return;
}
# We are inside a link.
# Save the original text, we well might need it.
$DisarmLinkText .= $text;
#print STDERR "DisarmText just added \"$text\"\n";
}
# HTML::Parser callback function for start tags
sub DisarmTagCallback {
my($tagname, $text, $attr, $attrseq) = @_;
#print STDERR "Disarming $tagname\n";
my $output = "";
my $webbugfilename;
if ($tagname eq 'form' && $DisarmFormTag) {
#print "It's a form\n";
$text = substr $text, 1;
$output .= "<BR><MailScannerForm$$ " . $text;
$DisarmDoneSomething{'form'} = 1;
} elsif ($tagname eq 'input' && $DisarmFormTag) {
#print "It's an input button\n";
$attr->{'type'} = "reset";
$output .= '<' . $tagname;
foreach (@$attrseq) {
next if /^on/;
$output .= ' ' . $_ . '="' . $attr->{$_} . '"';
}
$output .= '>';
$DisarmDoneSomething{'form input'} = 1;
} elsif ($tagname eq 'button' && $DisarmFormTag) {
#print "It's a button\n";
$attr->{'type'} = "reset";
$output .= '<' . $tagname;
foreach (@$attrseq) {
next if /^on/;
$output .= ' ' . $_ . '="' . $attr->{$_} . '"';
}
$output .= '>';
$DisarmDoneSomething{'form button'} = 1;
} elsif ($tagname eq 'object' && $DisarmCodebaseTag) {
#print "It's an object\n";
if (exists $attr->{'codebase'}) {
$text = substr $text, 1;
$output .= "<MailScannerObject$$ " . $text;
$DisarmDoneSomething{'object codebase'} = 1;
} elsif (exists $attr->{'data'}) {
$text = substr $text, 1;
$output .= "<MailScannerObject$$ " . $text;
$DisarmDoneSomething{'object data'} = 1;
} else {
$output .= $text;
}
} elsif ($tagname eq 'iframe' && $DisarmIframeTag) {
#print "It's an iframe\n";
$text = substr $text, 1;
$output .= "<MailScannerIFrame$$ " . $text;
$DisarmDoneSomething{'iframe'} = 1;
} elsif ($tagname eq 'script' && $DisarmScriptTag) {
#print "It's a script\n";
$text = substr $text, 1;
$output .= "<MailScannerScript$$ " . $text;
$DisarmDoneSomething{'script'} = 1;
} elsif ($tagname eq 'a' && $DisarmPhishing) {
#print STDERR "It's a link\n";
$output .= $text;
$DisarmLinkText = ''; # Reset state of automaton
$DisarmLinkURL = '';
$DisarmLinkURL = $attr->{'href'} if exists $attr->{'href'};
$DisarmInsideLink = 1;
$DisarmInsideLink = 0 if $DisarmLinkURL eq ''; # JPSB empty A tags. Was:
#Old: $DisarmInsideLink = 0 if $text =~ /\/\>$/; # JKF Catch /> empty A tags
#print STDERR "DisarmInsideLink = $DisarmInsideLink\n";
} elsif ($tagname eq 'img' && $DisarmWebBug) {
#print STDERR "It's an image\n";
#print STDERR "The src is \"" . $attr->{'src'} . "\"\n";
if (exists $attr->{'width'} && $attr->{'width'}<=2 &&
exists $attr->{'height'} && $attr->{'height'}<=2 &&
exists $attr->{'src'} && $attr->{'src'} !~ /^cid:|^$WebBugReplacement/i) {
# Is the filename in the WebBug whitelist?
$webbugfilename = $attr->{'src'};
$webbugfilename = $1 if $webbugfilename =~ /\/([^\/]+)$/;
if ($webbugfilename && $WebBugWhitelist &&
$webbugfilename =~ /$WebBugWhitelist/i) {
# It's in the whitelist, so ignore it
$output .= $text;
} else {
# It's not in the whitelist, so zap it with insecticide!
$output .= '<img src="' . $WebBugReplacement . '" width="' .
$attr->{'width'} . '" height="' . $attr->{'height'} .
'" alt="';
$output .= 'Web Bug from ' . $attr->{'src'} if $attr->{'src'};
$output .= '" />';
$DisarmWebBugFound = 1;
$DisarmDoneSomething{'web bug'} = 1;
}
} else {
$output .= $text;
}
} elsif ($tagname eq 'base') {
#print STDERR "It's a Base URL\n";
$output .= $text;
#print STDERR "Base URL = " . $attr->{'href'} . "\n";
$DisarmBaseURL = $attr->{'href'} if exists $attr->{'href'};
} elsif ($tagname eq 'area' && $DisarmInsideLink && $DisarmPhishing) {
#print STDERR "It's an imagemap area\n";
$output .= $text;
#print STDERR "Area URL = " . $attr->{'href'} . "\n";
$DisarmAreaURL = $attr->{'href'};
} else {
#print STDERR "The tag was a \"$tagname\"\n";
$output .= $text;
#print STDERR "output text is now \"$output\"\n";
}
# tagname DisarmPhishing
# a 0 0 1
# a 1 0 0 tagname=a && Disarm=1
# b 0 1 1
# b 1 1 0
#if ($DisarmInsideLink && !($tagname eq 'a' && $DisarmPhishing)) {
if ($DisarmInsideLink && ($tagname ne 'a' || !$DisarmPhishing)) {
$DisarmLinkText .= $output;
#print STDERR "StartCallback: DisarmLinkText now equals \"$DisarmLinkText\"\n";
} else {
print $output;
#print STDERR "StartCallback: Printed2 \"$output\"\n";
}
}
# HTML::Parser callback function for end tags
sub DisarmEndtagCallback {
my($tagname, $text, $id) = @_;
if ($tagname eq 'iframe' && $DisarmIframeTag) {
print "</MailScannerIFrame$$>";
$DisarmDoneSomething{'iframe'} = 1;
} elsif ($tagname eq 'form' && $DisarmFormTag) {
print "</MailScannerForm$$>";
$DisarmDoneSomething{'form'} = 1;
} elsif ($tagname eq 'script' && $DisarmScriptTag) {
print "</MailScannerScript$$>";
$DisarmDoneSomething{'script'} = 1;
} elsif ($tagname eq 'map' && $DisarmAreaURL) {
# We are inside an imagemap that is part of a phishing imagemap
$DisarmLinkText .= '</map>';
} elsif ($tagname eq 'a' && $DisarmPhishing) {
#print STDERR "Endtag Callback found link, " .
# "disarmlinktext = \"$DisarmLinkText\"\n";
my($squashedtext,$linkurl,$alarm,$numbertrap);
$DisarmInsideLink = 0;
$squashedtext = lc($DisarmLinkText);
if ($DisarmAreaURL) {
$squashedtext = $DisarmLinkURL;
$DisarmLinkURL = lc($DisarmAreaURL);
$DisarmAreaURL = ""; # End of a link, so reset this
} else {
$squashedtext = lc($DisarmLinkText);
}
# Try to filter out mentions of Microsoft's .NET system
$squashedtext = "" if $squashedtext eq ".net";
$squashedtext = "" if $squashedtext =~ /(^|\b)(ado|asp)\.net($|\b)/;
$squashedtext =~ s/\%a0//g;
$squashedtext =~ s#%([0-9a-f][0-9a-f])#chr(hex('0x' . $1))#gei; # Unescape
#Moved below tag removal, as required by new 'Remove tags' re.
#$squashedtext =~ s/\s+//g; # Remove any whitespace
$squashedtext =~ s/\\/\//g; # Change \ to / as many browsers do this
$squashedtext =~ s/^\[\d*\]//; # Removing leading [numbers]
#$squashedtext =~ s/(\<\/?[^>]*\>)*//ig; # Remove tags
$squashedtext =~ s/(\<\/?\w+((\s+\w+(\s*=\s*(?:\".*?\"|\'.*?\'|[^\'\">\s]+))?)+\s*|\s*)\/?\>)*//ig; # Remove tags, better re from snifer_@hotmail.com
$squashedtext =~ s/\s+//g; # Remove any whitespace
$squashedtext =~ s/^[^\/:]+\@//; # Remove username of email addresses
#$squashedtext =~ s/\&\w*\;//g; # Remove things like < and >
$squashedtext =~ s/^\<\;//g; # Remove leading <
$squashedtext =~ s/\>\;$//g; # Remove trailing >
$squashedtext =~ s/\<\;/\</g; # Remove things like < and >
$squashedtext =~ s/\>\;/\>/g; # rEmove things like < and >
#$squashedtext =~ s/./CharToIntnl("$&")/ge;
$squashedtext = StringToIntnl($squashedtext); # s/./CharToIntnl("$&")/ge;
#print STDERR "Text = \"$text\"\n";
#print STDERR "1SquashedText = \"$squashedtext\"\n";
#print STDERR "1LinkURL = \"$DisarmLinkURL\"\n";
# If it looks like a link, remove any leading https:// or ftp://
($linkurl,$alarm) = CleanLinkURL($DisarmLinkURL);
#print STDERR "linkurl = $linkurl\nBefore If statement\n";
#print STDERR "squashedtext = $squashedtext\nBefore If statement\n";
# Has it fallen foul of the numeric-ip phishing net? Must treat x
# like a digit so it catches 0x41 (= 'A')
$numbertrap = ($DisarmNumbers && $linkurl !~ /[<>g-wyz]+/)?1:0;
if ($alarm ||
$squashedtext =~ /^(w+|ft+p|fpt+|ma[il]+to)([.,]|\%2e)/i ||
$squashedtext =~ /[.,](com|org|net|info|biz|ws)/i ||
$squashedtext =~ /[.,]com?[.,][a-z][a-z]/i ||
$squashedtext =~ /^(ht+ps?|ft+p|fpt+|mailto)[:;](\/\/)?(.*(\.|\%2e))/i ||
$numbertrap) {
$squashedtext =~ s/^(ht+ps?|ft+p|fpt+|mailto)[:;](\/\/)?(.*(\.|\%2e))/$3/i;
$squashedtext =~ s/\/.*$//; # Only compare the hostnames
$squashedtext =~ s/[,.]+$//; # Allow trailing dots and commas
$squashedtext = 'www.' . $squashedtext
unless $squashedtext =~ /^ww+|ft+p|fpt+|mailto/ || $numbertrap;
#print STDERR "2SquashedText = \"$squashedtext\"\n";
# If we have already tagged this link as a phishing attack, spot the
# warning text we inserted last time and don't tag it again.
my $possiblefraudstart = MailScanner::Config::LanguageValue(0, 'possiblefraudstart');
my $squashedpossible = lc($possiblefraudstart);
my $squashedsearch = lc($DisarmLinkText);
$squashedpossible =~ s/\s//g;
$squashedpossible =~ s/(\<\/?[^>]*\>)*//ig; # Remove tags
$squashedsearch =~ s/\s//g;
$squashedsearch =~ s/(\<\/?[^>]*\>)*//ig; # Remove tags
#$squashedpossible = "www.$squashedpossible\"$linkurl\"";
$squashedpossible = quotemeta($squashedpossible);
#print STDERR "NEW CODE: SquashedText = $squashedtext\n";
#print STDERR "NEW CODE: DisarmLinkText = $DisarmLinkText\n";
#print STDERR "NEW CODE: Text = $text\n";
#print STDERR "NEW CODE: SquashedPossible = $squashedpossible\n";
#print STDERR "NEW CODE: LinkURL = $linkurl\n";
if ($squashedtext =~ /$squashedpossible/) {
#print STDERR "FOUND IT\n";
#print STDERR "$DisarmLinkText$text\n";
print "$DisarmLinkText$text";
$DisarmLinkText = ""; # Reset state of automaton
return;
}
#print STDERR "2LinkURL = \"$linkurl\"\n";
# If it is a phishing catch, or else it's not (numeric or IPv6 numeric)
# then notify.
#print STDERR "LinkURL is \"$linkurl\"\n";
#print STDERR "Squashe is \"$squashedtext\"\n";
#print STDERR "Phishing by numbers is $DisarmNumbers\n";
#
# Less strict phishing net code is here
#
if (!$StrictPhishing) {
my $TheyMatch = 0;
unless (InPhishingWhitelist($linkurl)) {
#print STDERR "Not strict phishing\n";
# We are just looking at the domain name and country code (more or less)
# Find the end of the domain name so we know what to strip
my $domain = $linkurl;
$domain =~ s/\/*$//; # Take off trailing /
$domain =~ s/\.([^.]{2,100})$//; # Take off .TLD
my $tld = $1;
$domain =~ s/([^.]{2,100})$//; # Take off SLD
my $sld = $1;
# Now do the same for the squashed text, i.e. where they claim it is
my $text = $squashedtext;
#print STDERR "Comparing $linkurl and $squashedtext\n";
#print STDERR "tld = $tld and sld = $sld\n";
$text =~ s/\/*$//; # Take off trailing /
$text =~ s/\.([^.]{2,100})$//; # Take off .TLD
my $ttld = $1;
$text =~ s/([^.]{2,100})$//; # Take off SLD
my $tsld = $1;
#print STDERR "ttld = $ttld and tsld = $tsld\n";
if ($tld && $ttld && $sld && $tsld && $tld eq $ttld && $sld eq $tsld) {
#print STDERR "tld/sld test matched\n";
# domain.org or domain.3rd.2nd.india
# Last 2 words match (domain.org), should that be enough or do we
# need to compare the next word too (domain.org.uk) ?
# We need to check the next word too.
$domain =~ s/([^.]{2,100})\.$//; # Take off 3LD.
my $third = $1;
$text =~ s/([^.]{2,100})\.$//; # Take off 3LD.
my $tthird = $1;
#print STDERR "third = $third and tthird = $tthird\n";
if ($MailScanner::Config::SecondLevelDomainExists{"$sld.$tld"}) {
# domain.org.uk
$TheyMatch = 1 if $third && $tthird && $third eq $tthird;
} else {
# Maybe we have a 3rd level domain base?
if ($MailScanner::Config::SecondLevelDomainExists{"$third.$sld.$tld"}) {
# We need to check the next (4th) word too.
$domain =~ /([^.]{2,100})\.$/; # Store 4LD
my $fourth = $1;
$text =~ /([^.]{2,100})\.$/; # Store 4LD
my $tfourth = $1;
$TheyMatch = 1 if $fourth && $tfourth && $fourth eq $tfourth &&
$third && $tthird && $third eq $tthird;
} else {
# We don't have a 3rd level, and we cannot have got here if
# there was a 2nd level, so it must just look like domain.org,
# so matches if tld and sld are the same. But we must have that
# true or we would never have got here, so they must match.
$TheyMatch = 1;
}
}
}
#
# Put phishing reporting code in here too.
#
if ($linkurl ne "") {
if ($TheyMatch) {
# Even though they are the same, still squeal if it's a raw IP
if ($numbertrap) {
print MailScanner::Config::LanguageValue(0, 'numericlinkwarning')
. ' '
if $PhishingHighlight; # && !InPhishingWhitelist($linkurl);
$DisarmPhishingFound = 1;
$linkurl = substr $linkurl, 0, 80;
$squashedtext = substr $squashedtext, 0, 80;
$DisarmDoneSomething{'phishing'} = 1 if $PhishingHighlight; #JKF1 $PhishingSubjectTag;
use bytes; # Don't send UTF16 to syslog, it breaks!
MailScanner::Log::NoticeLog('Found ip-based phishing fraud from ' .
'%s in %s', $linkurl, $id);
}
# If it wasn't a raw IP, then everything looks fine
} else {
# They didn't match so it's definitely an attack
print $possiblefraudstart . ' "' . $linkurl . '" ' .
MailScanner::Config::LanguageValue(0, 'possiblefraudend') .
' ' if $PhishingHighlight; # && !InPhishingWhitelist($linkurl);
$DisarmPhishingFound = 1;
$linkurl = substr $linkurl, 0, 80;
$squashedtext = substr $squashedtext, 0, 80;
$DisarmDoneSomething{'phishing'} = 1 if $PhishingHighlight; #JKF1 $PhishingSubjectTag;
use bytes; # Don't send UTF16 to syslog, it breaks!
MailScanner::Log::NoticeLog('Found phishing fraud from %s ' .
'claiming to be %s in %s',
$linkurl, $squashedtext, $id);
#$DisarmLinkURL);
}
# End of less strict reporting code.
# But it probably was a phishing attack so print it all out
no bytes;
print "$DisarmLinkText"; # JKF 20060820 $text";
$DisarmLinkText = ""; # Reset state of automaton
}
}
# End of less strict phishing net.
} else {
#
# Strict Phishing Net Goes Here
#
if ($alarm ||
($linkurl ne "" && $squashedtext !~ /^(w+\.)?\Q$linkurl\E\/?$/)
|| ($linkurl ne "" && $numbertrap)) {
unless (InPhishingWhitelist($linkurl)) {
use bytes; # Don't send UTF16 to syslog, it breaks!
if ($linkurl ne "" && numbertrap && $linkurl eq $squashedtext) {
# It's not a real phishing trap, just a use of numberic IP links
print MailScanner::Config::LanguageValue(0, 'numericlinkwarning') .
' ' if $PhishingHighlight;
} else {
# It's a phishing attack.
print $possiblefraudstart . ' "' . $linkurl . '" ' .
MailScanner::Config::LanguageValue(0, 'possiblefraudend') .
' ' if $PhishingHighlight;
}
$DisarmPhishingFound = 1;
$linkurl = substr $linkurl, 0, 80;
$squashedtext = substr $squashedtext, 0, 80;
$DisarmDoneSomething{'phishing'} = 1 if $PhishingHighlight; #JKF1 $PhishingSubjectTag;
if ($numbertrap) {
MailScanner::Log::InfoLog('Found ip-based phishing fraud from ' .
'%s in %s', $linkurl, $id);
} else {
MailScanner::Log::InfoLog('Found phishing fraud from %s ' .
'claiming to be %s in %s',
$linkurl, $squashedtext, $id);
#$DisarmLinkURL);
}
#print STDERR "Fake\n";
no bytes;
}
}
}
}
#print STDERR "End tag printed \"$DisarmLinkText$text\"\n";
print "$DisarmLinkText$text";
$DisarmLinkText = ""; # Reset state of automaton
#print STDERR "Reset disarmlinktext\n";
#
# End of all phishing code
#
} elsif ($DisarmInsideLink) {
# If inside a link, add the text to the link text to allow tags in links
$DisarmLinkText .= $text;
} else {
# It is not a tag we worry about, so just print the text and continue.
print $text;
}
}
my %CharToInternational = (
160,'nbsp',
161,'iexcl',
162,'cent',
163,'pound',
164,'curren',
165,'yen',
166,'brvbar',
167,'sect',
168,'uml',
169,'copy',
170,'ordf',
171,'laquo',
172,'not',
173,'shy',
174,'reg',
175,'macr',
176,'deg',
177,'plusmn',
178,'sup2',
179,'sup3',
180,'acute',
181,'micro',
182,'para',
183,'middot',
184,'cedil',
185,'sup1',
186,'ordm',
187,'raquo',
188,'frac14',
189,'frac12',
190,'frac34',
191,'iquest',
192,'Agrave',
193,'Aacute',
194,'Acirc',
195,'Atilde',
196,'Auml',
197,'Aring',
198,'AElig',
199,'Ccedil',
200,'Egrave',
201,'Eacute',
202,'Ecirc',
203,'Euml',
204,'Igrave',
205,'Iacute',
206,'Icirc',
207,'Iuml',
208,'ETH',
209,'Ntilde',
210,'Ograve',
211,'Oacute',
212,'Ocirc',
213,'Otilde',
214,'Ouml',
215,'times',
216,'Oslash',
217,'Ugrave',
218,'Uacute',
219,'Ucirc',
220,'Uuml',
221,'Yacute',
222,'THORN',
223,'szlig',
224,'agrave',
225,'aacute',
226,'acirc',
227,'atilde',
228,'auml',
229,'aring',
230,'aelig',
231,'ccedil',
232,'egrave',
233,'eacute',
234,'ecirc',
235,'euml',
236,'igrave',
237,'iacute',
238,'icirc',
239,'iuml',
240,'eth',
241,'ntilde',
242,'ograve',
243,'oacute',
244,'ocirc',
245,'otilde',
246,'ouml',
247,'divide',
248,'oslash',
249,'ugrave',
250,'uacute',
251,'ucirc',
252,'uuml',
253,'yacute',
254,'thorn',
255,'yuml'
);
# Turn any character into an international version of it if it is in the range
# 160 to 255.
sub CharToIntnl {
my $p = shift @_;
# Passed in an 8-bit character.
#print STDERR "Char in is $p\n";
($a) = unpack 'C', $p;
#print STDERR "Char is $a, $p\n";
# Bash char 160 (space) to nothing
return '' if $a == 160;
my $char = $CharToInternational{$a};
return '&' . $char . ';' if $char ne "";
return $p;
}
# Like CharToIntnl but does entire string
sub StringToIntnl {
my $original = shift;
# Much faster char conversion for whole strings
my(@newlinkurl, $newlinkurl, $char);
@newlinkurl = unpack("C*", $original); # Get an array of characters
foreach (@newlinkurl) {
next if $_ == 160;
$char = $CharToInternational{$_};
if (defined $char) {
$newlinkurl .= '&' . $char . ';';
} else {
$newlinkurl .= chr($_);
}
}
return $newlinkurl;
#$linkurl = $newlinkurl unless $newlinkurl eq "";
#$linkurl =~ s/./CharToIntnl("$&")/ge; -- Old slow version
}
# Clean up a link URL so it is suitable for phishing detection
# Return (clean url, alarm trigger value). An alarm trigger value non-zero
# means this is definitely likely to be a phishing trap, no matter what
# anything else says.
sub CleanLinkURL {
my($DisarmLinkURL) = @_;
use bytes;
my($linkurl,$alarm);
$alarm = 0;
$linkurl = $DisarmLinkURL;
$linkurl = lc($linkurl);
#print STDERR "Cleaning up $linkurl\n";
#$linkurl =~ s/\%a0//ig;
#$linkurl =~ s/\%e9/é/ig;
$linkurl =~ s#%([0-9a-f][0-9a-f])#chr(hex('0x' . $1))#gei; # Unescape
#print STDERR "2Cleaning up $linkurl\n";
$linkurl = StringToIntnl($linkurl);
#$linkurl =~ s/./CharToIntnl("$&")/ge; -- Old slow version
#print STDERR "Was $linkurl\n";
return ("",0) unless $linkurl =~ /[.\/]/; # Ignore if it is not a website at all
#$linkurl = "" unless $linkurl =~ /[.\/]/; # Ignore if it is not a website at all
$linkurl =~ s/\s+//g; # Remove any whitespace
$linkurl =~ s/\\/\//g; # Change \ to / as many browsers do this
#print STDERR "Is $linkurl\n";
return ("",0) if $linkurl =~ /\@/ && $linkurl !~ /\//; # Ignore emails
#$linkurl = "" if $linkurl =~ /\@/ && $linkurl !~ /\//; # Ignore emails
$linkurl =~ s/[,.]+$//; # Remove trailing dots, but also commas while at it
$linkurl =~ s/^\[\d*\]//; # Remove leading [numbers]
$linkurl =~ s/^blocked[:\/]+//i; # Remove "blocked::" labels
$linkurl =~ s/^outbind:\/\/\d+\//http:\/\//i; # Remove "outbind://22/" type labels
$linkurl = $DisarmBaseURL . '/' . $linkurl
if $linkurl ne "" && $DisarmBaseURL ne "" &&
$linkurl !~ /^(https?|ftp|mailto):/i;
$linkurl =~ s/^(https?|ftp)[:;]\/\///i;
return ("",0) if $linkurl =~ /^ma[il]+to[:;]/i;
#$linkurl = "" if $linkurl =~ /^ma[il]+to[:;]/i;
$linkurl =~ s/[?\/].*$//; # Only compare up to the first '/' or '?'
$linkurl =~ s/(\<\/?(br|p|ul)\>)*$//ig; # Remove trailing br, p, ul tags
return ("",0) if $linkurl =~ /^file:/i; # Ignore file: URLs completely
#$linkurl = "" if $linkurl =~ /^file:/i; # Ignore file: URLs completely
return ("",0) if $linkurl =~ /^#/; # Ignore internal links completely
#$linkurl = "" if $linkurl =~ /^#/; # Ignore internal links completely
$linkurl =~ s/\/$//; # LinkURL is trimmed -- note
$linkurl =~ s/:80$//; # Port 80 is the default anyway
$alarm = 1 if $linkurl =~ s/[\x00-\x1f[:^ascii:]]/_BAD_/g; # /\&\#/;
$linkurl = 'JavaScript' if $linkurl =~ /^javascript:/i;
($linkurl, $alarm);
}
# Return 1 if the hostname in $linkurl is in the safe sites file.
# Return 0 otherwise.
sub InPhishingWhitelist {
my($linkurl) = @_;
# Quick lookup
return 1 if $MailScanner::Config::PhishingWhitelist{$linkurl};
# Trim host. off the front of the hostname
while ($linkurl ne "" && $linkurl =~ s/^[^.]+\.//) {
# And replace it with *. then look it up
#print STDERR "Looking up *.$linkurl\n";
return 1 if $MailScanner::Config::PhishingWhitelist{'*.' . $linkurl};
}
return 0;
}
# Convert 1 MIME entity from html to text using HTML::Parser.
sub HTMLEntityToText {
my($this, $entity) = @_;
my($htmlname, $textname, $textfh, $htmlparser);
# Replace the MIME Content-Type
$entity->head->mime_attr('Content-type' => 'text/plain');
# Replace the filename with a new one
$htmlname = $entity->bodyhandle->path();
$textname = $htmlname;
$textname =~ s/\..?html?$//i; # Remove .htm .html .shtml
$textname .= '.txt'; # This should always pass the filename checks
$entity->bodyhandle->path($textname);
# Create the new file with the plain text in it
$textfh = new FileHandle;
unless ($textfh->open(">$textname")) {
MailScanner::Log::WarnLog('Could not create plain text file %s', $textname);
return;
}
$htmlparser = HTML::TokeParser::MailScanner->new($htmlname);
# Turn links into text containing the URL
$htmlparser->{textify}{a} = 'href';
$htmlparser->{textify}{img} = 'src';
my $inscript = 0;
my $instyle = 0;
while (my $token = $htmlparser->get_token()) {
next if $token->[0] eq 'C';
# Don't output the contents of style or script sections
if ($token->[1] =~ /style/i) {
$instyle = 1 if $token->[0] eq 'S';
$instyle = 0 if $token->[0] eq 'E';
next if $instyle;
}
if ($token->[1] =~ /script/i) {
$inscript = 1 if $token->[0] eq 'S';
$inscript = 0 if $token->[0] eq 'E';
next if $inscript;
}
my $text = $htmlparser->get_trimmed_text();
print $textfh $text . "\n" if $text;
}
$textfh->close();
}
#
# This is an improvement to the default HTML-Parser routine for getting
# the text out of an HTML message. The only difference to their one is
# that I join the array of items together with spaces rather than "".
#
package HTML::TokeParser::MailScanner;
use HTML::Entities qw(decode_entities);
use vars qw(@ISA);
@ISA = qw(HTML::TokeParser);
sub get_text
{
my $self = shift;
my $endat = shift;
my @text;
while (my $token = $self->get_token) {
my $type = $token->[0];
if ($type eq "T") {
my $text = $token->[1];
decode_entities($text) unless $token->[2];
push(@text, $text);
} elsif ($type =~ /^[SE]$/) {
my $tag = $token->[1];
if ($type eq "S") {
if (exists $self->{textify}{$tag}) {
my $alt = $self->{textify}{$tag};
my $text;
if (ref($alt)) {
$text = &$alt(@$token);
} else {
$text = $token->[2]{$alt || "alt"};
$text = "[\U$tag]" unless defined $text;
}
push(@text, $text);
next;
}
} else {
$tag = "/$tag";
}
if (!defined($endat) || $endat eq $tag) {
$self->unget_token($token);
last;
}
}
}
# JKF join("", @text);
join(" ", @text);
}
# And switch back to the original package we were in
package MailScanner::Message;
#
# This is an improvement to the default MIME character set decoding that
# is done on attachment filenames. It decodes all the character sets it
# knows about, just as before. But instead of warning about character sets
# it doesn't know about (and removing characters in them), it strips
# out all the 8-bit characters (rare) and leaves the 7-bit ones (common).
#
sub WordDecoderKeep7Bit {
local $_ = shift;
# JKF 19/8/05 Allow characters with the top bit set.
# JKF 19/8/05 Still blocks 16-bit characters though, as it should.
#tr/\x00-\x7F/#/c;
tr/\x00-\xFF/#/c;
$_;
}
#
# Create a subclass of MIME::Parser:FileInto so that I can over-ride
# the "evil filename" code with a slightly better one that detects
# filenames made up solely of whitespace, which breaks the Perl open().
# I have also improved exorcise_filename to detect and remove any leading
# or trailing whitespace, which should make life a lot easier for the
# virus scanner output parsers.
#
# For the original version see .../MIME/Parser/Filer.pm
#package MIME::Parser::FileInto::MailScanner;
#
#use vars qw(@ISA);
#@ISA = qw(MIME::Parser::FileInto);
#
## A filename is evil unless it only contains any of the following:
## \%\(\)\+\,\-\.0-9\=A-Z_a-z\x80-\xFF
## To get the correct pattern match string, do this:
## print '\x00-\x1F\x7F' . quotemeta(' !"£$&') . quotemeta("'") .
## quotemeta('*/:/<>?@[\]^`{|}~') . "\n";
## print ' ' . quotemeta('%()+,-.') . '0-9' . quotemeta('=') .
## 'A-Z' . quotemeta('_') . 'a-z' . quotemeta('{}') . '\x80-\xFF' . "\n";
##
#sub evil_filename {
# my ($self, $name) = @_;
#
# #$self->debug("is this evil? '$name'");
#
# #print STDERR "Testing \"$name\" to see if it is evil\n";
# return 1 if (!defined($name) or ($name eq '')); ### empty
# return 1 if ($name =~ m{(^\s)|(\s+\Z)}); ### leading/trailing whitespace
# return 1 if ($name =~ m{^\.+\Z}); ### dots
# return 1 if ($name =~ tr{ \%\(\)\+\,\-\.0-9\=A-Z_a-z\{\}\x80-\xFF}{}c);
# return 1 if ($self->{MPF_MaxName} and
# (length($name) > $self->{MPF_MaxName}));
#
# #print STDERR "It is okay\n";
# #$self->debug("it's ok");
# 0;
#}
#
#sub exorcise_filename {
# my ($self, $fname) = @_;
#
# ### Isolate to last path element:
# my $last = $fname; $last =~ s{^.*[/\\\[\]:]}{};
# if ($last and !$self->evil_filename($last)) {
# #$self->debug("looks like I can use the last path element");
# return $last;
# }
#
# # Try removing leading whitespace, trailing whitespace and all
# # dangerous characters to start with.
# $last =~ s/^\s+//;
# $last =~ s/\s+\Z//;
# $last =~ tr/ \%\(\)\+\,\-\.0-9\=A-Z_a-z\{\}\x80-\xFF//cd;
# return $last unless $self->evil_filename($last);
#
# ### Break last element into root and extension, and truncate:
# my ($root, $ext) = (($last =~ /^(.*)\.([^\.]+)\Z/)
# ? ($1, $2)
# : ($last, ''));
# # JKF Delete leading and trailing whitespace
# $root =~ s/^\s+//;
# $ext =~ s/\s+$//;
# $root = substr($root, 0, ($self->{MPF_TrimRoot} || 14));
# $ext = substr($ext, 0, ($self->{MPF_TrimExt} || 3));
# $ext =~ /^\w+$/ or $ext = "dat";
# my $trunc = $root . ($ext ? ".$ext" : '');
# if (!$self->evil_filename($trunc)) {
# #$self->debug("looks like I can use the truncated last path element");
# return $trunc;
# }
#
# ### Hope that works:
# undef;
#}
#
# Over-ride a function in MIME::Entity that gets called every time a MIME
# part is added to a message. The new version bails out if there were too
# many parts in the message. The limit will be read from the config.
# It just sets the entity to undef and relies on the supporting code to
# actually generate the error.
#
package MIME::Entity;
use vars qw(@ISA $EntityPartCounter $EntityPartCounterMax);
@ISA = qw(Mail::Internet);
# Reset the counter and the limit
sub ResetMailScannerCounter {
my($number) = @_;
$EntityPartCounter = 0;
$EntityPartCounterMax = $number;
}
# Read the Counter
sub MailScannerCounter {
return $EntityPartCounter || 0;
}
# Over-rise their add_part function with my own with counting added
sub add_part {
my ($self, $part, $index) = @_;
defined($index) or $index = -1;
# Incrememt the part counter so I can detect messages with too many parts
$EntityPartCounter++;
#print STDERR "Added a part. Counter = $EntityPartCounter, Max = " .
# $EntityPartCounterMax\n";
return undef
if $EntityPartCounterMax>0 && $EntityPartCounter > $EntityPartCounterMax;
### Make $index count from the end if negative:
$index = $#{$self->{ME_Parts}} + 2 + $index if ($index < 0);
splice(@{$self->{ME_Parts}}, $index, 0, $part);
$part;
}
#
# Over-ride a function in Mail::Header that parses the block of headers
# at the top of each MIME section. My improvement allows the first line
# of the header block to be missing, which breaks the original parser
# though the filename is still there.
#
package Mail::Header;
sub extract
{
my $me = shift;
my $arr = shift;
my $line;
$me->empty;
# JKF Make this more robust by allowing first line of header to be missing
shift @{$arr} while scalar(@{$arr}) &&
$arr->[0] =~ /\A[ \t]+/o &&
$arr->[1] =~ /\A$FIELD_NAME/o;
# JKF End mod here
while(scalar(@{$arr}) && $arr->[0] =~ /\A($FIELD_NAME|From )/o)
{
my $tag = $1;
$line = shift @{$arr};
$line .= shift @{$arr}
while(scalar(@{$arr}) && $arr->[0] =~ /\A[ \t]+/o);
($tag,$line) = _fmt_line($me,$tag,$line);
_insert($me,$tag,$line,-1)
if defined $line;
}
shift @{$arr}
if(scalar(@{$arr}) && $arr->[0] =~ /\A\s*\Z/o);
$me;
}
##
## Over-ride the MIME boundary extracting code so that we fail to parse
## messages with an empty MIME boundary. Best I can do for now.
##
#
#package MIME::Parser::Reader;
#
#sub add_boundary {
# my ($self, $bound) = @_;
# unshift @{$self->{Bounds}}, $bound; ### now at index 0
# # JKF Fix problem with the Britney virus
# $bound = "" if $bound eq '""';
# # JKF End
# $self->{BH}{"--$bound"} = "DELIM $bound";
# $self->{BH}{"--$bound--"} = "CLOSE $bound";
# $self;
#}
#
# Over-ride the hunt-for-uuencoded file code as it now needs to hunt for
# binhex-encoded text as well.
#
#package MIME::Parser;
#
##------------------------------
##
## hunt_for_uuencode ENCODED, ENTITY
##
## I<Instance method.>
## Try to detect and dispatch embedded uuencode as a fake multipart message.
## Returns new entity or undef.
##
#sub hunt_for_uuencode {
# my ($self, $ENCODED, $ent) = @_;
# my ($good, $jkfis);
# local $_;
# $self->debug("sniffing around for UUENCODE");
#
# ### Heuristic:
# $ENCODED->seek(0,0);
# while (defined($_ = $ENCODED->getline)) {
# if ($good = /^begin [0-7]{3}/) {
# $jkfis = 'uu';
# last;
# }
# if ($good = /^\(This file must be converted with/i) {
# $jkfis = 'binhex';
# last;
# }
# }
# $good or do { $self->debug("no one made the cut"); return 0 };
#
# ### New entity:
# my $top_ent = $ent->dup; ### no data yet
# $top_ent->make_multipart;
# my @parts;
#
# ### Made the first cut; on to the real stuff:
# $ENCODED->seek(0,0);
# my $decoder = MIME::Decoder->new(($jkfis eq 'uu')?'x-uuencode'
# :'binhex');
# $self->whine("Found a $jkfis attachment");
# my $pre;
# while (1) {
# my @bin_data;
#
# ### Try next part:
# my $out = IO::ScalarArray->new(\@bin_data);
# eval { $decoder->decode($ENCODED, $out) }; last if $@;
# my $preamble = $decoder->last_preamble;
# my $filename = $decoder->last_filename;
# my $mode = $decoder->last_mode;
#
# ### Get probable type:
# my $type = 'application/octet-stream';
# my ($ext) = $filename =~ /\.(\w+)\Z/; $ext = lc($ext || '');
# if ($ext =~ /^(gif|jpe?g|xbm|xpm|png)\Z/) { $type = "image/$1" }
#
# ### If we got our first preamble, create the text portion:
# if (@$preamble and
# (grep /\S/, @$preamble) and
# !@parts) {
# my $txt_ent = $self->interface('ENTITY_CLASS')->new;
#
# MIME::Entity->build(Type => "text/plain",
# Data => "");
# $txt_ent->bodyhandle($self->new_body_for($txt_ent->head));
# my $io = $txt_ent->bodyhandle->open("w");
# $io->print(@$preamble);
# $io->close;
# push @parts, $txt_ent;
# }
#
# ### Create the attachment:
# ### We use the x-unix-mode convention from "dtmail 1.2.1 SunOS 5.6".
# if (1) {
# my $bin_ent = MIME::Entity->build(Type=>$type,
# Filename=>$filename,
# Data=>"");
# $bin_ent->head->mime_attr('Content-type.x-unix-mode' => "0$mode");
# $bin_ent->bodyhandle($self->new_body_for($bin_ent->head));
# $bin_ent->bodyhandle->binmode(1);
# my $io = $bin_ent->bodyhandle->open("w");
# $io->print(@bin_data);
# $io->close;
# push @parts, $bin_ent;
# }
# }
#
# ### Did we get anything?
# @parts or return undef;
#
# ### Set the parts and a nice preamble:
# $top_ent->parts(\@parts);
# $top_ent->preamble
# (["The following is a multipart MIME message which was extracted\n",
# "from a $jkfis-encoded message.\n"]);
# $top_ent;
#}
#
# Overload the MIME quoted-printable decoder.
# This version will make lines that end in \n now end in \r\n.
# This hopefully fixes problems with PDF files as they are now extracted
# correctly.
#
#package MIME::QuotedPrint;
#
#sub decode_qp ($)
#{
# my $res = shift;
# $res =~ s/[ \t]+?(\r?\n)/$1/g; # rule #3 (trailing space must be deleted)
# $res =~ s/=\r?\n//g; # rule #5 (soft line breaks)
# $res =~ s/([^\r])\n\Z/$1\r\n/; # JKF rule to replace trailing \n with \r\n
# $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
# $res;
#}
1;
syntax highlighted by Code2HTML, v. 0.9.1