#
#   MailScanner - SMTP E-Mail Virus Scanner
#   Copyright (C) 2002  Julian Field
#
#   $Id: Message.pm,v 1.126.2.112 2004/03/30 15:29:48 jkf Exp $
#
#   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 MIME::Parser;
use MIME::Decoder::UU;
use MIME::WordDecoder;
use POSIX qw(setsid);
use HTML::TokeParser;
use HTML::Parser;
use Archive::Zip qw( :ERROR_CODES );
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 MailScanner::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: 1.126.2.112 $, 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)
# $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
# %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)
#

# Constructor.
# Takes id.
# This isn't specific to the MTA at all, so is all done here.
sub new {
  my $type = shift;
  my($id, $queuedirname) = @_;
  my $this = {};
  my ($queue, $workarea, $mta, $hpath, $dpath, $addr, $user, $domain);
  my ($archiveplaces);
  my $hfile = new FileHandle;

  #print STDERR "Creating message $id\n";

  $this->{id} = $id;
  @{$this->{archiveplaces}} = (); # Hope this syntax is right!

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

  # Reset the infection counters to 0
  $this->{virusinfected} = 0;
  $this->{nameinfected}  = 0;
  $this->{otherinfected} = 0;
  $this->{stillwarn}     = 0;

  # Work out where to archive/copy this message.
  # Could do all the archiving in a different separate place.
  $archiveplaces = MailScanner::Config::Value('archivemail', $this);
  @{$this->{archiveplaces}} = ((defined $archiveplaces)?split(" ", $archiveplaces):());

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

  my $spamheader    = "";
  my $rblspamheader = "";
  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');

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

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

  ## If it's a blacklisted address, don't bother doing any checks at all
  #if (MailScanner::Config::Value('spamblacklist', $this)) {
  #  $this->{isspam} = 1;
  #  $this->{spamreport} = 'spam (blacklisted)';
  #  MailScanner::Log::InfoLog("Message %s from %s (%s) " .
  #                            " is spam (blacklisted)",
  #                            $this->{id}, $this->{clientip},
  #                            $this->{from});
  #  return 1;
  #}

  # Work out if they always want the SA header
  $includesaheader = MailScanner::Config::Value('includespamheader', $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;
  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;
  }

  # If it's a blacklisted address, don't bother doing any checks at all
  if (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;
  }

  if (!$iswhitelisted) {
    # Not whitelisted, so do the RBL checks
    #$rblspamheader     = MailScanner::RBLs::Checks($this);
    ($rblcounter, $rblspamheader) = MailScanner::RBLs::Checks($this);
    $RBLsaysspam       = 1 if $rblcounter;
    #$RBLsaysspam       = 1 if $rblspamheader;
    # Add leading "spam, " if RBL says it is spam. This will be at the
    # front of the spam report.
    $rblspamheader     = $LocalSpamText . ', ' . $rblspamheader if $rblcounter;
    $this->{isspam}    = 1 if $rblcounter;
    $this->{isrblspam} = 1 if $rblcounter;
    $this->{ishigh}    = 1 if $rblcounter >= MailScanner::Config::Value(
                                             'highrbls', $this);
    #print STDERR "RBL report is \"$rblspamheader\"\n";
    #print STDERR "RBLCounter = $rblcounter\n";
    #print STDERR "HighRBLs   = " .
    #             MailScanner::Config::Value('highrbls', $this) . "\n";
  }

  # Don't do the SA checks if they have said no.
  unless (MailScanner::Config::Value('usespamassassin', $this)) {
    $this->{spamwhitelisted} = $iswhitelisted;
    $this->{spamreport}      = $rblspamheader;
    MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s",
                              $this->{id}, $this->{clientip},
                              $this->{from}, $todomain, $rblspamheader)
      if $RBLsaysspam && $LogSpam;
    return $RBLsaysspam;
  }

  # If it's spam and they dont want to check SA as well
  if ($this->{isspam} &&
      !MailScanner::Config::Value('checksaifonspamlist', $this)) {
    $this->{spamwhitelisted} = $iswhitelisted;
    $this->{spamreport}      = $rblspamheader;
    MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s",
                              $this->{id}, $this->{clientip},
                              $this->{from}, $todomain, $rblspamheader)
      if $RBLsaysspam && $LogSpam;
    return $RBLsaysspam;
  }

  # They must want the SA checks doing.

  my $SAsaysspam = 0;
  my $SAHighScoring = 0;
  my $saheader = "";
  my $sascore  = 0;
  my $salongreport = "";
  ($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";
    $spamheader = $rblspamheader;
    # 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";
      $spamheader = $LocalSpamText unless $spamheader;
      $spamheader .= ', ' if $spamheader && $saheader;
      $spamheader .= $saheader;
      $this->{ishigh} = 1 if $SAHighScoring;
    }
  } else {
    # It's not spam...
    #print STDERR "It's not spam\n";
    #print STDERR "SAHeader = $saheader\n";
    $spamheader = MailScanner::Config::LanguageValue($this, 'notspam');
    if ($iswhitelisted) {
      $spamheader .= ' (' .
                    MailScanner::Config::LanguageValue($this, 'whitelisted') .
                    ')';
    }
    # so RBL report must be blank as you can't force inclusion of that.
    # So just include SA report.
    $spamheader .= ", $saheader";
  }

  # Now just reflow and log the results
  if ($spamheader ne "") {
    $spamheader = $this->ReflowHeader(
                  MailScanner::Config::Value('spamheader',$this), $spamheader);
    $this->{spamreport} = $spamheader;
  }

  # Do the spam logging here so we can log high-scoring spam too
  if (($LogSpam && $this->{isspam}) || ($LogNonSpam && !$this->{isspam})) {
    my $ReportText = $spamheader;
    $ReportText =~ s/\s+/ /sg;
    MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s",
                              $this->{id}, $this->{clientip},
                              $this->{from}, $todomain, $ReportText);
  }

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

  # Get a space-separated list of all the actions
  if ($HamSpam eq 'nonspam') {
    $actions = lc(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}) {
      $actions = lc(MailScanner::Config::Value('highscorespamactions', $this));
    } else {
      $actions = lc(MailScanner::Config::Value('spamactions', $this));
    }
  }
  $actions =~ tr/,//d; # Remove all commas in case they put any in
  @actions = split(" ", $actions);

  # The default action if they haven't specified anything is to
  # deliver spam like normal mail.
  return unless @actions;

  #print STDERR "Message: HandleHamSpam has actions " . join(',',@actions) .
  #             "\n";

  foreach $action (@actions) {
    # 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;
    }
  }

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

    # Delete action is over-ridden as we are sending it somewhere
    delete $actions{'delete'};

    MailScanner::Log::InfoLog("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'};

    # Message still exists, so it will be delivered to its new recipients
  } else {
    #
    # Message is not going to be delivered anywhere
    #

    MailScanner::Log::InfoLog("Spam Actions: message %s actions are %s",
                              $this->{id}, join(',', keys %actions))
      if $HamSpam eq 'spam' && MailScanner::Config::Value('logspam');

    # 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::InfoLog("Will not bounce high-scoring spam")
      } else {
        $this->HandleSpamBounce()
          if MailScanner::Config::Value('enablespambounce', $this);
      }
    }
  }

  # AuthBounce a message back to the authenticateduser if they want that
  if ($actions{'authbounce'}) {
    if ($HamSpam eq 'nonspam') {
      MailScanner::Log::WarnLog("Does not make sense to authbounce non-spam");
    } else {
      #MailScanner::Log::WarnLog('The "bounce" Spam Action no longer exists');
      #if ($this->{ishigh}) {
        #MailScanner::Log::InfoLog("Will not authbounce high-scoring spam")
      #} else {
  		$this->HandleSpamBounce(1,MailScanner::Config::Value('alwaysauthbounce', $this));
          #if MailScanner::Config::Value('enablespamauthbounce', $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();
    $spamdir = $dir2 . '/' . $HamSpam;
    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};
    $this->{store}->CopyEntireMessage($this, $spamdir, $this->{id},
                                      $uid, $gid, $changeowner);
    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
# If isAuthBounce is true, bounce this message to the authenticateduser instead
# of "from", 
# If alwaysBounce is true, bounce the message even if authenticateduser is empty
# using from field
sub HandleSpamBounce {
  my $this = shift;
	my $isAuthBounce=shift;
	my $alwaysBounce=shift;

  my($from,$to,$subject,$date,$spamreport,$hostname);
  my($emailmsg, $line, $messagefh, $filename, $localpostmaster, $id);

	if( $isAuthBounce ) {
  	$from = $this->{authenticateduser};
		if( $from eq "" || $from eq "<>" ) {
			if( $alwaysBounce ) {
  			$from = $this->{from};
			}
			else {
				return;
			}
		}
	}
	else {
  	$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);
  $hostname = MailScanner::Config::Value('hostname', $this);
  $subject = $this->{subject};
  $date = scalar localtime;
  $spamreport = $this->{spamreport};

  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::InfoLog("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::InfoLog("Spam Actions: (SpamAssassin) Bounce to %s",
                              $from)
      if MailScanner::Config::Value('logspam');
  }
  if ($filename eq "") {
    $filename = MailScanner::Config::Value('senderbothspamreport', $this);
    MailScanner::Log::InfoLog("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...
    /(.*)/;
    $line = eval "\"$1\"";
    $emailmsg .= $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, '<>')
    or MailScanner::Log::WarnLog("Could not send sender spam bounce, %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);

  $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);
  $hostname = MailScanner::Config::Value('hostname', $this);
  $subject = $this->{subject};
  $date = 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($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::InfoLog("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 .= $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", $!);
}



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

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

  # 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})
  $global::MS->{mta}->AddMultipleHeader($this, 'spamheader',
                                        $this->{spamreport}, ', ')
    if $this->{isspam} ||
       MailScanner::Config::Value('includespamheader', $this);

  # 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);
  $starcount = int($this->{sascore}) + 0;
  $starcount = 0 if $this->{spamwhitelisted}; # 0 stars if white-listed
  $scoretext = $starcount;
  $minstars = MailScanner::Config::Value('minstars', $this);
  $starcount = $minstars if $this->{isrblspam} && $minstars &&
                            $starcount<$minstars;
  if (MailScanner::Config::Value('spamstars', $this) =~ /1/ && $starcount>0) {
    if (MailScanner::Config::Value('spamscorenotstars', $this)) {
      $stars = int($starcount);
    } else {
      $starcount = 60 if $starcount>60;
      $stars = MailScanner::Config::Value('spamstarscharacter') x $starcount;
    }
    $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 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/;
  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 it is high-scoring spam, then add a different bit of text
  $spamtag = MailScanner::Config::Value('highspamsubjecttext', $this);
  $spamtag =~ s/_SCORE_/$scoretext/;
  if ($this->{isspam} && $this->{ishigh} &&
      MailScanner::Config::Value('highspamprependsubject',$this) &&
      !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) {
    $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' ');
  }


  # 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) !~ /0/) {
    # 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);
  }
}

# Explode a message into its MIME structure and attachments.
# Pass in the workarea where it should go.
sub Explode {
  my $this = shift;

  my($pipe, $pid, $workarea);

  return if $this->{deleted};

  # 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::MailScanner->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
  
  # 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);
  my $entity = eval { $parser->parse($pipe) };
  #print STDERR "Done the parse. Counter = " .
  #      MIME::Entity::MailScannerCounter() . " and max = $maxparts\n";
  #$entity = undef
  #  if $maxparts>0 && MIME::Entity::MailScannerCounter()>=$maxparts;
  if (!$entity) {
    #print STDERR "Found an error!\n";
    $pipe->close();
    waitpid $pid, 0;
    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 in %s", $this->{id});
    $this->{entity} = $entity; # In case it failed due to too many attachments
    $this->{toomanyattach} = 1;
    $this->{otherinfected} = 1;
    return;
  }

  #close($pipe);
  # Closing the pipe this way will reap the child, apparently!
  $pipe->close;
  kill 9, $pid; # Make sure we are reaping a dead'un
  # jjh 2004-03-12 don't waitpid here.
  #waitpid $pid, 0;
  $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.
  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 files are " . join(',',@tneffiles) . "\n";

    foreach $tneffile (@tneffiles) {
      my $result;
      MailScanner::Log::InfoLog("Expanding TNEF archive at %s/%s",
                                $explodeinto, $tneffile);
      $result = MailScanner::TNEF::Decoder($explodeinto, $tneffile, $this);
      unless ($result) {
        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;
  }

  # 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, $mailscannername);
  $allowpasswords = MailScanner::Config::Value('allowpasszips', $this);
  $allowpasswords = ($allowpasswords !~ /0/)?1:0;
  $couldnotreadmesg = MailScanner::Config::LanguageValue($this,
                                                         'unreadablearchive');
  $passwordedmesg = MailScanner::Config::LanguageValue($this,
                                                       'passwordedarchive');
  $mailscannername = MailScanner::Config::LanguageValue($this, 'mailscanner');
  $this->ExplodePartAndArchives($explodeinto,
                                MailScanner::Config::Value('maxzipdepth', $this),
                                $allowpasswords, $couldnotreadmesg,
                                $passwordedmesg, $mailscannername);


  # Set the owner and group on all the extracted files
  chown $workarea->{uid}, $workarea->{gid}, glob "$explodeinto/*"
    if $workarea->{changeowner};
}

# 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, $msname) = @_;

  my($dir, $file, $part, @parts, $buffer);
  my(%seenbefore, %seenbeforesize, $foundnewfiles);
  my($size, $level, $ziperror, $tarerror, $silentviruses, $noisyviruses);
  my($allziperrors, $alltarerrors, $textlevel);
  my($linenum, $foundheader, $prevline, $line, $position, $prevpos, $nextpos);

  $dir = new DirHandle;
  $file = new FileHandle;
  $level = 0; #-1;
  $textlevel = 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);

  OUTER: while(1) {
    $textlevel++;
    last if $level>$maxlevels; # && $textlevel>1;
    $foundnewfiles = 0;
    @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
      next unless $part =~ /(^msg.*txt$)|(\.(tar\.g?z|taz|tgz|tz|zip|exe)$)/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::MailScanner->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) };

            # 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 unless $file->open("$explodeinto/$part");
      #print STDERR "About to read 4 bytes\n";
      #$file->open("$explodeinto/$part") or next; # Skip if it can't be read
      unless (read($file, $buffer, 4) == 4) {
        #print STDERR "Very short file $part\n";
        $file->close;
        next;
      }
      $file->close;
      next unless $buffer eq "PK\003\004";
      #print STDERR "Found a zip file\n" ;
      #next unless $part =~ /\.(tar\.g?z|taz|tgz|tz|zip|exe)$/i;
      $foundnewfiles = 1;

      # Is it a zip file, in which case unpack the zip
      $ziperror = "";
      $ziperror = $this->UnpackZip($part, $explodeinto, $allowpasswords,
                                   $onlycheckencryption);
      # If unpacking as a zip failed, try it as a tar
      $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") {
        MailScanner::Log::WarnLog("Password-protected archive (%s) in %s",
                                  $part, $this->{id});
        $this->{allreports}{$part} .= "$msname: $passwordedmesg\n";
        $this->{alltypes}{$part} .= 'c';
        $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) {
        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;
    $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: $passwordedmesg\n";
    $this->{alltypes}{""} .= 'c';
    $this->{otherinfected}++;
  }
}

# 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 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";
    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);
    $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.
      $fh->open(">$safename") && $fh->close();
    }
  }
  return 0;
}

# Is this filename evil?
sub IsNameEvil {
  my($this, $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 (length($name) > 50);

  #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) = @_;

    ### Isolate to last path element:
    my $last = $fname; $last =~ s{^.*[/\\\[\]:]}{};
    if ($last and !$self->IsNameEvil($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->IsNameEvil($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->IsNameEvil($trunc)) {
        #$self->debug("looks like I can use the truncated last path element");
        return $trunc;
    }

    ### Hope that works:
    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);

    # 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 "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 "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->{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->{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:  $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};
    }
  }
  # 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";
}


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

  # 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, $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/;

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

  # 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 {
      if ($tnefentity) {
        $entity = $tnefentity;
      } else {
        $entity = $this->{file2entity}{"$file"};
        #print STDERR "Cleaning $file which is entity $entity\n";
        # Try to find a matching entity, may involve querying the parent
        if (!$entity) {
          $entity = $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 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;

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


# 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);
    #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';
      $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 {
      ## When replacing the whole body of message/partial messages,
      ## don't forget to fix the root mime header.
      #$entity->head->mime_attr("Content-type" => "multipart/mixed")
      #  if $entity->head->mime_attr("content-type") =~ /message\/partial/i;
      #print STDERR "In CleanEntity, replacing entire message\n";
      $parts[0] = build MIME::Entity
                        Type => 'text/plain',
                        Filename => $warningfile,
                        Disposition => 'inline',
                        Data => $Warning,
                        Encoding => 'quoted-printable',
                        Charset => $charset,
                        Top => 0;
      #print STDERR "Mime type is " . $entity->mime_type() . "\n";
      #my $sss = $entity->is_multipart();
      #print STDERR "Currently is " . $sss . "\n";
      #print STDERR "Is defined\n" if defined($sss);
      #print STDERR "Type now is " . $entity->head->mime_attr('content-type')
      #             . "\n";
  
      #print STDERR "Status is " . $entity->make_multipart() . "\n"
      $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...
  $Warning = $this->ConstructWarning($this->{entity2file}{$entity},
                                     $report, $this->{id}, $reportname);
  $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;
  $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) = @_;

  my $date = scalar localtime;
  my $textfh = new FileHandle;
  my $dir = $global::MS->{work}{dir}; # Get the working directory

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

#  # 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 .= $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
# 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);
  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);

  my $result = "";
  while (<$fh>) {
    chomp;
    s#"#\\"#g;
    s#@#\\@#g;
    # Boring untainting again...
    /(.*)/;
    $line = eval "\"$1\"";
    $result .= $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) ||
      !$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',
                          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',
                          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('inlinehtmlsig');
    foreach $line (@body) {
      $line =~ s/\<\/x?html\>/$signature$&/i;
      $io->print($line);
    }
    (($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";
    $this->DeliverUnmodifiedBody('cleanheader');
  }
}


# 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) = @_;

  return if $this->{deleted}; # This should never happen

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

  # 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})
  $global::MS->{mta}->AddMultipleHeader($this, 'spamheader',
                                        $this->{spamreport}, ', ')
    if $this->{isspam} ||
       MailScanner::Config::Value('includespamheader', $this);

  # 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);
  $starcount = int($this->{sascore}) + 0;
  $starcount = 0 if $this->{spamwhitelisted}; # 0 stars if white-listed
  $scoretext = $starcount;
  $minstars = MailScanner::Config::Value('minstars', $this);
  $starcount = $minstars if $this->{isrblspam} && $minstars &&
                            $starcount<$minstars;
  if (MailScanner::Config::Value('spamstars', $this) =~ /1/ && $starcount>0) {
    if (MailScanner::Config::Value('spamscorenotstars', $this)) {
      $stars = int($starcount);
    } else {
      $starcount = 60 if $starcount>60;
      $stars = MailScanner::Config::Value('spamstarscharacter') x $starcount;
    }
    $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 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 $subjectchanged = 0;
  my $spamtag = MailScanner::Config::Value('spamsubjecttext', $this);
  $spamtag =~ s/_SCORE_/$scoretext/;
  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 it is high-scoring spam, then add a different bit of text
  $spamtag = MailScanner::Config::Value('highspamsubjecttext', $this);
  $spamtag =~ s/_SCORE_/$scoretext/;
  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;
  }

  # 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 eq 'start' && !$subjectchanged &&
      !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $scantag)) {
    $global::MS->{mta}->PrependHeader($this, 'Subject:', $scantag, ' ');
  } elsif ($modifscan eq 'end' && !$subjectchanged &&
      !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $scantag)) {
    $global::MS->{mta}->AppendHeader($this, 'Subject:', $scantag, ' ');
  }

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

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

  # Set up the output envelope with its (possibly modified) headers
  $global::MS->{mta}->AddHeadersToQf($this, $this->{entity}->stringify_header);

  # 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})
  $global::MS->{mta}->AddMultipleHeader($this, 'spamheader',
                                        $this->{spamreport}, ', ')
    if $this->{isspam} ||
       MailScanner::Config::Value('includespamheader', $this);

  # 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);
  $starcount = int($this->{sascore}) + 0;
  $starcount = 0 if $this->{spamwhitelisted}; # 0 stars if white-listed
  $scoretext = $starcount;
  $minstars = MailScanner::Config::Value('minstars', $this);
  $starcount = $minstars if $this->{isrblspam} && $minstars &&
                            $starcount<$minstars;
  if (MailScanner::Config::Value('spamstars', $this) =~ /1/ && $starcount>0) {
    if (MailScanner::Config::Value('spamscorenotstars', $this)) {
      $stars = int($starcount);
    } else {
      $starcount = 60 if $starcount>60;
      $stars = MailScanner::Config::Value('spamstarscharacter') x $starcount;
    }
    $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};

  # 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 $subjectchanged = 0;
  my $spamtag = MailScanner::Config::Value('spamsubjecttext', $this);
  $spamtag =~ s/_SCORE_/$scoretext/;
  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 it is high-scoring spam, then add a different bit of text
  $spamtag = MailScanner::Config::Value('highspamsubjecttext', $this);
  $spamtag =~ s/_SCORE_/$scoretext/;
  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;
  }

  # 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);
  #print STDERR "I have triggered a filename trap\n" if $this->{nameinfected};
  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;
    }
  } 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;
    }
  } 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;
    }
  }

  # 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 eq 'start' && !$subjectchanged &&
      !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $scantag)) {
    $global::MS->{mta}->PrependHeader($this, 'Subject:', $scantag, ' ');
  } elsif ($modifscan eq 'end' && !$subjectchanged &&
      !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $scantag)) {
    $global::MS->{mta}->AppendHeader($this, 'Subject:', $scantag, ' ');
  }

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


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

  my(@noisyin) = split(" ",MailScanner::Config::Value('noisyviruses', $this));
  my($noisy, $noisyin, @noisy, $nregexp);

  # Get out quickly if there's nothing to do
  return unless @silentin || @noisyin;

  # Turn each silent and noisy report into a regexp
  foreach $silent (@silentin) {
    $silentin = quotemeta $silent;
    push @silent, $silentin;
  }
  foreach $noisy (@noisyin) {
    $noisyin = quotemeta $noisy;
    push @noisy, $noisyin;
  }
  # Make 2 big regexps from them all
  $regexp = '(' . join(')|(', @silent) . ')';
  $nregexp = '(' . join(')|(', @noisy) . ')';

  # Make 1 big string from all the reports
  $allreports = join('', values %{$this->{allreports}});

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

  #print STDERR "FindSilentInfection: Found it!\n" if $this->{silent};
  #print STDERR "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, @everyreport, $entitytypes, @everytype);
  my($emailmsg, $line, $messagefh, $msgname, $localpostmaster, $id);
  my($hostname);

  # 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);
  $hostname = MailScanner::Config::Value('hostname', $this);
  $subject = $this->{subject};
  $date = scalar localtime;

  my($to, %tolist);
  foreach $to (@{$this->{to}}) {
    $tolist{$to} = 1;
  }
  $to = join(', ', sort keys %tolist);

  $allreports    = $this->{allreports};
  $entityreports = $this->{entityreports};
  push @everyreport, values %$allreports;
  push @everyreport, values %$entityreports;
  my $reportword = MailScanner::Config::LanguageValue($this, "report");
  $report = join($reportword . ': ', @everyreport);
  
  $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);
  } else {
    $msgname = MailScanner::Config::Value('sendervirusreport', $this);
  }

  # 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 .= $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);

  $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";

  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 $rept = join("    $reportword: ", @everyrept);
  my $ip   = $this->{clientip};

  # 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" .
            "$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);
  $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);

  $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       => "MailScanner <$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;
  while(<$textfh>) {
    $line = chomp;
    #s#"#\\"#g; # Escape any " characters
    #s#@#\\@#g; # Escape any @ characters
    $line =~ s/([\(\)\[\]\.\?\*\+\^"'@])/\\$1/g; # Escape any regex characters
    # Untainting joy...
    $line =~ /(.*)/;
    $result = eval "\"$1\"";
    $output .= $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 = 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);
    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.
my($DisarmFormTag, $DisarmScriptTag, $DisarmCodebaseTag, $DisarmIframeTag);
sub DisarmHTML {
  my $this = shift;

  #print STDERR "Tags to convert are " . $this->{tagstoconvert} . "\n";

  # Set the disarm booleans for this message
  $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;

  $this->DisarmHTMLTree($this->{entity});
}


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

  # 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.
  $entity = $this->{entity} or return;

  # Construct the RFC822 attachment
  $mimeversion = $entity->head->get('mime-version');
  $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);
  $hostname = MailScanner::Config::Value('hostname', $this);
  $subject = $this->{subject};
  $date = scalar localtime;
  $fullspamreport = $this->{spamreport};
  $longspamreport = $this->{salongreport};
  #$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 .= $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);
  $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; # 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->DisarmHTMLEntity($entity);
    MailScanner::Log::InfoLog('Content Checks: Detected and will disarm ' .
                              'HTML message 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->DisarmHTMLTree($part);
  }

  return $counter;
}


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

# Convert 1 MIME entity from html to dis-armed HTML using HTML::Parser.
sub DisarmHTMLEntity {
  my($this, $entity) = @_;

  my($oldname, $newname, $oldfh, $outfh, $htmlparser);

  # Replace the filename with a new one
  $oldname = $entity->bodyhandle->path();
  $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;
  }

  # Set default output filehandle so we generate the new HTML
  $oldfh = select $outfh;

  # Process the old HTML file into the new one
  HTML::Parser->new(api_version => 3,
      start_h     => [\&DisarmTagCallback,    "tagname, text, attr, attrseq"],
      end_h       => [\&DisarmEndtagCallback, "tagname, text"],
      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();
}

# HTML::Parser callback function for start tags
sub DisarmTagCallback {
  my($tagname, $text, $attr, $attrseq) = @_;

  if ($tagname eq 'form' && $DisarmFormTag) {
    #print "It's a form\n";
    $text = substr $text, 1;
    print "<BR><MailScannerForm$$ " . $text;
  } elsif ($tagname eq 'input' && $DisarmFormTag) {
    #print "It's an input button\n";
    $attr->{'type'} = "reset";
    print '<' . $tagname;
    foreach (@$attrseq) {
      next if /^on/;
      print ' ' . $_ . '="' . $attr->{$_} . '"';
    }
    print '>';
  } elsif ($tagname eq 'button' && $DisarmFormTag) {
    #print "It's a button\n";
    $attr->{'type'} = "reset";
    print '<' . $tagname;
    foreach (@$attrseq) {
      next if /^on/;
      print ' ' . $_ . '="' . $attr->{$_} . '"';
    }
    print '>';
  } elsif ($tagname eq 'object' && $DisarmCodebaseTag) {
    #print "It's an object\n";
    if (exists $attr->{'codebase'}) {
      $text = substr $text, 1;
      print "<MailScannerObject$$ " . $text;
    } elsif (exists $attr->{'data'}) {
      $text = substr $text, 1;
      print "<MailScannerObject$$ " . $text;
    } else {
      print $text;
    }
  } elsif ($tagname eq 'iframe' && $DisarmIframeTag) {
    #print "It's an iframe\n";
    $text = substr $text, 1;
    print "<MailScannerIFrame$$ " . $text;
  } elsif ($tagname eq 'script' && $DisarmScriptTag) {
    #print "It's a script\n";
    $text = substr $text, 1;
    print "<MailScannerScript$$ " . $text;
  } else {
    print $text;
  }
}

# HTML::Parser callback function for end tags
sub DisarmEndtagCallback {
  my($tagname, $text) = @_;

  if ($tagname eq 'iframe' && $DisarmIframeTag) {
    print "</MailScannerIFrame$$>";
  } elsif ($tagname eq 'form' && $DisarmFormTag) {
    print "</MailScannerForm$$>";
  } elsif ($tagname eq 'script' && $DisarmScriptTag) {
    print "</MailScannerScript$$>";
  } else {
    print $text;
  }
}



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

  while (my $token = $htmlparser->get_token()) {
    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;
    tr/\x00-\x7F/#/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 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;
}

1;

