Handling MIME e-mail messages in GNATS

#!/usr/bin/perl
#
# parsemime.pl -- Yngve Svendsen, May 2001
#
# Script to decode MIME-encoded mail messages. Fully decodes header
# fields according to RFC2047. Merges multi-line header fields into
# single lines. Decodes the message body, saving binary parts to disk.
# Outputs a new message body, consisting of the plaintext message parts
# and references detailing the location of the saved stripped-out
# non-plaintext parts.

use MIME::Parser;
use File::Basename;

undef $/; # We want to treat everything read from STDIN as one line
$input = <>;
$/ = "\n";
($headers, $body) = split (/\n\n/, $input, 2);

# Split MIME-multipart messages and store the parts in subdirectories
# under the directory indicated by $output_path. Depending on which
# mail system your site uses, the directory specified by $output_path might
# have to have special permissions. If you have qmail, the dir should
# be owned by the user 'alias'. Sendmail should be content with 'root'
# as owner.
my $output_path = '/path/to/archive/directory';
my ($parsed) = (basename($0))[0];
my $parser = MIME::Parser->new();

# Permission mask for output files.
# These permissions are very lax. Replace with what is appropriate
# for your system.
$oldumask = umask 0002;

$parser->output_under($output_path);
$parser->output_prefix($parsed);
$parser->output_to_core();

my $entity = $parser->parse_data($input); 
# Permissions for the directory containing the output files.
# These permissions are very lax. Replace with what is appropriate
# for your system.
chmod 0775, ($parser->output_dir);

# Process the headers:
$procheaders = $headers;
$procheaders =~ s/\?=\s\n/\?=\n/g; # Lines ending with an encoded-word
                               # have an extra space at the end. Remove it.
$procheaders =~ s/\n[ |\t]//g; # Merge multi-line headers into a single line.
$transheaders = '';

foreach $line (split(/\n/, $procheaders))
{
	while ($line =~ m/=\?[^?]+\?(.)\?([^?]*)\?=/)
	{
	  $encoding   = $1;
	  $txt        = $2;
	  $str_before = $`;
	  $str_after  = $';

# Base64
    if ($encoding =~ /b/i)
    {
      require MIME::Base64;
      MIME::Base64->import(decode_base64);
      $txt = decode_base64($txt);
    }

# QP
    elsif ($encoding =~ /q/i)
    {
      require MIME::QuotedPrint;
      MIME::QuotedPrint->import(decode_qp);
      $txt = decode_qp($txt);
    }

    $line = $str_before . $txt . $str_after;
  }
  # The decode above does not do underline-to-space translation:
  $line =~ tr/_/ /;
  $transheaders .= $line . "\n";
}

# Reconstruct the message, made from headers and the MIME text parts
# we saved earlier. Add references in the message body to the non-text
# parts that have been stripped out and stored. The purgeable method
# returns the full path of the files constructed from the different
# message parts.
print $transheaders . "\n";

foreach $file ($parser->filer->purgeable) {
    # Strip trailing spaces from filenames:
    $file =~ /(\S*)\s*$/;
    $file = $1;
    if ($file =~ /\.txt\s*$/) {
        # We have found a plaintext part. Include it in the new body:
        open PART, $file;
        while (<PART>) {
            print;
        }
        close PART;
        # Build list of files included in the new body. We will delete
        # these files further down.
        unshift @purgeables, $file;
    }
    else {
        # We have found a non-plaintext part. Add a reference to it in the
        # new body:
        print "\n\n** Attachment decoded and saved to \n** $file\n\n";
    }
}

# Make the list we built the new list of purgeable files:
$parser->filer->purgeable(\@purgeables);
# Delete them:
$parser->filer->purge;

umask $oldumask;