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

###########################################################################
# mime_strip.html_bodies.pl                                               #
###########################################################################
# Used to strip the "HTML-alternative" MIME attachments that some Mozilla #
# and MS Outlook users like to add to every email.  Used in conjunction   #
# with procmail.                                                          #
#                                                                         #
# Built 12/17/2002 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 $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 $@;

if ($ent->effective_type eq "multipart/alternative"
    and $ent->parts == 2
    and $ent->parts(0)->effective_type eq "text/plain"
    and $ent->parts(1)->effective_type eq "text/html") {
  
  my $newent = MIME::Entity->build(Data =>
                                   $ent->parts(0)->body_as_string .
                                   "\n\n[HTML alternate version deleted]\n");
  $ent->parts([$newent]);
  $ent->make_singlepart;
  $ent->sync_headers(Length => 'COMPUTE', Nonstandard => 'ERASE');
} elsif ($ent->effective_type eq "multipart/mixed"
    and $ent->parts(0)->effective_type eq "multipart/alternative"
    and $ent->parts(0)->parts == 2
    and $ent->parts(0)->parts(0)->effective_type eq "text/plain"
    and $ent->parts(0)->parts(1)->effective_type eq "text/html") {

    my $newent = MIME::Entity->build(Data =>
                 $ent->parts(0)->parts(0)->body_as_string);
    $ent->parts(0)->parts([$newent]);
    $ent->parts(0)->make_singlepart;
    $ent->parts(0)->sync_headers(Length => 'COMPUTE', Nonstandard => 'ERASE');
    $ent->sync_headers(Length => 'COMPUTE', Nonstandard => 'ERASE');
#
# Mozilla Mail (added 12/17/2002 by LHH)
#
} elsif ($ent->effective_type eq "multipart/alternative"
    and $ent->parts == 2
    and $ent->parts(0)->effective_type eq "text/plain"
    and $ent->parts(1)->effective_type eq "multipart/related") {
  
  my $newent = MIME::Entity->build(Data =>
                                   $ent->parts(0)->body_as_string .
                                   "\n\n[HTML alternate version deleted]\n");
  $ent->parts([$newent]);
  $ent->make_singlepart;
  $ent->sync_headers(Length => 'COMPUTE', Nonstandard => 'ERASE');
}

print $envelope;
$ent->print;

exit;

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

=head1 NAME

mime_strip.html_bodies.pl

=head1 README

Used to strip the alternative "HTML body" attachments that some Mozilla and
MS Outlook users like to add to every email.  Most often used in conjunction
with procmail.

=head1 DESCRIPTION

Below is a snippet from my .procmailrc to illustrate 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
  }

  # Strip HTML-alternative bodies
  :0fw
  | /home/hightowe/bin/mime_strip.html_bodies.pl
}
#############################################################

=head1 AUTHORSHIP

Lester Hightower <hightowe@10east.com>

=head1 CHANGE LOG

Dec-17-2002: 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