package Mail::Miner::Attachment;
use base 'Mail::Miner::DBI';
__PACKAGE__->set_up_table("attachments");
1;
package Mail::Miner::Attachments;
use strict;
use Exporter;
use Mail::Address;
our @ISA = qw(Exporter);
our @EXPORT = qw(detach_attachments detach);
my $GFileNo;
=head1 NAME
Mail::Miner::Attachment - Backend methods for Mail::Miner attachments
=head1 DESCRIPTION
This module implements some backend functionality for dealing with
C<Mail::Miner> attachments.
=head2 C<detach_attachments>
detach_attachments($entity, $messageid);
This subroutine takes a C<MIME::Entity> object, and flattens it,
storing any parts which are non-text, or have a recommended filename, into
the database. The textual body of the message is updated to alert the
user to how to extract the attachments.
=cut
my %ok_parts = map { $_ => 1 } ( "text/plain", "multipart/alternative");
sub detach_attachments {
my $object = shift;
my $entity = shift;
my @body;
my $content;
$entity->make_multipart;
for ($entity->parts) {
my $fn = $_->head->recommended_filename;
if (exists($ok_parts{$_->mime_type}) and !$fn) {
$content = $_ unless $content;
push @body, @{$_->body};
} else {
my $att = $_->mime_type;
my $add = $object->add_to_attachments({
filename => $fn,
contenttype => $_->mime_type,
encoding => ($_->bodyhandle && $_->bodyhandle->as_string)
});
return $entity unless $add->id; # Just in case
push @body, "\n",
"[ ".$entity->mime_type." attachment $fn detached - use \n",
"\tmm --detach ".$add->id."\n",
" to recover ]\n";
}
}
if ($content) {
my $io;
if ($io = $content->open("w")) {
foreach (@body) { $io->print($_) }
$io->close;
}
} else {
# Shit, no text at all
$content = MIME::Entity->build(
Type => "text/plain",
Data => \@body
);
}
$entity->parts([$content]);
$entity->make_singlepart;
return $entity;
}
=head2 C<detach>
detach($msgid)
This implements the front-end C<detach> option to C<mm>, the Mail::Miner
command-line tool. It saves a message's attachments to the current
directory, interactively.
=cut
sub detach {
my $id = shift;
my $obj = Mail::Miner::Attachment->fetch($id);
die "Couldn't find that attachment!\n" unless $obj;
my $first=0;
my $filename = $a->filename ||
_gen_filename($a->contenttype);
my $from = _namefrom(Mail::Address->parse($a->from_address));
print "Detaching $filename (".$a->contenttype.") sent by $from...\n";
if (-e $filename) {
print "\n! $filename already exists. Replace? (y/N)\n";
my $foo = <STDIN>;
if ($foo !~ /^y/i) {
print "OK, skipping...\n";
next;
}
}
open (OUT, ">", $filename) or do {warn "! $filename: $!\n"; next;};
print OUT $a->attachment;
close OUT;
}
sub _gen_filename {
my $content_type = shift;
# We're only using this for the generation of file names, so the
# directory we feed it is irrelevant.
my $filer = MIME::Parser::FileInto->new("/tmp");
# This code borrowed from MIME::Parser::Filer
my ($type, $subtype) = split m{/}, $content_type;
$subtype ||= '';
my $ext = ($filer->{MPF_Ext}{"$type/$subtype"} ||
$filer->{MPF_Ext}{"$type/*"} ||
$filer->{MPF_Ext}{"*/*"} ||
".dat");
++$GFileNo;
return "attachment-$$-$GFileNo$ext";
}
sub _namefrom {
my $what=shift;
return unless $what;
my ($address, $name, $phrase) = ($what->address, $what->name, $what->phrase);
return $name || $phrase || $address;
}
1;