/usr/share/doc/libmail-box-perl/examples/strip-attachments.pl is in libmail-box-perl 2.117-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 | #!/usr/bin/perl
#
# $Id: strip-attachments.pl,v 1.4 2002/11/30 12:14:01 wrk Exp $
#
# Strip attachments using Mail::Box module.
#
# Usage:
#
# perl strip-attachments.pl mbox
#
# This script reads a mailbox ($ARG1) and writes attachments larger than
# 16K to a folder (./attachments/). Next it deletes the attachment from
# the E-mail and writes it to a file named $ARG1.stripped.
#
# By Pjotr Prins <pjotr@pckassa.com>, $Date: 2002/11/30 12:14:01 $
#
# This code can be used and modified without restriction.
# Code based on example by Mark Overmeer, <mailbox@overmeer.net>, 9 nov 2001
# In this example, the stripped data is written to a different folder.
# You may not need that (but please be careful: test your script well!)
# Simply remove everything related to $outbox and $outfilename, and open
# the source folder with access => 'rw'
# You may want to have a look at Mail::Message::Convert::Rebuild, which
# the provides the $msg->rebuild() method.
# BE WARNED: when different messages specify the same filename for a part,
# they will overwrite another... you may want a message sequency number in
# the path of the output file.
use warnings;
use strict;
use lib '..', '.';
use Mail::Box::Manager; # everything else will auto-compile when used
use File::Basename 'basename';
use File::Spec;
my $attachments = 'attachments';
#
# Get the command line arguments.
#
die "Usage: $0 folderfile\n"
unless @ARGV==1;
my $filename = shift @ARGV;
#
# Create Attachments directory if non existent
#
-d $attachments
or mkdir $attachments
or die "Cannot create directory $attachments\n";
#
# Open the folders
#
my $mgr = Mail::Box::Manager->new;
my $folder = $mgr->open
( $filename
, extract => 'LAZY' # never take the body unless needed
); # which saves memory and time.
die "Cannot open $filename: $!\n"
unless defined $folder;
my $outfilename = "$filename.stripped";
# die "File $outfilename exists!" if -e $outfilename;
my $outbox = $mgr->open
( $outfilename
, access => 'a' # append,
, create => 1 # create if not existent
);
die "Cannot open $outfilename to write: $!\n"
unless defined $outbox;
print "Mail folder $folder contains ", $folder->nrMessages, " messages:\n";
foreach my $message ($folder->messages)
{ printf "%3d. %s\n", $message->seqnr, $message->subject;
$message->printStructure;
my $m = $message->clone;
unless($m->isMultipart)
{ $outbox->addMessage($m);
next;
}
foreach my $part ($m->parts)
{
# Strip attachments larger than 16K. Another example would be:
# next if $part->body->mimeType ne 'text/plain';
next unless $part->body->size > 16384;
print "\n**** Stripping Attachment "; # ,$part->head,"\n";
# Warning: double names possible! Put each message in seperate dir
my $attachment = $part->body->dispositionFilename($attachments);
print $attachment,"\n";
unless(-f $attachment) # Write attachment to file
{ open(FH, '>', $attachment)
or die "ERROR: cannot write attachment to $attachment: $!\n";
$part->decoded->print(\*FH);
close(FH)
or die "ERROR: writing to $attachment: $!\n";
}
$part->delete;
}
$outbox->addMessage($m);
}
$mgr->closeAllFolders;
|