#!/usr/pkg/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;

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 $parser = MIME::Parser->new();

$parser->output_to_core();

my $entity = $parser->parse_data($input); 

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

  }
  if ($line =~ m/^content-type:/i) {
    $line = "Content-Type: TEXT/PLAIN; format=flowed; charset=US-ASCII";
  }
  # The decode above does not do underline-to-space translation:
  $line =~ tr/_/ /;
  $transheaders .= $line . "\n";
}
print $transheaders . "\n";

foreach $file ($parser->filer->purgeable) {
    # Strip trailing spaces from filenames:
    $file =~ /(\S*)\s*$/;
    $file = $1;
    # We have found a plaintext part. Include it in the new body:
    open PART, $file;
    while (<PART>) {
		if (!/^Version:\s+[0-9]+/) {
        	print;
		}
    }
    close PART;
    # Build list of files included in the new body. We will delete
    # these files further down.
    unshift @purgeables, $file;
}
print "\n";

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