Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

attachments mass-dumps file attachments from mail

by Aristotle (Chancellor)
on Nov 02, 2004 at 21:21 UTC ( #404752=sourcecode: print w/ replies, xml ) Need Help??

Category: E-Mail Programs
Author/Contact Info /msg Aristotle
Description:

Does what it says on the tin. Reads from standard input or files/folders, so it is easy to use from your .procmailrc, from within your MUA, or the shell.

This was a joy to write I have to thank to Simon Cozens and his cohorts for a bunch of great email modules.

Also, a practical application of Batch processing progress printer.

#!/usr/bin/perl
use strict;
use warnings;
no warnings 'once';

=head1 NAME

attachments -- mass-dumps file attachments from mail

=head1 SYNOPSIS

F<attachments>
S<B<[ -f ]>>
S<B<[ -d directory ]>>
S<B<[ src [ src .. ] ]>>

=head1 DESCRIPTION

This program saves files attached to any number of email messages, rea
+ding either individual messages of entire mailboxes. If no arguments 
+are passed, it expects the data on standard input.

=head1 ARGUMENTS

=over 4

=item B<-h>, B<--help>

See a synopsis.

=item B<--man>

Browse the manpage.

=item B<-f>, B<--folders>

Puts the program in folders mode. Any arguments passed are assumed to 
+be mailboxes of any of a number of formats. Otherwise, an mbox(5) for
+mat mailbox is expected on standard input.

=back

=over 4

=head1 OPTIONS

=item B<-d>, B<--directory>

If given, attachments will be saved under this directory. Otherwise, t
+hey go in the current directory.

=over 4

=back

=head1 AUTHORS

Aristotle Pagaltzis

=head1 COPYRIGHT

This script is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.

=cut

use Pod::Usage;
use Getopt::Long 2.24, qw(:config bundling no_ignore_case no_auto_abbr
+ev);
use Email::MIME;
use Fcntl;
use File::Basename;
use File::Spec::Functions qw( canonpath catfile );

package Email::MIMEFolder;

our @ISA = qw( Email::Folder );

sub bless_message {
    my $self = shift;
    my ( $msg ) = @_;
    Email::MIME->new( $msg );
}

package main;

use constant BLOCKSIZE => 2**16;

sub write_file {
    my ( $fn, $content ) = @_;
    my $offs = 0;
    my $count = BLOCKSIZE;

    sysopen my $fh, $fn, O_WRONLY | O_EXCL | O_CREAT
        or die "Couldn't open $fn for writing: $!\n";

    $offs += $count = syswrite $fh, substr $$content, $offs, $count
        until $count < BLOCKSIZE;

    close $fh
        or die "Error closing $fn: $!\n"
}

sub read_file {
    my ( $fn ) = @_;
    open my $fh, '<', $fn
        or die "Couldn't open $fn for reading: $!\n";
    local $/;
    <$fh>;
}

sub make_printer {
    my $hdr = shift;
    my $count;
    return bless sub {
        my $item = shift || do {
            print "\n" if $count;
            return;
        };
        print( ( $count ? "," : "$hdr:") , " ", $item );
        ++$count;
    }, 'PRINTER';
    sub PRINTER::DESTROY { shift->() }
}

my $opt_directory;

sub process_mail {
    my ( $msg ) = @_;
    my $print = make_printer( $msg->header( "Message-ID" ) );
    for( $msg->parts ) {
        my $fn = $_->filename;
        next if not defined $fn;
        $fn = basename $fn;
        next if not length $fn;
        $print->( $fn );
        my $path = canonpath catfile $opt_directory, $fn;
        write_file $path, \( $_->body );
    }
}

GetOptions(
    'h|help'        => sub { pod2usage( -verbose => 1 ) },
    'man'           => sub { pod2usage( -verbose => 2 ) },
    'f|folders'     => \( my $opt_folders ),
    'd|directory=s' => \(    $opt_directory = '.' ),
) or pod2usage();

if( $opt_folders ) {
    require Email::Folder;

    my $msg;
    if( @ARGV ) {
        for( @ARGV ) {
            my $folder = Email::MIMEFolder->new( $_ );
            process_mail( $msg ) while $msg = $folder->next_message;
        }
    }
    else {
        # HACK, because ::Mbox sucks
        my $folder = Email::MIMEFolder->new( 'stdin', reader => 'Email
+::Folder::Mbox' );
        open $folder->reader->{_fh}, '<', \do { local $/; <> };

        process_mail( $msg ) while $msg = $folder->next_message;
    }
}
else {
    if( @ARGV ) {
        process_mail( Email::MIME->new( read_file $_ ) ) for @ARGV;
    }
    else {
        local $/;
        process_mail( Email::MIME->new( <> ) );
    }
}

Comment on attachments mass-dumps file attachments from mail
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://404752]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others examining the Monastery: (9)
As of 2015-07-08 05:29 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (94 votes), past polls