tools/extract_attachments

   1 #!/usr/bin/perl -w
   2
   3 # Found this code on the internet. Not tested...
   4 # http://forums.devshed.com/t49349/s.html
   5
   6 use strict;
   7 use MIME::Parser;
   8
   9 my $logfile='/home/directory/attaches.log';
  10 my $attachdir='/home/directory';
  11
  12 my $parser=new MIME::Parser;
  13 $parser->ignore_errors(1);
  14 $parser->extract_uuencode(1);
  15 $parser->tmp_recycling(0);
  16 $parser->output_to_core(1);
  17 my $entity=$parser->parse(*STDIN);
  18
  19 my $from=$entity->head->get('From');
  20 my $subject=$entity->head->get('Subject');
  21 my @parts=$entity->parts;
  22 my $aname='attachment001';
  23 while(my $part = shift(@parts)) {
  24   if($part->parts) {
  25       push @parts,$part->parts; # Nested multi-part
  26       next;
  27   }
  28   my $type=$part->head->mime_type || $part->head->effective_type;
  29   if($type !~ /^(text|message)/i) { # Not a text, save it
  30       my $filename=$part->head->recommended_filename || $aname;
  31       $aname++;
  32       my $io=$part->open("r");
  33       my $uniq=time().'-'.$$;
  34         $filename =~ s/[;<>*|`&\$!#\(\)\[\]\{\}:'"\n]//g;
  35       open(F,">> $attachdir/$uniq-$filename");
  36       my $buf;
  37           while($io->read($buf,1024)) {
  38           print F $buf;
  39       }
  40       close(F);
  41       $io->close;
  42       open(LOG,">> $logfile");
  43       print LOG localtime()." From: $from\tSubject: $subject\tFile: $uniq-$filename\n";
  44       close(LOG);
  45 }
  46 }
  47 exit;