#!/usr/local/bin/perl -w

#########################################################################
# mime_rename.dangerous_windows_exts.pl                                 #
#########################################################################
# Used to rename attachments with "dangerous" filenames with respect    #
# to MS Windows virii.  Used in conjunction with procmail.              #
#                                                                       #
# Built 03/25/2003 by Lester Hightower <hightowe@10east.com>            #
# Based on info from this URL: http://perlmonks.thepen.com/53404.html   #
#########################################################################

use strict;
use MIME::Parser;
use MIME::Entity;

my $VERSION = 1.1;

my @dangerous_exts=qw(pif com dll cmd hta reg scr exe bat vbs);

$|++;

my $envelope = <STDIN>;

my $parser = MIME::Parser->new;
$parser->output_to_core(1);
$parser->tmp_to_core(1);

my $ent = eval { $parser->parse(\*STDIN) }; die "$@" if $@;

&ScrubMultiPart($ent);

print $envelope;
$ent->print;

exit;

#################
## Subroutines ##
#################
sub ScrubMultiPart {
  my $ent = shift @_;
  #warn "I am in multi part\n";
  if ($ent->is_multipart()) {
    my $parts_count=$ent->parts;
    foreach my $i_part (0 .. ($ent->parts - 1)) {
      #warn "Calling ScrubMultiPart($i_part)\n";
      &ScrubMultiPart($ent->parts($i_part));
    }
    $ent->make_singlepart;
    $ent->sync_headers(Length => 'COMPUTE', Nonstandard => 'ERASE');
  } else {
    &ScrubSinglePart($ent);
  }
  return $ent;
}

sub ScrubSinglePart {
  my $ent = shift @_;
  #warn "I am in single part\n";
  my $head=$ent->head;
  my $conttype_name=$head->mime_attr("content-type.name");
  if (defined($conttype_name)) {
    my $dangerous_exts_regex='\.' . join('$|\.', @dangerous_exts) . '$';
    if ($conttype_name =~ m/$dangerous_exts_regex/i) {
      #warn "Filename is dangerous: $conttype_name\n";
      my $new_filename=$conttype_name . ".POSSIBLE_VIRUS";
      $head->mime_attr("content-type.name" => $new_filename);
    }
  }
  # Check to see if there is a Content-disposition, and if so, delete it
  my @cont_disp_hrds=$head->get("content-disposition");
  if ($head->count("content-disposition") > 0) {
    $head->delete("content-disposition");
  }
  return $ent;
}


###############
## Begin POD ##
###############

=head1 NAME

mime_rename.dangerous_windows_exts.pl

=head1 README

Used to rename attachments with "dangerous" filenames with respect to MS
Windows virii.  Intended to be used in conjunction with procmail.

=head1 DESCRIPTION

Below is a snippet from my .procmailrc to illistrate the use of this script.
Note that perldoc wraps some of the lines when it should not, so if you
intend to copy/paste please open the script itself and copy/paste from
there, not from a "perldoc" or "man" view.

#############################################################
:0
* ^Content-Type: (multipart/alternative|multipart/mixed)
{
  # Throw a copy into filtered.multipart_alternative.
  # (Paranoia, you can kill this entire section)
  :0c
  {
    # OK, before we just blindly file this
    # in filtered.multipart_alternative, let's
    # give spamassassin a chance to /dev/null it.
    :0fw
    | /usr/bin/spamassassin -P

    :0
    * ^X-Spam-Status: Yes
    * !^From[ :].*@10east.com
    /dev/null
    # END: spamassassin

    :0
    /home/hightowe/mail/filtered.multipart_alternative
  }

  # Rename possibly dangerous attachments (.exe/.vbs/.pif/etc.)
  :0fw
  | /home/hightowe/bin/mime_rename.dangerous_windows_exts.pl
}
#############################################################

=head1 AUTHORSHIP

Lester Hightower <hightowe@10east.com>

=head1 CHANGE LOG

Mar-25-2003: Originally created by Lester Hightower

=head1 PREREQUISITES

This script requires the C<strict> module.  It also requires
C<MIME::Tools 5.411>.

=pod OSNAMES

any

=pod SCRIPT CATEGORIES

Mail
Mail/Converters
Mail/Filters

=cut