<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#!/usr/local/bin/perl -w
#
# Created: 06/18/04 09:04:06 EDT by Andy Harrison
#
# USAGE
#
#     gmailarchiver.pl [-f "imapfolder"] \
#       [&lt;action&gt; [--send] [-o outputfile ] [-u user -p passwd] \
#           [-e emailaddress] [--smtp smtp_server_name]]
#
#       [--mbox mbox_file_name][--send][-u user -p passwd] \
#           [-e e-mailaddress] [--smtp smtp_server_name ]
#
#       [--url mailman_mbox_file_url [-e e-mailaddress] \
#           [--smtp smtp_server_name][--send]]
#
#       [--mailman mailman_listinfo_url [-e e-mailaddress] \
#           [--smtp smtp_server_name][--send]]
#
# SEE ALSO
#
#   perldoc gmailarchiver.pl
#
#
# $Id: gmailarchiver.pl,v 1.7 2004/07/29 19:13:52 aharriso Exp aharriso $

use strict;

no warnings 'once';
$|++;

use Mail::Mailer;
use Mail::IMAPClient;
use File::Slurp "read_file";
use Getopt::Long qw/:config auto_help auto_version/;
use List::Util qw/reduce/;

use vars 
    qw/
        $opt_c $opt_d $opt_e $opt_f 
        $opt_h $opt_l $opt_m $opt_n 
        $opt_o $opt_p $opt_port $opt_s 
        $opt_smtp $opt_u $opt_v $opt_subject
        $opt_delete $opt_until $opt_mbox
        $opt_url $opt_mailman

        $host $port $imap $folder
    /;

local $main::VERSION = 
    '$Id: gmailarchiver.pl,v 1.7 2004/07/29 19:13:52 aharriso Exp aharriso $';

GetOptions(
    'c|count!'        =&gt; \$opt_c,        # count of messages
    'delete!'         =&gt; \$opt_delete,   # delete messages
    'dump!'           =&gt; \$opt_d,        # download messages
    'e|email=s'       =&gt; \$opt_e,        # e-mail address
    'f|folder=s'      =&gt; \$opt_f,        # folder to select
    'h|host=s'        =&gt; \$opt_h,        # hostname
    'help'            =&gt; sub { help() }, # display help
    'l|list!'         =&gt; \$opt_l,        # list folders
    'mbox=s'          =&gt; \$opt_mbox,     # mboxfile name
    'm|msg|message=i' =&gt; \$opt_m,        # dump individual message
    'mailman=s'       =&gt; \$opt_mailman,  # URL of mailman listinfo page
    'n|numbers!'      =&gt; \$opt_n,        # number of messages in folder
    'o|outputfile=s'  =&gt; \$opt_o,        # output file name
    'p|password=s'    =&gt; \$opt_p,        # imap password
    'port=i'          =&gt; \$opt_port,     # server port
    's|send!'         =&gt; \$opt_s,        # send message to e-mail 
                                         # address after downloading
    'smtp=s'          =&gt; \$opt_smtp,     # smtp server to use to send the 
                                         # outgoing archived messages
    'subject=s'       =&gt; \$opt_subject,  # Subject prefix
    'until=i'         =&gt; \$opt_until,    # delete until this message number
    'u|user=s'        =&gt; \$opt_u,        # imap username
    'url=s'           =&gt; \$opt_url,      # Archive URL
    'v|verbose'       =&gt; \$opt_v,        # print some details
);

if ( $opt_v ) {
    eval {  
        require Data::Dumper; 
        $Data::Dumper::Indent = 3; 
    } 
}

if ( $opt_c or $opt_d or $opt_n or $opt_l or $opt_delete ) { 
    # bare minimum options to bother connecting

    $host = $opt_h ? $opt_h : 'localhost';
    $port = $opt_port ? $opt_port : '143';

    print "::host::-", $host, "-:: ::port::-", $port, "-::\n" if $opt_v;

    # Connect to the IMAP server
    #
    $imap = Mail::IMAPClient-&gt;new(
        Server   =&gt; $host,
        Port     =&gt; $port,
        User     =&gt; $opt_u,
        Password =&gt; $opt_p,
    ) or die "$opt_u unable to connect to imap $host:$port. \n\nError: $@";


    $folder = $opt_f ? $opt_f : "INBOX";
    $imap-&gt;select( $folder ) or die "Couldn't select folder: $@\n";

} 

if ( $opt_d ) {

    my $filename = $opt_o ? $opt_o : "/tmp/imapdump.txt";
    print "filename : ", $opt_o, "\n" if $opt_o and $opt_v;
    if ( $opt_o ) { 
        $imap-&gt;message_to_file( $filename, ( $opt_m or $imap-&gt;messages ) ) 
            or die "error::$@, $!::\n";
    }

    my @message_list;
    if ( $opt_until ) {
        for ( $imap-&gt;messages ) {
            push @message_list, $_ if $_ &lt;= $opt_until and $_ =&gt; $opt_m;
        }
    } else {
        
        @message_list = $opt_m ? $opt_m : $imap-&gt;messages;

    }
           
    for ( @message_list ) {

        if ( $opt_s and $opt_e ) {

            send_message ( 
                {
                    'To'       =&gt; $opt_e,
                    'From'     =&gt; $imap-&gt;get_header( $_, "From" ),
                    'Reply-To' =&gt; $opt_e,        # in case of bounces
                    'Subject'  =&gt; $opt_subject ? 
                                  $opt_subject . " " .  
                                  $imap-&gt;get_header( $_, "Subject" ) : 
                                  $imap-&gt;get_header( $_, "Subject" ),
                    'body'     =&gt; $imap-&gt;body_string( $_ ),
                } 
            );

        } elsif ( $opt_e and $opt_o and ! $opt_s ) {

            send_message ( 
                {
                    'To'      =&gt; $opt_e,
                    'From'    =&gt; "imap-to-gmail script",
                    'Subject' =&gt; "archive of $folder",
                    'body'    =&gt; reduce { $a . $b } read_file( $filename ),
                } 
            );

        } else {

            print $imap-&gt;bodypart_string( $_, 0 );
            print $imap-&gt;body_string( $_ );

        }
    }

    print "\n\n";


} elsif ( $opt_c ) {
    
    print "\n$folder contains ",$imap-&gt;message_count, " messages.\n\n";

} elsif ( $opt_n ) {

    print "Message numbers:\n\n";
    print $_, " " for $imap-&gt;messages;
    print "\n";

} elsif ( $opt_l ) {

    print $imap-&gt;list;

} elsif ( $opt_delete and $opt_m ) {

    if ( $opt_until ) {

        my @deletions;
        for ( $imap-&gt;messages ) {
            push @deletions, $_ if $_ &lt;= $opt_until and $_ =&gt; $opt_m;
        }
        $imap-&gt;delete_message( \@deletions ) or
            die "Could not delete messages: $@\n";

    } else {

        $imap-&gt;delete_message( $opt_m ) or 
            die "Could not delete messages: $@\n";

    }

    $imap-&gt;expunge( $opt_f ) or die "Could not expunge: $@\n";


} elsif ( $opt_mbox and $opt_s and $opt_e and $opt_smtp ) {

    mbox_parse( $opt_mbox, $opt_e );

} elsif ( $opt_mailman ) {

    print "--mailman--$opt_mailman\n";
    grab_archives( $opt_mailman, "all" );

} elsif ( $opt_url ) {

    print "--url--$opt_url\n" if $opt_v;
    grab_archives( $opt_url, undef );

} else { 

    help();

}

$imap-&gt;logout or warn "Couldn't logout: $@\n" if $imap;

sub help {

    use Pod::Usage;
    pod2usage( -verbose =&gt; 2 );

}

sub grab_archives {

    print "::_::", Dumper( @_ ), "::\n" if $opt_v;
    my ( $url, $option ) = @_;

    print "::url::-&gt;", $url, "&lt;-::\ngrab option::$option::\n" if $opt_v;

    die "not a valid mailman archive url: $!\n" 
        if ! $option eq "all" and $url =~ m/txt.gz/;

    die "Please install WWW::Mechanize Module: $@\n" unless
        eval { require WWW::Mechanize; };

    my $mech = WWW::Mechanize-&gt;new();  
    
    if ( $option eq "all" ) {
        $mech-&gt;get( $url ) or
            die "Unable to fetch: $url, $!\n";

        $mech-&gt;follow_link( text_regex =&gt; qr/Archives/ );

        my @archives_obj = 
            $mech-&gt;find_all_links( url_regex =&gt; qr/\.txt\.gz$/ );

        for ( @archives_obj ) {

            my $url = $_-&gt;url;

            my $fetched_filename = fetch_archive( $url, $mech );

            mbox_parse( $fetched_filename, $opt_e );
        }
    } else {

        print "step1** ::", $url, ":: **\n" if $opt_v;
        my $fetched_filename = fetch_archive( $url, $mech );
        mbox_parse( $fetched_filename, $opt_e );

    }

}

sub fetch_archive {

    my ( $url, $mech ) = @_;
    my $destination_file;
    my $gz_file;

    print Dumper( $url ) if $opt_v;

    if ( $url =~ m/^http:/ ) {
        die "Unable to load URI module: $@\n" unless
            eval { require URI; };
        my $link = URI-&gt;new( $url ); 
        my $path = $link-&gt;path;  
        my @filename = $link-&gt;path_segments( $link-&gt;path ); 
        print ":filename:", 
              Dumper( $filename[-1] ), 
              "\n::" if $opt_v;
        $gz_file = $filename[-1];

    } else {

        $gz_file = $url;

    }

    $destination_file = $gz_file;
    $destination_file =~ s/\.gz$//;

    $mech-&gt;get( $url, ":content_file" =&gt; $gz_file ) or 
        warn "Unable to fetch: $url, $!\n";

    print "::urlgunzip::", Dumper( $url ), "::\n" if $opt_v;

    gunzip( $gz_file, $destination_file ) and 
        unlink $url || die "Unable to gunzip: ", $url, " $!\n";

    return $destination_file or die "error fetching archive: $!\n";

}

sub mbox_parse {

    my $mbox_file   = shift;
    my $email       = shift;

    print "--file--&gt;\n", Dumper( $mbox_file ), Dumper( $email ), 
          "&lt;----\n" if $opt_v;

    die "Please install Mail::MboxParser Module: $@\n" unless
        eval { require Mail::MboxParser; };

    my $parseropts = {
        enable_cache    =&gt; 0,
        enable_grep     =&gt; 1
    };
    my $mb = Mail::MboxParser-&gt;new( $mbox_file,
                                     decode     =&gt; 'ALL',
                                     parseropts =&gt; $parseropts ) or 
        die "Problem reading mbox file: $@, $!\n";

    my $msg_counter;
    if ( $opt_m ) {
        for ( $msg_counter = 1 ; $msg_counter &lt;= $opt_m ; $msg_counter++ ) {
            # Allows message range specification
            $mb-&gt;next_message;
        } 
    }

    while ( my $msg = $mb-&gt;next_message ) {

        send_message( 
            {
                'To'        =&gt;  $email,
                'From'      =&gt;  $msg-&gt;header-&gt;{ from },
                'Subject'   =&gt;  $opt_subject ?
                                $opt_subject . " " .
                                $msg-&gt;header-&gt;{ subject } :
                                $msg-&gt;header-&gt;{ subject },
                'Date'      =&gt;  $msg-&gt;header-&gt;{ date } ,
                'body'      =&gt;  $msg-&gt;body-&gt;as_string,
            }
        ) or warn "unable to send: $!, $@\n";

        last if $opt_until and $msg_counter++ &gt; $opt_until;
    }

}

sub send_message {

# leaving this line commented so I can quickly switch to test mode.
#    my $mailer = new Mail::Mailer 'testfile'
    my $mailer = new Mail::Mailer 'smtp', Server =&gt; $opt_smtp 
        if $opt_e and $opt_s and $opt_smtp || 
            die "Specify a valid smtp server with --smtp:  $@\n";

    my $message_body = $_[0]-&gt;{ 'body' };
    delete $_[0]-&gt;{ 'body' } if $message_body;

    print "-----&gt;\n", Dumper( $_[0]-&gt;{'Subject'} ), "&lt;------\n" if $opt_v;
    $mailer-&gt;open( $_[0] ) or warn "error mailing: $!, $@\n",
        "contents\n--------\n", $_[0], "\n-----------\n";

    print ".";
    print "message body\n", "&gt;" x 20, "\n", 
      $message_body,
      "\n", "&lt;" x 20, "\nend message body\n" if $opt_v;

    print $mailer $message_body or 
        warn "unable to output message contents: $!, $@\n";

    $mailer-&gt;close;


}

# Lifted from CPAN.pm
# CPAN::Tarzip::gunzip
#
sub gunzip {
    
    die "Unable to load Compress::Zlib module: $@\n" unless
        eval { require Compress::Zlib; };

    die "Unable to load FileHandle module: $@\n" unless
        eval { require FileHandle; };

    my( $read, $write ) = @_;
    my($buffer,$fhw);

    $fhw = FileHandle-&gt;new("&gt;$write")
	    or die("Could not open &gt;$write: $!");

    my $gz = Compress::Zlib::gzopen($read, "rb")
	    or die("Cannot gzopen $read: $!\n");

    $fhw-&gt;print($buffer) while $gz-&gt;gzread($buffer) &gt; 0 ;

    die("Error reading from $read: $!\n")
	    if $gz-&gt;gzerror != Compress::Zlib::Z_STREAM_END();

    $gz-&gt;gzclose() ;
    $fhw-&gt;close;

}

#
# $Log: gmailarchiver.pl,v $
# Revision 1.7  2004/07/29 19:13:52  aharriso
# fixed a verbose option bug
#
# retooled the pod docs
#
# Revision 1.6  2004/07/22 14:52:58  aharriso
# code cleanup
# script name change to gmailarchiver
# CPAN friendly POD
#
# Revision 1.5  2004/07/21 15:05:29  aharriso
# added mbox support, mailman handling
#
# Revision 1.4  2004/07/20 13:14:53  aharriso
# added features to prefix a subject and delete messages
#
# Revision 1.3  2004/07/16 12:45:46  aharriso
# fixed the elsif $opt_d bug
#
# Revision 1.2  2004/07/02 12:01:09  aharriso
# minor changes
#
# Revision 1.1  2004/07/02 04:12:29  aharriso
# Initial revision
#
#

__END__

=head1 NAME

gmailarchiver.pl - Archive your IMAP Mail

=head1 SCRIPT CATEGORIES

Mail

=head1 README

I created this script for the purpose of moving some 
of my IMAP mail to my gmail.com account.

I've also added mbox support along with mailman mbox
archive support.

=head1 OSNAMES

any

=head1 PREREQUISITES

C&lt;Mail::Mailer&gt;

C&lt;Mail::IMAPClient&gt;

C&lt;File::Slurp&gt;

=head1 COREQUISITES

C&lt;Mail::MboxParser&gt; - for mbox format file handling

C&lt;WWW::Mechanize&gt; - to fetch Mailman (mbox format) archives

=head1 SYNOPSIS

=head2 OPTIONS AND ARGUMENTS

B&lt;Actions&gt;

You may only select one of the following actions.

=over 15

=item B&lt;-c&gt; B&lt;--count&gt;

count of messages

I&lt;Required arguments&gt;

B&lt;--user&gt; B&lt;--password&gt; 

I&lt;Optional arguments&gt;

B&lt;--folder&gt; B&lt;--port&gt; B&lt;--hostname&gt;

=item B&lt;--dump&gt;

Dump (download) messages

I&lt;Required arguments&gt;

B&lt;--user&gt; B&lt;--password&gt; 

I&lt;Optional arguments&gt;

B&lt;--folder&gt; B&lt;--port&gt; B&lt;--hostname&gt;
B&lt;-m&gt; (--until) B&lt;--outputfile&gt; B&lt;--send&gt; B&lt;--smtp&gt;
B&lt;--subject&gt; 

=item B&lt;--delete&gt;

Delete messages matching I&lt;message_id&gt;.  Use B&lt;--until&gt; to 
specify a range.

I&lt;Required arguments&gt;

B&lt;--user&gt; B&lt;--password&gt; 

I&lt;Optional arguments&gt;

B&lt;--folder&gt; B&lt;--hostname&gt; B&lt;--port&gt; B&lt;-m&gt; (--until)

=item B&lt;--list&gt;

List IMAP folders

I&lt;Required arguments&gt;

B&lt;--user&gt; B&lt;--password&gt; 

I&lt;Optional arguments&gt;

B&lt;--hostname&gt; B&lt;--port&gt; 

=item B&lt;--mailman&gt; I&lt;list-info url&gt;

Forward mailman list archives to your gmail account.

Specify the full url to list-info mailman page.
(such as I&lt;http://lists.bestpractical.com/cgi-bin/mailman/listinfo/rt-users&gt;)

I&lt;Required arguments&gt;

B&lt;--email&gt; B&lt;--smtp&gt; B&lt;--send&gt;

I&lt;Optional arguments&gt;

B&lt;-m&gt; (--until) B&lt;--subject&gt; 

=item B&lt;-n&gt; B&lt;--numbers&gt;

Show message id numbers in folders

I&lt;Required arguments&gt;

B&lt;--user&gt; B&lt;--password&gt; 

I&lt;Optional arguments&gt;

B&lt;--folder&gt; B&lt;--hostname&gt; B&lt;--port&gt; 

=item B&lt;--mbox&gt; I&lt;filename&gt;

Forward an mbox archive file to your gmail account.

I&lt;Required arguments&gt;

&lt;--email&gt; &lt;--send&gt; &lt;--smtp&gt;

I&lt;Optional arguments&gt;

&lt;-m&gt; (--until) B&lt;--subject&gt;

=item B&lt;--url&gt; I&lt;url&gt;

Specify the full url to an mbox format archive.

(such as I&lt;http://lists.bestpractical.com/pipermail/rt-users/2004-July.txt.gz&gt;)

I&lt;Required arguments&gt;

B&lt;--email&gt; B&lt;--send&gt; B&lt;--smtp&gt;

I&lt;Optional arguments&gt;

B&lt;-m&gt; (--until) B&lt;--subject&gt;

=back

B&lt;Argument details&gt;

=over 15

=item B&lt;-e&gt; B&lt;--email&gt; I&lt;address&gt;

destination e-mail address

=item B&lt;-f&gt; B&lt;--folder&gt; I&lt;foldername&gt;

folder to select

=item B&lt;-h&gt; B&lt;--host&gt; I&lt;hostname&gt;

IMAP server you want to access, default [C&lt;localhost&gt;]

=item B&lt;-l&gt; B&lt;--list&gt;

list folders

=item B&lt;-m&gt; I&lt;id&gt;

specify individual message id.  You may also use the B&lt;--until&gt; 
param to specify a range, as described for B&lt;--delete&gt;.

=item B&lt;-o&gt; B&lt;--outputfile&gt; C&lt;filename&gt;&gt;

output file name

=item B&lt;-p&gt; B&lt;--password&gt; I&lt;password&gt;

IMAP password

=item B&lt;--port&gt; I&lt;port_number&gt;

Connect to IMAP server using specified port.  Default [C&lt;143&gt;]

=item B&lt;-s&gt; B&lt;--send&gt;

send messages to specified e-mail address after downloading

=item B&lt;--smtp&gt; I&lt;smtp_server&gt;

name of smtp server that will be used to send the 
outgoing archived messages.

=item B&lt;--subject&gt; I&lt;subject&gt;

To assist with filtering, you may specify a Subject prefix.

(such as I&lt;'[Apache-Users Archives]'&gt;

=item B&lt;-u&gt; B&lt;--user&gt; I&lt;username&gt;

IMAP username

=item B&lt;-v&gt; B&lt;--verbose&gt;

print some details

=back

=head2 EXAMPLES

=over 15

=item C&lt;gmailarchiver.pl&gt; C&lt;-u&gt; I&lt;username&gt; C&lt;-p&gt; I&lt;password&gt; C&lt;--dump&gt;
C&lt;-o&gt; I&lt;outputfile&gt; C&lt;-f&gt; I&lt;INBOX.List1&gt;

Dump all messages in I&lt;INBOX.List1&gt; to the single specified file

(Optionally, e-mail the file by adding C&lt;-e&gt; I&lt;address&gt;)

=item C&lt;gmailarchiver.pl&gt; C&lt;-u&gt; I&lt;username&gt; C&lt;-p&gt; I&lt;password&gt; C&lt;-f&gt; 
I&lt;INBOX.Lists.FreeBSD.Questions&gt; C&lt;--dump&gt; C&lt;-m&gt; I&lt;1&gt; C&lt;--until&gt; 
I&lt;1000&gt; C&lt;-e&gt; I&lt;destination_address&gt; C&lt;--smtp&gt; I&lt;smtp_server_name&gt;
C&lt;--subject&gt; I&lt;'[FreeBSD-Questions Archive]'&gt; C&lt;--send&gt;

Send the first 1000 messages of your freebsd-questions mailling list
folder with filterable subject prefix [FreeBSD-Questions Archive].

=item C&lt;gmailarchiver.pl&gt; C&lt;-u&gt; I&lt;username&gt; C&lt;-p&gt; I&lt;password&gt; C&lt;--dump&gt; C&lt;-e&gt; 
I&lt;foo@example.com&gt; C&lt;--smtp&gt; I&lt;smtp_server_name&gt; C&lt;--send&gt; C&lt;--subject&gt; 
I&lt;subject_prefix&gt;

Dump all messages and e-mail forward them individually

(Optionally, you can still specify C&lt;-o&gt; to also output to a file

=item C&lt;gmailarchiver.pl&gt; C&lt;-u&gt; I&lt;username&gt; C&lt;-p&gt; I&lt;password&gt; C&lt;-c&gt; C&lt;-f&gt; 
I&lt;INBOX.List1&gt;

Count messages in IMAP folder I&lt;INBOX.List1&gt;

=item C&lt;gmailarchiver.pl&gt; C&lt;-u&gt; I&lt;username&gt; C&lt;-p&gt; I&lt;password&gt; C&lt;-l&gt;

List all IMAP folders

=item C&lt;gmailarchiver.pl&gt; C&lt;-u&gt; I&lt;username&gt; C&lt;-p&gt; I&lt;password&gt; C&lt;-n&gt;

List message id numbers in folder I&lt;INBOX.List1&gt;

=item C&lt;gmailarchiver.pl&gt; C&lt;-u&gt; I&lt;username&gt; C&lt;-p&gt; I&lt;password&gt; C&lt;--dump&gt; C&lt;-m&gt; 
I&lt;10&gt; C&lt;-f&gt; I&lt;INBOX.List1&gt;

Dump message with id number I&lt;10&gt; from folder I&lt;INBOX.List1&gt;

=item C&lt;gmailarchiver.pl&gt; C&lt;--mailman&gt; 
I&lt;http://lists.bestpractical.com/cgi-bin/mailman/listinfo/rt-users&gt;
C&lt;-e&gt; I&lt;destination_address&gt; C&lt;--smtp&gt; I&lt;smtp_server_name&gt;
C&lt;--subject&gt; I&lt;'[RT-Users Web Archive]'&gt; C&lt;--send&gt;

Send all messages from the RT-Users mailman mailing list archive
to the specified e-mail address, prefixing each subject with 
the filterable string '[RT-Users Web Archive]'

=item C&lt;gmailarchiver.pl&gt; C&lt;--url&gt; 
I&lt;http://lists.bestpractical.com/pipermail/rt-users/2004-July.txt.gz&gt;
C&lt;-e&gt; I&lt;destination_address&gt; C&lt;--smtp&gt; I&lt;smtp_server_name&gt;
C&lt;--subject&gt; I&lt;'[RT-Users Web Archive]'&gt; C&lt;--send&gt;

Send all messages from the RT-Users mailman mailing list archive for
July 2004 to the specified e-mail address, prefixing each subject with
the filterable string '[RT-Users Web Archive]'

=back

=head1 ACKNOWLEDGEMENTS

built using Mail::IMAPClient by C&lt;DJKERNEN@cpan.org&gt;

lifted the gunzip routine from CPAN.pm written by
Andreas Koenig E&lt;lt&gt;andreas.koenig@anima.deE&lt;gt&gt;

=head1 SEE ALSO

L&lt;Mail::Webmail::Gmail|http://search.cpan.org/~mincus/Mail-Webmail-Gmail-0.07/&gt;

=head1 AUTHOR

Andy Harrison

 { 
   domain   =&gt; "gmail", 
   tld      =&gt; "com", 
   username =&gt; "aharrison" 
 }

=cut


</pre></body></html>