#!/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.                                                          #
#                                                                         #
# Originally coded 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;
use IPC::Open2;
use FileHandle;

my $VERSION = 1.4;

$|++;

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 $body=$ent->parts(0)->bodyhandle->as_string();
  # If the body is short (so a regex makes sense) and it's all white-space,
  # then dropping the HTML body makes the message a little useless, and
  # likely it is spam...  However, if we have lynx available, we'll
  # try to convert it to plain text.
  if (length($body) < 500 && $body =~ m/^\s+$/) {
    my $html_body=$ent->parts(1)->bodyhandle->as_string();
    my $new_body = &HTMLtoTXTviaLynx(\$html_body);
    if (length($new_body)) { $body = $new_body; }
  }
  my $newent = MIME::Entity->build(Data =>
                           $body .  "\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 $body=$ent->parts(0)->parts(0)->bodyhandle->as_string();
  # If the body is short (so a regex makes sense) and it's all white-space,
  # then dropping the HTML body makes the message a little useless, and
  # likely it is spam...  However, if we have lynx available, we'll
  # try to convert it to plain text.
  if (length($body) < 500 && $body =~ m/^\s+$/) {
    my $html_body=$ent->parts(0)->parts(1)->bodyhandle->as_string();
    my $new_body = &HTMLtoTXTviaLynx(\$html_body);
    if (length($new_body)) { $body = $new_body; }
  }

  my $newent = MIME::Entity->build(Data =>
                 $body .  "\n\n[HTML alternate version deleted]\n");
  $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)
#
# Emails from mozilla with "multipart/related" attachments.
} 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)->bodyhandle->as_string() .
                                   "\n\n[HTML alternate version deleted]\n");
  $ent->parts([$newent]);
  $ent->make_singlepart;
  $ent->sync_headers(Length => 'COMPUTE', Nonstandard => 'ERASE');
#
# Mozilla Mail (added 03/27/2003 by LHH)
#
# Emails from mozilla with "multipart/related" attachments inside of
# an "multipart/alternative" in a "multipart/mixed" message.
# These come when a document is attached to an email and the
# client is also configured to send HTML mail.
} 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 "multipart/related") {

    my $newent = MIME::Entity->build(Data =>
                 $ent->parts(0)->parts(0)->bodyhandle->as_string() .
                          "\n\n[HTML alternate version deleted]\n");
    $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');
}

print $envelope;
$ent->print;

exit;

###############
# Subroutines #
###############
sub HTMLtoTXTviaLynx {
  my $rhtml=shift @_;
  if (ref($rhtml) ne 'SCALAR') { return ''; }

  my $LYNX_EXE=`which lynx 2>/dev/null`;
  chomp($LYNX_EXE);
  if (! (-x $LYNX_EXE)) { return ''; }

  my $body='';
  my $tmp_file = "/tmp/mime_strip.html_bodies.$$.lynx.tmp";
  my $h_out=new FileHandle;
  my $h_in=new FileHandle;
  my $new_enough_lynx=0;
  my $lynx_ver="UNKNOWN";
  if (open($h_in, "'$LYNX_EXE' --version 2>&1 |")) {
    my @ver_data=<$h_in>;
    my ($ver_info,@crap)=grep(/version/i, @ver_data);
    chomp($ver_info);
    close($h_in);
    if ($ver_info =~ m/Version (([0-9]+)\.([0-9]+)\.([0-9]+)[^\s]+)/i) {
      $lynx_ver=$1;
      if ($2 >= 2 && $3 >= 8 && $4 >= 4) {
        $new_enough_lynx=1;
      }
    }
  }
  if ($new_enough_lynx && open($h_out, "| '$LYNX_EXE' -stdin -dump -nolog -noredir -localhost -width=76 1>'$tmp_file' 2>/dev/null")) {
    print $h_out $$rhtml;
    close $h_out;
    if (-r $tmp_file && open($h_in, "< $tmp_file")) {
      my @lynx_text_arr=<$h_in>;
      close($h_in);
      unlink $tmp_file;
      my $lynx_text=join('', @lynx_text_arr);
      if (length($lynx_text)) {
        $body = $lynx_text . "\n[HTML converted to text by lynx $lynx_ver]\n";
      }
    }
  } elsif (! $new_enough_lynx) {
    $body="NOTICE from mime_strip.html_bodies.pl:\n" .
	"\n" .
	"This message had an empty text/plain attachment, so I wanted\n" .
	"to use lynx to convert the HTML attachment to plain text,\n" .
	"and I found a lynx binary at $LYNX_EXE, but the lynx\n" .
	"version is too old for me to use (ver. $lynx_ver).\n" .
	"\n" .
	"You might consider upgrading lynx to v2.8.4 or higher.\n";
  }
return $body;
}


###############
## 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
Mar-25-2003: Version 1.0, first release to CPAN
Mar-26-2003: Version 1.1, added "README" to POD for better CPAN behavior
Mar-27-2003: Version 1.2, added another Mozilla "multipart/related" catch
Apr-22-2003: Version 1.3, bugfix: changed to $ent->bodyhandle->as_string()
Jan-06-2004: Version 1.4: added lynx-based HTML->plain text conversions
                          for multi-part alternatives that do not have a
                          text/plain component.

=head1 PREREQUISITES

This script requires the C<strict> module.  It also requires
C<MIME::Tools 5.411>.  If you want to use the HTML->text feature
(not required, and not very important) you will need version 2.4.8
or higher of lynx, the text-based web-browser, installed.

=pod OSNAMES

any

=pod SCRIPT CATEGORIES

Mail
Mail/Converters
Mail/Filters

=cut