#!/usr/bin/perl -w
# 
# stripmime
# 
# how to use:
#      - run ./Configure ; nah, I'm joking
#      - use 'perl -MCPAN -e shell' to download Mime-Tools
#        which you won't  have.
#      - save this file somewhere cosy.
#
# Put the following recipe in your procmail
#
#   # Scary MIME stripping
#   :0 Hf
#   * ^Content-Type: multipart/mixed
#   | $HOME/bin/stripmime   # or wherever
#
#   - change $directory to point to where you want attachments to end up
#   - if you want to put them somewhere accessible by a webserver,
#     change $host and $url to something that makes sense (but
#     bear in mind that if you have CGI Exec powers in that directory,
#     you've basically allowed someone to e-mail you a trojan)
#   - pray that it works as well for you as it did for me
#
# DON'T TRY THIS UNLESS YOU'RE CONFIDENT ABOUT
# PROCMAIL, PERL and/or LOSING ALL YOUR MAIL
#
# bugs and hate mail to: stripmime@spesh.com
#
# thanks
# d.
#
# this file can be found (for now) at
# http://www.ntk.net/2000/05/19/stripmime.txt
#
# copying fine, but include URL

use MIME::Parser;

$host="machine.example.com";
$directory="$ENV{HOME}/public_html/";
$url="http://$host/~yourusername/";

my $parser = new MIME::Parser;
$parser->output_dir($directory);
$entity=$parser->read(\*STDIN);
# print $entity->print_header(\*STDERR);
my @parts=$entity->parts;
if ($#parts>0) {
        my @newparts;
        my @sig;
        push @sig, "stripmime activated: $#parts scanned\n";
        foreach $part (@parts) {
                if ($part->mime_type =~ /text/) {
                        push @newparts, $part
                        } else {
                        my $path=$part->bodyhandle->path;
                        my $newsig="Attachment saved as: $path\n";
                        if ($url) {
                        		  chmod 0644, $path;
                                  my $fullurl=$path;
                                  $fullurl =~ s/\Q$directory\E/$url/;
                                  $newsig.="<$fullurl>\n"; 
                                  }
                        push @sig, "$newsig\n";
                        }
                }
        $entity->parts(\@newparts);
        $entity->sign(Signature => \@sig, Remove => 0);
# I didn't need the following with Mutt, but your MUA may prefer it
#		$entity->sync_headers(Length =>'COMPUTE');
        $entity->print(\*STDOUT);
        foreach $part (@newparts) {
                $part->purge;
                }
        } 
        else { 
        # if single part
        $entity->print(\*STDOUT);
        }