User password -P

Server Port (default $PORT) -i INBOX save path (default $INBOX_PATH) -I skip INBOX (default $DOINBOX) -f Save path for other folders (default $FOLDERS_PATH) -m Regexp for IMAP folders not to be saved: $DONT_MOVE -r Read delimiter (default \"$READ_DELIMITER\") -w Write Delimiter (default \"$WRITE_DELIMITER\") -b Banned chars (default \"$BANNED_CHARS\") -c Strip CRs from saved files [for Unix] (default \"$CR\") -n Receive only messages (Default ".($NUMBER ? "$NUMBER" : "all").") -U Unseen messages Only -D Delete downloaded files on server -d Debug mode (default $DEBUG)\n"; exit 1; } ## do our magic tricks ###################################### connect_imap(); find_folders(); sub connect_imap() { # Open an SSL session to the IMAP server # Handles the SSL setup, and gives us back a socket my $ssl; if ($opt_S) { $ssl=IO::Socket::SSL->new( PeerHost => "$SERVER:imaps" # , SSL_version => 'SSLv2' # for older versions of openssl ); defined $ssl or die "Error connecting to $SERVER:imaps - $@"; $ssl->autoflush(1); } $imap = Mail::IMAPClient->new( Socket => ($opt_S ? $ssl : 0), Server => $SERVER, User => $USER, Password => $PASSWORD, Port => $PORT, Debug => $DEBUG, Uid => 0, Clear => 1, ) or die ("Could not connect to $SERVER:$PORT with $USER: $! $?\n"); } sub find_folders() { my @folders = $imap->folders; # push(@folders, "INBOX"); foreach my $folder (@folders) { my $message_count; if ($folder eq "INBOX" and $DOINBOX == 0) { print "* $folder is unwanted, skipping.\n"; next; } if (!$UNSEEN) { $message_count = $imap->message_count($folder); } else { $message_count = $imap->unseen_count($folder) || 0; } if(! $message_count) { print "* $folder is empty, skipping.\n"; next; } if($folder =~ /$DONT_MOVE/) { warn "! $folder matches DONT_MOVE ruleset, skipping\n"; next; } my $new_folder = $folder; $new_folder =~ s/\./_/g; $new_folder =~ s/\Q$READ_DELIMITER/$WRITE_DELIMITER/g; my $path = $new_folder eq "INBOX" ? "$INBOX_PATH" : "$FOLDERS_PATH/$new_folder"; if ($NUMBER && $NUMBER < $message_count) { printf "x %4i %-45.45s => %s", $NUMBER, $folder, $path; write_folder $folder, $path, 1, $NUMBER; } else { printf "x %4i %-45.45s => %s", $message_count, $folder, $path; write_folder $folder, $path, 1, $message_count; } } } sub write_folder($$$$) { my($folder, $newpath, $first_message, $last_message) = @_; $imap->select($folder) or warn "Could not examine $folder: $!"; my $new_dir = dirname $newpath; my $new_file = basename $newpath; -d $new_dir or mkpath($new_dir, 0700) or die "Cannot create $new_dir:$!\n"; open my $mbox, $WRITE_MODE, $newpath or die "Cannot create file $newpath: $!\n"; my @msgs = $imap->unseen if $UNSEEN; for (my $i=$first_message; $i<$last_message+1; ++$i) { my $m = ($UNSEEN ? shift @msgs : $i); my $date = UnixDate(ParseDate($imap->internaldate($m)), "%a %b %e %T %Y"); my $user = $imap->get_envelope($m)->from_addresses; $user =~ s/^.*<([^>]*)>/$1/; $user = '-' unless $user; print '.' if $m%25 == 0; my $msg_header = $imap->fetch($m, "FAST") or warn "Could not fetch header $m from $folder\n"; my $msg_rfc822 = $imap->fetch($m, "RFC822"); unless($msg_rfc822) { warn "Could not fetch RFC822 $m from $folder\n"; $FAIL=1 } undef my $start; foreach (@$msg_rfc822) { my $message; if($_ =~ /\: / && !$message) { ++$message; print $mbox "From $user $date\n"; } if(/^\)\r/) { undef $message; print $mbox "\n\n"; } next unless $message; $_ =~ s/\r$//; $_ = $imap->Strip_cr($_) if $CR; print $mbox "$_"; } if($DELETE && ! $FAIL) { $imap->delete_message($m) or warn "Could not delete_message: $@\n"; $FAIL = 0; } } close $mbox or die "Write errors to $newpath: $!\n"; if($DELETE) { $imap->expunge($folder) or warn "Could not expunge: $@\n"; } print "\n"; } # 2008/08/07 - Added SSL support, fixed From header printing, and CR # elimination (sobek) # # Revision 19991216.7 2002/08/23 13:29:48 dkernen # # Revision 19991216.6 2000/12/11 21:58:52 dkernen # # Revision 19991216.5 1999/12/16 17:19:12 dkernen # Bring up to same level # # Revision 19991124.3 1999/12/16 17:14:25 dkernen # Incorporate changes for exists method performance enhancement # # Revision 19991124.02 1999/11/24 17:46:19 dkernen # More fixes to t/basic.t # # Revision 19991124.01 1999/11/24 16:51:49 dkernen # Changed t/basic.t to test for UIDPLUS before trying UID cmds # # Revision 1.3 1999/11/23 17:51:06 dkernen # Committing version 1.06 distribution copy Mail-IMAPClient-3.38/examples/migrate_mail2.pl0000755000175000017500000002566212535524202020451 0ustar ppearlppearl#!/usr/local/bin/perl #$Id$ # # An example of how to migrate from a Netscape server # (which uses a slash as a separator and which does # not allow subfolders under the INBOX, only next to it) # to a Cyrus server (which uses a dot (.) as a separator # and which requires subfolders to be under "INBOX"). # There are also some allowed-character differences taken # into account but this is by no means complete AFAIK. # # This is an example. If you are doing mail migrations # then this may in fact be a very helpful example but # it is unlikely to work 100% correctly as-is. # A good place to start is by testing a rather large-volume # transfer of actual mail from the source server with the # -v option turned on and redirect output to a file for # perusal. Examine the output carefully for unexpected # results, such as a number of messages being skipped because # they're already in the target folder when you know darn # well this is the first time you ran the script. This # would indicate an incompatibility with the logic for # detecting duplicates, unless for some reason the source # mailbox contains a lot of duplicate messages to begin with. # (The latter case is an example of why you should use an # actual mailbox stuffed with actual mail for test; if you # generate test messages and then test migrating those you # will only prove that your test messages are migratable. # # Also, you may need to play with the rules # for translating folder names based on what kind of # names your target server and source server support. # # You may also need to play with the logic that determines # whether or not a message has already been migrated, # especially if your source server has messages that # did not come from an SMTP gateway or something like that. # # Some servers allow folders to contain mail and subfolders, # some allow folders to only contain either mail or subfolders. # If you are migrating from a "mixed use" type to a "single use" # type server then you'll have to figure out how to deal # with this. (This script deals with this by creating folders like # "/blah_mail", "/blah/blah_mail", and "/blah/blah/blah_mail" # to hold mail if the source folder contains mail and subfolders # and the target server supports only single-use folders. # You may not choose a different strategy.) # # Finally, it's possible that in some server-to-server # copies, the source server supports messages that the # target server considers unacceptable. For example, some # but not all IMAP servers flat out refuse to accept # messages with "base newlines", which is to say messages # whose lines are match the pattern /[^\r]\n$/. There is # no logic in this script that deals with the situation; # you will have to identify it if it exists and figure # out how you want to handle it. # # This is probably not an exhaustive list of issues you'll # face in a migration, but it's a start. # # If you're just migrating from an old version to a newer # version of the same server then you'll probably have # a much easier time of it. # # use Mail::IMAPClient; use Data::Dumper; use IO::File; use File::Basename ; use Getopt::Std; use strict; use vars qw/ $opt_B $opt_D $opt_T $opt_U $opt_W $opt_b $opt_d $opt_h $opt_t $opt_u $opt_w $opt_v $opt_s $opt_S $opt_W $opt_p $opt_P $opt_f $opt_F $opt_m $opt_M /; getopts('vs:S:u:U:dDb:B:f:F:w:W:p:P:t:T:hm:M:'); if ( $opt_h ) { print STDERR <<"HELP"; $0 - an example script demonstrating the use of the Mail::IMAPClient's migrate method. Syntax: $0 -s source_server -u source_user -w source_password -p source_port \ -d debug_source -f source_debugging_file -b source_buffsize \ -t source_timeout -m source_auth_mechanism \ -S target_server -U target_user -W target_password -P target_port \ -D debug_target -F target_debugging_file -B target_buffsize \ -T target_timeout -M target_auth_mechanism \ -v where "source" refers to the "copied from" mailbox, target is the "copied to" mailbox, and -v turns on verbose output. Authentication mechanisms default to "PLAIN". HELP exit; } $opt_v and ++$|; print "$0: Started at ",scalar(localtime),"\n" if $opt_v; $opt_p||=143; $opt_P||=143; # Make a connection to the source mailbox: my $imap = Mail::IMAPClient->new( Server => $opt_s, User => $opt_u, Password=> $opt_w, Uid => 1, Port => $opt_p, Debug => $opt_d||0, Buffer => $opt_b||4096, Fast_io => 1, ( $opt_m ? ( Authmechanism => $opt_m) : () ), Timeout => $opt_t, ($opt_f ? ( Debug_fh=>IO::File->new(">$opt_f" )) : ()), ) or die "$@"; # Make a connection to the target mailbox: my $imap2 = Mail::IMAPClient->new( Server => $opt_S, User => $opt_U, Password=> $opt_W, Port => $opt_P, Uid => 1, Debug => $opt_D||0, ( $opt_M ? ( Authmechanism => $opt_M) : () ), ($opt_F ? ( Debug_fh=>IO::File->new(">$opt_F")) : ()), Buffer => $opt_B||4096, Fast_io => 1, Timeout => $opt_T, # True value ) or die "$@"; # Turn off buffering on debug files: $imap->Debug_fh->autoflush; $imap2->Debug_fh->autoflush; # Get folder hierarchy separator characters from source and target: my $sep1 = $imap->separator; my $sep2 = $imap2->separator; # Find out if source and target support subfolders inside INBOX: my $inferiorFlag1 = $imap->is_parent("INBOX"); my $inferiorFlag2 = $imap2->is_parent("INBOX"); # Set up a test folders to see if the source and target support mixed-use # folders (i.e. folders with both subfolders and mail messages): my $testFolder1 = "Migrate_Test_$$" ; # Ex: Migrate_Test_1234 $testFolder1 = $inferiorFlag2 ? "INBOX" . $sep2 . $testFolder1 : $testFolder1 ; # The following folder will be a subfolder of $testFolder1: my $testFolder2 = "Migrate_Test_$$" . $sep2 . "Migrate_test_subfolder_$$" ; $testFolder2 = $inferiorFlag2 ? "INBOX" . $sep2 . $testFolder2 : $testFolder2 ; $imap2->create($testFolder2) ; # Create the subfolder first; RFC2060 dictates that # the parent folder should be created at the same time # The following line inspired the selectable method. It was also made obsolete by it, # but I'm leaving it as is to demonstrate use of lower-level method calls: my $mixedUse2 = grep(/NoSelect/i,$imap2->list("",$testFolder1))? 0 : 1; # Repeat the above with the source mailbox: $testFolder2 = "Migrate_Test_$$" . $sep1 . "Migrate_test_subfolder_$$" ; $testFolder2 = $inferiorFlag1 ? "INBOX" . $sep1 . $testFolder1 : $testFolder1 ; $imap->create($testFolder2) ; my $mixedUse1 = grep(/NoSelect/i,$imap->list("",$testFolder1))? 0 : 1; print "Imap host $opt_s:$opt_p uses a '$sep1' as a separator and ", ( defined($inferiorFlag1) ? "allows " : "does not allow "), "children in the INBOX. It supports ", ($mixedUse1?"mixed use ":"single use "), "folders.\n" if $opt_v; print "Imap host $opt_S:$opt_P uses a '$sep2' as a separator and ", ( defined($inferiorFlag2) ? "allows " : "does not allow "), "children in the INBOX. It supports ", ($mixedUse2?"mixed use ":"single use "), "folders.\n" if $opt_v; for ($testFolder1,$testFolder2) {$imap->delete($_); $imap2->delete($_);} my($totalMsgs, $totalBytes) = (0,0); # Now we will migrate the folder. Here we are doing one message at a time # so that we can do more granular status reporting and error checking. # A lazier way would be to do all the messages in one migrate method call # (specifying "ALL" as the message number) but then we wouldn't be able # to print out which message we were migrating and it would be a little # bit tougher to control checking for duplicates and stuff like that. # We could also check the size of the message on the target right after # the migrate as an extra safety check if we wanted to but I didn't bother # here. (I saved as an exercise for the reader. Yeah! That's it! An exercise!) # Iterate over all the folders in the source mailbox: for my $f ($imap->folders) { # Select the folder on the source side: $imap->select($f) ; # Massage the foldername into an acceptable target-side foldername: my $targF = ""; my $srcF = $f; $srcF =~ s/^INBOX$sep1//i; if ( $inferiorFlag2 ) { $targF = $srcF eq "INBOX" ? "INBOX" : "INBOX.$f" ; } else { $targF = $srcF ; } $targF =~ s/$sep1/$sep2/go unless $sep1 eq $sep2; $targF =~ tr/#\$\& '"/\@\@+_/; if ( $imap->is_parent($f) and !$mixedUse2 ) { $targF .= "_mail" ; } print "Migrating folder $f to $targF\n" if $opt_v; # Create the (massaged) folder on the target side: unless ( $imap2->exists($targF) ) { $imap2->create($imap2->Massage($targF)) or warn "Cannot create $targF on " . $imap2->Server . ": $@\n" and next; } # ... and select it $imap2->select($imap2->Massage($targF)) or warn "Cannot select $targF on " . $imap2->Server . ": $@\n" and next; # now that we know the target folder is selectable, we can close it again: $imap2->close; my $count = 0; my $expectedTotal = $imap->message_count($f) ; # Now start iterating over all the messages on the source side... for my $msg ($imap->messages) { ++$count; my $h = ""; # Get some basic info about the message: eval { $h = ($imap->parse_headers($msg,"Message-id")||{})->{'Message-id'}[0]}; my $tsize = $imap->size($msg); my $ret = 0 ; my $h2 = []; # Make sure we didn't already migrate the message in a previous pass: $imap2->select($targF); if ( $tsize and $h and $h2 = $imap2->search( HEADER => 'Message-id' => $imap2->Quote($h), NOT => SMALLER => $tsize, NOT => LARGER => $tsize ) ) { print "Skipping $f/$msg to $targF. ", "One or more messages (" ,join(", ",@$h2), ") with the same size and message id ($h) ", "is already on the server. ", "\n" if $opt_v; $imap2->close; } else { print "Migrating $f/$msg to $targF. ", "Message #$count of $expectedTotal has ", $tsize , " bytes.", "\n" if $opt_v; $imap2->close; # Migrate the message: my $ret = $imap->migrate($imap2,$msg,"$targF") ; $ret and ( $totalMsgs++ , $totalBytes += $tsize); $ret or warn "Cannot migrate $f/$msg to $targF on " . $imap2->Server . ": $@\n" ; } } } print "$0: Finished migrating $totalMsgs messages and $totalBytes bytes at ",scalar(localtime),"\n" if $opt_v; exit; =head1 AUTHOR David J. Kernen The Kernen Group, Inc. imap@kernengroup.com =head1 COPYRIGHT This example and Mail::IMAPClient are Copyright (c) 2003 by The Kernen Group, Inc. All rights reserved. This example is distributed with Mail::IMAPClient and subject to the same licensing requirements as Mail::IMAPClient. imtest is a utility distributed with Cyrus IMAP server, Copyright (c) 1994-2000 Carnegie Mellon University. All rights reserved. =cut #$Log: migrate_mail2.pl,v $ #Revision 19991216.4 2003/06/12 21:38:33 dkernen # #Preparing 2.2.8 #Added Files: COPYRIGHT #Modified Files: Parse.grammar #Added Files: Makefile.old # Makefile.PL Todo sample.perldb # BodyStructure.pm # Parse.grammar Parse.pod # range.t # Thread.grammar # draft-crispin-imapv-17.txt rfc1731.txt rfc2060.txt rfc2062.txt # rfc2221.txt rfc2359.txt rfc2683.txt # Mail-IMAPClient-3.38/examples/find_dup_msgs.pl0000755000175000017500000001405212535524202020545 0ustar ppearlppearl#!/usr/local/bin/perl # $Id$ use Mail::IMAPClient; use Mozilla::LDAP::Conn; use Getopt::Std; use vars qw/$rootdn $opt_a/; use Data::Dumper; # It then connects to a user's mailhost and rummages around, # looking for duplicate messages. # It will optionally delete messages that are duplicates (based on # msg-id header and number of bytes). # For help, enter: # find_dup_msgs.pl -h # getopts('ahdtvf:F:u:s:p:P:'); if ( $opt_h ) { print STDERR &usage; exit; } my $uid = $opt_u or die &usage; $opt_s||='localhost'; $opt_p or die &usage; $opt_P||=143; $opt_t and $opt_d and die "ERROR: Don't specify -d and -t together.\n" . &usage; my($pu,$pp) = get_admin(); print "Connecting to $host:$opt_P\n" if $opt_v; my $imap = Imap->new( Server => $opt_s, User => $opt_u, Password=> $opt_p, Port => $opt_P, Fast_io => 1, ) or die "couldn't connect to $host port $opt_P: $!\n"; my %folders; my %counts; FOLDER: foreach my $f ( $opt_F ? $opt_F : $imap->folders ) { next if $opt_t and $f eq 'Trash'; $folders{$f} = 0; $counts{$f} = $imap->message_count($f); print "Processing folder $f\n" if $opt_v; unless ( $imap->select($f)) { warn "Error selecting $f: " . $imap->LastError . "\n"; next FOLDER; } my @msgs = $imap->search("ALL"); my %hash = (); MESSAGE: foreach my $m (@msgs) { my $mid; if ($opt_a) { my $h = $imap->parse_headers( $m,"Date","Subject","From","Message-ID" ) or next MESSAGE; $mid = "$h->{'Date'}[0]$;$h->{'Subject'}[0]$;". "$h->{'From'}[0]$;$h->{'Message-ID'}[0]"; } else { $mid = $imap->parse_headers( $m, "Message-ID" )->{'Message-ID'}[0] or next MESSAGE; } my $size = $imap->size($m); if ( exists $hash{$mid} and $hash{$mid} == $size ) { if ($opt_f) { open F,">>$opt_f" or die "can't open $opt_f: $!\n"; print F $imap->message_string($m), "___END OF SAVED MESSAGE___","\n"; close F; } $imap->move("Trash",$m) if $opt_t; $imap->delete_message($m) if $opt_d; $folders{$f}++; print "Found a duplicate in ${f}; key = $mid\n" if $opt_v; } else { $hash{$mid} = $size; } } print "$f hash:\n",Data::Dumper::Dumper(\%hash) if $opt_v; $imap->expunge if ($opt_t or $opt_d); } my $total; my $totms; map { $total += $_} values %folders; map { $totms += $_ } values %counts; print "Found $total duplicate messages in ${uid}'s mailbox. ", "The breakdown is:\n", "\tFolder\tNumber of Duplicates\tNumber of Msgs in Folder\n", "\t------\t--------------------\t------------------------\n", map { "\t$_\t$folders{$_}\t$counts{$_}\n" } keys %folders, "\tTOTAL\t$total\t$totms\n" ; sub usage { return "Usage:\n" . "\t$0 [-d|-t] [-v] [-f filename] [-a] [-P port] \\\n". "\t\t-s server -u user -p password\n\n" . "\t-a\t\tdo an especially aggressive search for duplicates\n". "\t-d\t\tdelete duplicates (default is to just report them)\n". "\t-f file\t\tsave deleted messages in file named 'file'\n" . "\t-F fldr\t\tOnly check the folder named 'fldr' (default is to check all folders)\n" . "\t-h\t\tprint this help message (all other options are ignored)\n" . "\t-p password\tspecify the target user's password\n" . "\t-P port\t\tspecify the port to connect to (default is 143)\n" . "\t-s server\tspecify the target mail server\n" . "\t-u uid\t\tspecify the target user\n" . "\t-t\t\tmove deleted messages to trash folder\n" . "\t-v\t\tprint verbose status messages while processing\n". "\n" ; } =head1 AUTHOR David J. Kernen The Kernen Group, Inc. imap@kernengroup.com =head1 COPYRIGHT This example and Mail::IMAPClient are Copyright (c) 2003 by The Kernen Group, Inc. All rights reserved. This example is distributed with Mail::IMAPClient and subject to the same licensing requirements as Mail::IMAPClient. imtest is a utility distributed with Cyrus IMAP server, Copyright (c) 1994-2000 Carnegie Mellon University. All rights reserved. =cut # History: # $Log: find_dup_msgs.pl,v $ # Revision 19991216.5 2003/06/12 21:38:32 dkernen # # Preparing 2.2.8 # Added Files: COPYRIGHT # Modified Files: Parse.grammar # Added Files: Makefile.old # Makefile.PL Todo sample.perldb # BodyStructure.pm # Parse.grammar Parse.pod # range.t # Thread.grammar # draft-crispin-imapv-17.txt rfc1731.txt rfc2060.txt rfc2062.txt # rfc2221.txt rfc2359.txt rfc2683.txt # # Revision 1.1 2003/06/12 21:38:14 dkernen # # Preparing 2.2.8 # Added Files: COPYRIGHT # Modified Files: Parse.grammar # Added Files: Makefile.old # Makefile.PL Todo sample.perldb # BodyStructure.pm # Parse.grammar Parse.pod # range.t # Thread.grammar # draft-crispin-imapv-17.txt rfc1731.txt rfc2060.txt rfc2062.txt # rfc2221.txt rfc2359.txt rfc2683.txt # # Revision 19991216.4 2002/08/23 14:34:51 dkernen # # Modified Files: Changes IMAPClient.pm Makefile Makefile.PL test.txt for version 2.2.0 # Added Files: Makefile Makefile.PL Parse.grammar Parse.pm Parse.pod version 2.2.0 # Added Files: parse.t for version 2.2.0 # Added Files: bodystructure.t for 2.2.0 # Modified Files: find_dup_msgs.pl for v2.2.0 # # Revision 1.6 2001/03/08 19:00:35 dkernen # # ---------------------------------------------------------------------- # Modified Files: # copy_folder.pl delete_mailbox.pl find_dup_msgs.pl # mbox_check.pl process_orphans.pl rename_id.pl # scratch_indexes.pl # to get ready for nsusmsg02 upgrade # ---------------------------------------------------------------------- # # Revision 1.5 2000/11/01 15:51:58 dkernen # # Modified Files: copy_folder.pl find_dup_msgs.pl restore_mbox.pl # # Revision 1.4 2000/04/13 21:17:18 dkernen # # Modified Files: find_dup_msgs.pl - to add -a switch (for aggressive dup search) # Added Files: copy_folder.pl - a utility for copying a folder from one user's # mailbox to another's # # Revision 1.3 2000/03/14 16:40:21 dkernen # # Modified Files: find_dup_msgs.pl -- to skip msgs with no message-id # # Revision 1.2 2000/03/13 19:05:50 dkernen # # Modified Files: # delete_mailbox.pl find_dup_msgs.pl restore_mbox.pl -- to add cvs comments # find_dup_msgs.pl -- to fix bug that occurred when -t (move-to-trash) switch is used # Mail-IMAPClient-3.38/examples/populate_mailbox.pl0000755000175000017500000002161712535524202021275 0ustar ppearlppearl#!/usr/local/bin/perl #$Id$ # use Time::Local ; use FileHandle ; use File::Copy ; use Mail::IMAPClient; use Sys::Hostname ; # my $default_user = 'default' ; my $default_pswd = 'default' ; # ######################################################################### # ARGS: DATE = YYYYMMDDHHMM (defaults to current system date) # # UID = IMAP account id (defaults to $default_user) # # PSWD = uid's password (defaults to $default_pswd) # # HOST = Target host (defaults to localhost) # # CLEAN = 1 (defaults to 0; used to clean out mailbox 1st) # # CLEANONLY= 1 (defaults to 0; if 1 then only CLEAN is done) # # DOMAIN = x.com (no default) the mail domain for UID's address # # # # EG: populate_mailbox.pl DATE=200001010100 UID=testuser # # # ######################################################################### # (my($x)= join(" ",@ARGV)) ; $x=~s~=~ ~g ; chomp($x) ; # my %hash = split(/\s+/, $x) if $x ; # while (my ($k,$v) = each %hash ) { $hash{uc $k} = $v ; } while (my ($k,$v) = each %hash ) { delete $hash{$k} if $k =~ tr/[a-z]// ; } ; $hash{UID} ||= "$default_user" ; $hash{PSWD} ||= "$default_pswd" ; $hash{HOST} ||= hostname ; # while (my ($k,$v) = each %hash ) { print "Running with $k set to $v\n" ; } # my $domain = $hash{DOMAIN} or die "No mail domain provided.\n" ; my $now = seconds($hash{DATE}) || time ; # my $six = $now - ( 6 * 24 * 60 * 60 ) ; my $seven = $now - ( 7 * 24 * 60 * 60 ) ; my $notthirty = $now - ( 29 * 24 * 60 * 60 ) ; my $thirty = $now - ( 30 * 24 * 60 * 60 ) ; my $notsixty = $now - ( 59 * 24 * 60 * 60 ) ; my $sixty = $now - ( 60 * 24 * 60 * 60 ) ; my $notd365 = $now - ( 364 * 24 * 60 * 60 ) ; my $d365 = $now - ( 365 * 24 * 60 * 60 ) ; # $hash{SUBJECTS} = [ "Sixty days old", "Less than sixty days old" , "365 days old", "Less than 365 days old" , "Trash/Incinerator -- 7 days old" , "Sent -- 29 days old" , "Sent -- 30 days old" , "Trash -- 6 days old" , ] ; $hash{FOLDERS} = [ "Sent", "INBOX", "Trash" , "365_folder", "Trash/Incinerator" , "not_365_folder" , ] ; # &clean_mailbox if $hash{CLEANONLY} || $hash{CLEAN} ; exit if $hash{CLEANONLY} ; # #send to: date: subject: # #-------- --- ----- --------- # sendmail( $hash{UID}, $sixty, "Sixty days old" ) ; sendmail( $hash{UID}, $notsixty, "Less than sixty days old") ; sendmail( $hash{UID}, $d365, "365 days old" ) ; sendmail( $hash{UID}, $notd365, "Less than 365 days old" ) ; # populate_trash("Trash/Incinerator",$hash{UID}, $seven, 7 ) ; populate_trash( "Trash" , $hash{UID}, $six, 6 ) ; populate_trash( "Sent" , $hash{UID}, $thirty, 30 ) ; populate_trash( "Sent" , $hash{UID}, $notthirty, 29 ) ; # movemail( "365 days old" , "365_folder" ) ; # movemail( "Less than 365 days old" , "not_365_folder" ) ; # exit ; # # sub seconds { my $d = shift or return undef ; my($yy,$moy,$dom,$hr,$min) = # $d =~ m! ^ # anchor at start # (\d\d\d\d) # year # (\d\d) # month # (\d\d) # day # (\d\d) # hour # (\d\d) # minute # !x ; # return timegm(0,$min,$hr,$dom,$moy-1,($yy>99?$yy-1900:$yy)) ; } # sub sendmail { # my($to,$date,$subject) = @_ ; my $text = <new ( Server => $hash{HOST} , User => $hash{UID} , Password=> $hash{PSWD} ) or die "can't connect: $!\n" ; # $imap->append("INBOX",$text) ; $imap->logout ; } } # sub populate_trash { my $where = shift ; my $to = shift ; my $date = shift ; my $d = shift ; # my($ss,$min,$hr,$day,$mon,$year)=gmtime($date) ; $mon++ ; $year += 1900 ; my $fn =sprintf("%4.4d%2.2d%2.2d%2.2d%2.2d%2.2d" , $year,$mon,$day,$hr,$min,$ss ) ; my $x = 0 ; my $subject = "$where -- $d days old" ; while ($x++ < 10) { my $fh ; $fh .= "Date: @{[&rfc822_date($date)]}\n" ; $fh .= <new ( Server => $hash{HOST} , User => $hash{UID} , Password=> $hash{PSWD} ) or die "can't connect: $!\n" ; $imap->append($where, $fh) ; # } # } # sub movemail { # my ($subj,$fold) = @_ ; my $fh = Mail::IMAPClient->new ( Debug => 0 , Server => $hash{HOST} , User => $hash{UID} , Password => $hash{PSWD} , ) ; # $fh->select("inbox") or die "cannot open inbox: $!\n" ; # foreach my $f ($fh->search(qq(SUBJECT "$subj")) ) { # $fh->move($fold,$f) ; # } # } # sub clean_mailbox { # my $fh =Mail::IMAPClient->new ( Debug => 0 , Server => $hash{HOST} , User => $hash{UID} , Password => $hash{PSWD} , ) ; for my $x (@{$hash{FOLDERS}}) { my @msgs ; $fh->create($x) unless $fh->exists($x) ; $fh->select($x) ; for my $s (@{$hash{SUBJECTS}}) { push @msgs, $fh->search(qq(SUBJECT "$s")) ; } $fh->delete_message(@msgs) if scalar(@msgs) ; $fh->expunge ; } } # sub rfc822_date { #Date: Fri, 09 Jul 1999 13:10:55 -0400 # my $date = shift ; my @date = localtime($date) ; my @dow = qw{ Sun Mon Tue Wed Thu Fri Sat } ; my @mnt = qw{ Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec} ; # return sprintf ( "%s, %2.2d %s %4.4s %2.2d:%2.2d:%2.2d -0400" , $dow[$date[6]] , $date[3] , $mnt[$date[4]] , $date[5]+=1900 , $date[2] , $date[1] , $date[0] ) ; } =head1 AUTHOR David J. Kernen The Kernen Group, Inc. imap@kernengroup.com =head1 COPYRIGHT This example and Mail::IMAPClient are Copyright (c) 2003 by The Kernen Group, Inc. All rights reserved. This example is distributed with Mail::IMAPClient and subject to the same licensing requirements as Mail::IMAPClient. imtest is a utility distributed with Cyrus IMAP server, Copyright (c) 1994-2000 Carnegie Mellon University. All rights reserved. =cut # $Id$ # $Log: populate_mailbox.pl,v $ # Revision 19991216.8 2003/06/12 21:38:34 dkernen # # Preparing 2.2.8 # Added Files: COPYRIGHT # Modified Files: Parse.grammar # Added Files: Makefile.old # Makefile.PL Todo sample.perldb # BodyStructure.pm # Parse.grammar Parse.pod # range.t # Thread.grammar # draft-crispin-imapv-17.txt rfc1731.txt rfc2060.txt rfc2062.txt # rfc2221.txt rfc2359.txt rfc2683.txt # # Revision 1.1 2003/06/12 21:38:16 dkernen # # Preparing 2.2.8 # Added Files: COPYRIGHT # Modified Files: Parse.grammar # Added Files: Makefile.old # Makefile.PL Todo sample.perldb # BodyStructure.pm # Parse.grammar Parse.pod # range.t # Thread.grammar # draft-crispin-imapv-17.txt rfc1731.txt rfc2060.txt rfc2062.txt # rfc2221.txt rfc2359.txt rfc2683.txt # # Revision 19991216.7 2002/08/23 13:29:49 dkernen # # Modified Files: Changes IMAPClient.pm INSTALL MANIFEST Makefile Makefile.PL README Todo test.txt # Made changes to create version 2.1.6. # Modified Files: # imap_to_mbox.pl populate_mailbox.pl # Added Files: # cleanTest.pl migrate_mbox.pl # # Revision 19991216.6 2000/12/11 21:58:53 dkernen # # Modified Files: # build_dist.pl build_ldif.pl copy_folder.pl find_dup_msgs.pl # imap_to_mbox.pl populate_mailbox.pl # to add CVS data # # Revision 19991216.5 1999/12/16 17:19:15 dkernen # Bring up to same level # # Revision 19991124.3 1999/12/16 17:14:26 dkernen # Incorporate changes for exists method performance enhancement # # Revision 19991124.02 1999/11/24 17:46:21 dkernen # More fixes to t/basic.t # # Revision 19991124.01 1999/11/24 16:51:51 dkernen # Changed t/basic.t to test for UIDPLUS before trying UID cmds # # Revision 1.4 1999/11/23 17:51:06 dkernen # Committing version 1.06 distribution copy # Mail-IMAPClient-3.38/examples/copy_folder.pl0000755000175000017500000000773512535524202020243 0ustar ppearlppearl#!/usr/local/bin/perl #$Id$ ++$|; use Getopt::Std; use Mail::IMAPClient; use vars qw/$opt_r $opt_h $opt_t $opt_f/; getopts("t:f:F:N:rh"); if ( $opt_h ) { print &usage; exit; } my($to_id,$to_pass,$thost) = $opt_t =~ m{ ([^/]+) # everything up to / is the id / # then a slash ([^@]+) # then everything up to @ is pswd @ # then an @-sign (.*) # then everything else is the host }x ; my($from_id,$from_pass,$fhost) = $opt_f =~ m{ ([^/]+) # everything up to / is the id / # then a slash ([^@]+) # then everything up to @ is pswd @ # then an @-sign (.*) # then everything else is the host }x ; $to_id and $from_id and $to_pass and $from_pass and $thost and $fhost or die "Error: Must specify -t and -f (to and from)\n" . &usage; $opt_F or die "Error: Must specify '-F folder' or how will I know what folder to copy?\n" . &usage ; $opt_N ||= $opt_F; print "Copying folder $opt_F from $from_id\@$fhost to ${to_id}'s $opt_N folder on $thost.\n"; my ($from) = Mail::IMAPClient->new( Server => $fhost, User => $from_id, Password=> $from_pass, Fast_IO => 1, Uid => 1, Debug => 0, ); my ($to) = Mail::IMAPClient->new( Server => $thost, User => $to_id, Password=> $to_pass, Fast_IO => 1, Uid => 1, Debug => 0, ); my @folders = $opt_r ? @{$from->folders($opt_F)} : ( $opt_F ) ; foreach my $fold (@folders) { print "Processing folder $fold\n"; $from->select($fold); if ($opt_F ne $opt_N) { $fold =~s/^$opt_F/$opt_N/o; } unless ($to->exists($fold)) { $to->create($fold) or warn "Couldn't create $fold\n" and next; } $to->select($fold); my @msgs = $from->search("ALL"); # my %flaghash = $from->flags(\@msgs); foreach $msg (@msgs) { print "Processing message $msg in folder $fold.\n"; my $string = $from->message_string($msg); # print "String = $string\n"; my $new_id = $to->append($fold,$string) or warn "Couldn't append msg #$msg to target folder $fold.\n"; $to->store($new_id,"+FLAGS (" . join(" ",@{$from->flags($msg)}) . ")"); } } sub usage { return "Syntax:\n\t$0 -t to_id/to_pass\@to.host -f from_id/from_pass\@from.host \\\n" . "\t\t-F folder [-N New_Folder] [-r]\n". "\tor\n\t$0 -h\n\n". "\twhere:\n\t\t". "to_id\t\tis the id to recieve the folder\n\t\t". "to_pass\t\tis the password for to_id\n\t\t". "from\t\tis the uid who currently has the folder\n\t\t". "from_pass\tis the password for from_id\n\t\t". "to.host\t\tis the optional host where the 'to' uid has a mailbox\n\t\t". "from.host\tis the optional host where the 'from' uid has a mailbox\n\t\t". "folder\t\tis the folder to copy from\n\t\t". "New_Folder\tis the folder to copy to (defaults to 'folder')\n\t\t". "-h\t\tprints this help message\n\t\t". "-r\t\tspecifies a recursive copy (only works on systems that support the idea " . "\n\t\t\t\tof recursive folders)\n\t\t". "\n" ; } =head1 AUTHOR David J. Kernen The Kernen Group, Inc. imap@kernengroup.com =head1 COPYRIGHT This example and Mail::IMAPClient are Copyright (c) 1999,2000,2003 by The Kernen Group, Inc. All rights reserved. This example is distributed with Mail::IMAPClient and subject to the same licensing requirements as Mail::IMAPClient. imtest is a utility distributed with Cyrus IMAP server, Copyright (c) 1994-2000 Carnegie Mellon University. All rights reserved. =cut # History: # $Log: copy_folder.pl,v $ # Revision 19991216.3 2003/06/12 21:38:30 dkernen # # Preparing 2.2.8 # Added Files: COPYRIGHT # Modified Files: Parse.grammar # Added Files: Makefile.old # Makefile.PL Todo sample.perldb # BodyStructure.pm # Parse.grammar Parse.pod # range.t # Thread.grammar # draft-crispin-imapv-17.txt rfc1731.txt rfc2060.txt rfc2062.txt # rfc2221.txt rfc2359.txt rfc2683.txt # # Revision 19991216.2 2000/12/11 21:58:51 dkernen # # Modified Files: # build_dist.pl build_ldif.pl copy_folder.pl find_dup_msgs.pl # imap_to_mbox.pl populate_mailbox.pl # to add CVS data # Mail-IMAPClient-3.38/examples/idle.pl0000755000175000017500000001500412563153330016640 0ustar ppearlppearl#!/usr/bin/perl =head1 NAME idle.pl - example using IMAP idle =head1 SYNOPSIS idle.pl [options] Options: [*] == Required, [+] == Multiple vals OK, (val) == Default --o Server= *IMAP server name/IP --o User= *User account to login to --o Password= *Password to use for the User account (see security note below) --o Port= port on Server to connect to --o Ssl= use SSL on this connection --o Starttls= call STARTTLS on this connection --o Debug= enable debugging in Mail::IMAPClient --o ImapclientKey=Val any other Mail::IMAPClient attribute/value pair --folder folder (mailbox) to IMAP SELECT (INBOX) --maxidle maximum time to idle without receiving data (300) --help display a brief help message --man display the entire man page --debug enable script debugging =head1 NOTES =head2 --o Password= A password specified as a command-line option may be visible to other users via the system process table. It may alternately be given in the PASSWORD environment variable. =head2 --maxidle RFC 2177 states, "The server MAY consider a client inactive if it has an IDLE command running, and if such a server has an inactivity timeout it MAY log the client off implicitly at the end of its timeout period. Because of that, clients using IDLE are advised to terminate the IDLE and re-issue it at least every 29 minutes to avoid being logged off." The default of --maxidle 300 is used to allow the client to notice when a connection has silently been closed upstream due to network or firewall issue or configuration without missing too many idle events. =cut use strict; use warnings; use File::Basename qw(basename); use Getopt::Long qw(GetOptions); use Mail::IMAPClient qw(); use Pod::Usage qw(pod2usage); use POSIX qw(); use constant { FOLDER => "INBOX", MAXIDLE => 300, }; $| = 1; # set autoflush my $DEBUG = 0; # GLOBAL set by process_options() my $QUIT = 0; my $VERSION = "1.00"; my $Prog = basename($0); ### # main program main(); sub main { my %Opt = process_options(); pout("started $Prog\n"); my $imap = Mail::IMAPClient->new( %{ $Opt{opt} } ) or die("$Prog: error: Mail::IMAPClient->new: $@\n"); my ( $folder, $chkseen, $tag ) = ( $Opt{folder}, 1, undef ); $imap->select($folder) or die("$Prog: error: select '$folder': $@\n"); $SIG{'INT'} = \&sigint_handler; until ($QUIT) { unless ( $imap->IsConnected ) { warn("$Prog: reconnecting due to error: $@\n") if $imap->LastError; $imap->connect or last; $imap->select($folder) or last; $tag = undef; } my $ret; if ($chkseen) { $chkseen = 0; # end idle if necessary if ($tag) { $tag = undef; $ret = $imap->done or last; } my $unseen = $imap->unseen_count; last if $@; pout("$unseen unseen/new message(s) in '$folder'\n") if $unseen; } # idle for X seconds unless data was returned by done unless ($ret) { $tag ||= $imap->idle or die("$Prog: error: idle: $@\n"); warn( "$Prog: DEBUG: ", _ts(), " do idle_data($Opt{maxidle})\n" ) if $DEBUG; $ret = $imap->idle_data( $Opt{maxidle} ) or last; # connection can go stale so we exit/re-enter of idle state # - RFC 2177 mentions 29m but firewalls may be more strict unless (@$ret) { warn( "$Prog: DEBUG: ", _ts(), " force exit of idle\n" ) if $DEBUG; $tag = undef; # restarted lost connections on next iteration $ret = $imap->done or next; } } local ( $1, $2, $3 ); foreach my $resp (@$ret) { $resp =~ s/\015?\012$//; warn("$Prog: DEBUG: server response: $resp\n") if $DEBUG; # ignore: # - DONE command # - OK IDLE... next if ( $resp eq "DONE" ); next if ( $resp =~ /^\w+\s+OK\s+IDLE\b/ ); if ( $resp =~ /^\*\s+(\d+)\s+(EXISTS)\b/ ) { my ( $num, $what ) = ( $1, $2 ); pout("$what: $num message(s) in '$folder'\n"); $chkseen++; } elsif ( $resp =~ /^\*\s+(\d+)\s+(EXPUNGE)\b/ ) { my ( $num, $what ) = ( $1, $2 ); pout("$what: message $num from '$folder'\n"); } # * 83 FETCH (FLAGS (\Seen)) elsif ( $resp =~ /^\*\s+(\d+)\s+(FETCH)\s+(.*)/ ) { my ( $num, $what, $info ) = ( $1, $2, $3 ); $chkseen++ if ( $info =~ /[\(|\s]\\Seen[\)|\s]/ ); pout("$what: message $num from '$folder': $info\n"); } else { pout("server response: $resp\n"); } } } my $rc = 0; if ($@) { if ($QUIT) { warn("$Prog: caught signal\n"); } else { $rc = 1; } warn("$Prog: imap error: $@\n") if ( !$QUIT || $DEBUG ); } exit($rc); } ### # supporting routines sub pout { print( _ts(), " ", @_ ); } sub process_options { my ( %Opt, @err ); GetOptions( \%Opt, "opt=s%", "debug:1", "help", "man", "folder=s", "maxidle:i" ) or pod2usage( -verbose => 0 ); pod2usage( -message => "$Prog: version $VERSION\n", -verbose => 1 ) if ( $Opt{help} ); pod2usage( -verbose => 2 ) if ( $Opt{man} ); # set global DEBUG $DEBUG = $Opt{debug} || 0; # folder (mailbox) to watch $Opt{folder} = FOLDER unless ( exists $Opt{folder} ); # restart idle when no idle_data seen for this long $Opt{maxidle} = MAXIDLE unless ( exists $Opt{maxidle} ); $Opt{opt}->{Password} = $ENV{PASSWORD} if ( !exists $Opt{opt}->{Password} && defined $ENV{PASSWORD} ); foreach my $arg (qw(Server User Password)) { push( @err, "-o $arg= is required" ) if !exists $Opt{opt}->{$arg}; } pod2usage( -verbose => 1, -message => join( "", map( "$Prog: $_\n", @err ) ) ) if (@err); return %Opt; } # example: 2005-10-02 07:50:32 sub _ts { my %opt = @_; my $fmt = $opt{fmt} || "%Y-%m-%d %T"; return POSIX::strftime( $fmt, localtime(time) ); } sub sigint_handler { $QUIT = 1; } Mail-IMAPClient-3.38/examples/cyrus_expunge.pl0000755000175000017500000000404312535524202020623 0ustar ppearlppearl#!/usr/local/bin/perl #$Id$ use Mail::IMAPClient; use IO::File; # Change the following line (or replace it with something better): my($h,$u,$p) = ('cyrus_host','cyrus_admin_id','cyrus_admin_pswd'); my $imap = Mail::IMAPClient->new( Server => "$h", # imap host User => "$u", # $u, Password=> "$p", # $p, Uid => 1, # True value Port => 143, # Cyrus Debug => 0, # True value Buffer => 4096*10, # True value Fast_io => 1, # True value Timeout => 30, # True value # Debug_fh=> IO::File->new(">out.db"), # fhandle ) or die "$@"; for my $f ( $imap->folders ) { print "Expunging $f\n"; unless ($imap->select($f) ) { $imap->setacl($f,$u,"lrswipcda") or warn "Cannot setacl for $f: $@\n" and next; $imap->select($f) or warn "Cannot select $f: $@" and next; } $imap->expunge; } =head1 AUTHOR David J. Kernen The Kernen Group, Inc. imap@kernengroup.com =head1 COPYRIGHT This example and Mail::IMAPClient are Copyright (c) 2003 by The Kernen Group, Inc. All rights reserved. This example is distributed with Mail::IMAPClient and subject to the same licensing requirements as Mail::IMAPClient. imtest is a utility distributed with Cyrus IMAP server, Copyright (c) 1994-2000 Carnegie Mellon University. All rights reserved. =cut # #$Log: cyrus_expunge.pl,v $ #Revision 19991216.3 2003/06/12 21:38:31 dkernen # #Preparing 2.2.8 #Added Files: COPYRIGHT #Modified Files: Parse.grammar #Added Files: Makefile.old # Makefile.PL Todo sample.perldb # BodyStructure.pm # Parse.grammar Parse.pod # range.t # Thread.grammar # draft-crispin-imapv-17.txt rfc1731.txt rfc2060.txt rfc2062.txt # rfc2221.txt rfc2359.txt rfc2683.txt # #Revision 1.1 2003/06/12 21:38:14 dkernen # #Preparing 2.2.8 #Added Files: COPYRIGHT #Modified Files: Parse.grammar #Added Files: Makefile.old # Makefile.PL Todo sample.perldb # BodyStructure.pm # Parse.grammar Parse.pod # range.t # Thread.grammar # draft-crispin-imapv-17.txt rfc1731.txt rfc2060.txt rfc2062.txt # rfc2221.txt rfc2359.txt rfc2683.txt # # Mail-IMAPClient-3.38/examples/cleanTest.pl0000755000175000017500000000362312535524202017650 0ustar ppearlppearl#!/usr/local/bin/perl use Mail::IMAPClient; use IO::File; # # Example that will also clean out your test account if interrupted 'make test' # runs have left junk folders there. Run from installation dir, installation/examples # subdir, or supply full path to the test.txt file (created during 'perl Makefile.PL' # and left in the installation dir until 'make clean'). # If you 've already run 'make clean' or said no to extended tests, # then you don't have the file anyway; re-run 'perl Makefile.PL', reply 'y' to the # extended tests prompt, then supply the test account's credentials as prompted. # Then try this again. # if ( -f "./test.txt" ) { $configFile = "./test.txt" } elsif ( -f "../test.txt" ) { $configFile = "../test.txt" } elsif ( $ARGV[0] and -f "$ARGV[0]" ) { $configFile = $ARGV[0]; } else { print STDERR "Can't find test.txt. Please run this from the installation directory ", "or supply the full path to test.txt as an argument on the command line.\n"; } my $fh = IO::File->new("./test.txt") or die "./test.txt: $!\n"; while (my $input = <$fh>) { chomp $input; my($k,$v) = split(/=/,$input,2); $conf{$k}=$v; } my $imap = Mail::IMAPClient->new(Server=>$conf{server},User=>$conf{user}, Password=>$conf{passed}) or die "Connecting to $conf{server}: $! $@\n"; for my $f ( grep(/^IMAPClient_/,$imap->folders) ) { print "Deleting $f\n"; $imap->select($f); $imap->delete_messages(@{$imap->messages}) ; $imap->close($f); $imap->delete($f); } =head1 AUTHOR David J. Kernen The Kernen Group, Inc. imap@kernengroup.com =head1 COPYRIGHT This example and Mail::IMAPClient are Copyright (c) 2003 by The Kernen Group, Inc. All rights reserved. This example is distributed with Mail::IMAPClient and subject to the same licensing requirements as Mail::IMAPClient. imtest is a utility distributed with Cyrus IMAP server, Copyright (c) 1994-2000 Carnegie Mellon University. All rights reserved. =cut Mail-IMAPClient-3.38/examples/build_ldif.pl0000755000175000017500000001367612535524202020034 0ustar ppearlppearl#!/usr/local/bin/perl #$Id$ use Mail::IMAPClient; use MIME::Lite; use Data::Dumper; =head1 DESCRIPTION B accepts the name of a target folder as an argument. It then opens that folder and rummages through all the mail files in it, looking for "Reply-to:" headers (or "From:" headers, where there is no "Reply-to:"). It then prints to STDOUT a file in ldif format containing entries for all of the addresses that it finds. It also appends a message into the specified folder containing all of the addresses in both the B field of the message header and in an LDIF-format attachment. B requires B. =head1 SYNTAX B I<-h> B I<-s servername -u username -p password -f folder [ -d ]> =over 4 =item -f The folder name to process. =item -s The servername of the IMAP server =item -t Include "To" and "Cc" fields as well as "From" =item -u The user to log in as =item -p The password for the user specified in the I<-u> option =item -d Tells the IMAP client to turn on debugging info =item -n Suppress delivering message to folder =item -h Prints out this document =back B You can supply defaults for the above options by updating the script. =cut use Getopt::Std; getopts('hs:u:p:f:dtn'); # Update the following to supply defaults: $opt_f ||= "default folder"; $opt_s ||= "default server"; $opt_u ||= "default user"; $opt_p ||= "default password"; # security risk: use with caution! # Let the compiler know we're serious about these variables: $opt_0 = ( $opt_h or $opt_d or $opt_t or $opt_n or $opt_0); exec "perldoc $0" if $opt_h; my $imap = Mail::IMAPClient->new( Server => $opt_s , User => $opt_u , Password=> $opt_p , Debug => $opt_d||0 , ) or die "can't connect to server\n"; $imap->select($opt_f); $imap->expunge; my @msgs = $imap->search("NOT SUBJECT",qq("buid_ldif.pl $opt_f Output")); my %list; foreach my $m (@msgs) { my $ref = $imap->parse_headers($m,"Reply-to","From"); warn "Couldn't get recipient address from msg#$m\n" unless scalar(@{$ref->{'Reply-to'}}) || scalar(@{$ref->{'From'}}) ; my $from = scalar(@{$ref->{'Reply-to'}}) ? $ref->{'Reply-to'}[0] : $ref->{'From'}[0] ; my $name = $from ; $name =~ s/<.*// ; if ($name =~ /\@/) { $name = $from ; $name =~ s/\@.*//; ; } $name =~ s/\"//g ; $name =~ s/^\s+|\s+$//g ; my $addr = $from ; $addr =~ s/.*]//g ; $list{lc($addr)} = [ $addr, $name ] unless exists $list{lc($addr)} ; if ($opt_t) { # Do "To" and "Cc", too my $ref = $imap->parse_headers($m,"To","Cc") ; my @array = ( @{$ref->{To}} , @{$ref->{Cc}} ) ; my @members = () ; foreach my $text (@array) { while ( $text =~ / "([^"\\]*(\\.[^"\\]*)*"[^,]*),? | ([^",]+),? | , /gx ) { push @members, defined($1)?$1:$3 ; } } foreach my $to (@members) { my $name = $to ; $name =~ s/<.*// ; if ($name =~ /\@/) { $name = $to ; $name =~ s/\@.*//; ; } $name =~ s/\"//g ; $name =~ s/^\s+|\s+$//g ; my $addr = $to ; $addr =~ s/.*]//g ; $list{lc($addr)} = [ $addr, $name ] unless exists $list{lc($addr)} ; } } } my $text = join "",map { qq{dn: cn="} . $list{$_}[1] . qq{", mail=$list{$_}[0]\n} . qq{cn: } . $list{$_}[1] . qq{\n} . qq{mail: $list{$_}[0]\n} . qq{objectclass: top\nobjectclass: person\n\n}; } keys %list ; # Create a new multipart message: my $msg = MIME::Lite->new( From => $opt_u, map({ ("To" => $list{$_}[0]) } keys %list), Subject => "LDIF file from $opt_f", Type =>'TEXT', Data =>"Attached is the LDIF file of addresses from folder $opt_f." ); $msg->attach( Type =>'text/ldif', Filename => "$opt_f.ldif", Data => $text , ); print $text; $imap->append($opt_f, $msg->as_string) unless $opt_n; print Dumper($imap) if $opt_d; $imap->logout; =head1 AUTHOR David J. Kernen The Kernen Group, Inc. imap@kernengroup.com =head1 COPYRIGHT This example and Mail::IMAPClient are Copyright (c) 1999,2003 by The Kernen Group, Inc. All rights reserved. This example is distributed with Mail::IMAPClient and subject to the same licensing requirements as Mail::IMAPClient. imtest is a utility distributed with Cyrus IMAP server, Copyright (c) 1994-2000 Carnegie Mellon University. All rights reserved. =cut # $Id$ # $Log: build_ldif.pl,v $ # Revision 19991216.11 2003/06/12 21:38:30 dkernen # # Preparing 2.2.8 # Added Files: COPYRIGHT # Modified Files: Parse.grammar # Added Files: Makefile.old # Makefile.PL Todo sample.perldb # BodyStructure.pm # Parse.grammar Parse.pod # range.t # Thread.grammar # draft-crispin-imapv-17.txt rfc1731.txt rfc2060.txt rfc2062.txt # rfc2221.txt rfc2359.txt rfc2683.txt # # Revision 19991216.10 2002/05/24 15:47:18 dkernen # Misc fixes # # Revision 19991216.9 2000/12/11 21:58:51 dkernen # # Modified Files: # build_dist.pl build_ldif.pl copy_folder.pl find_dup_msgs.pl # imap_to_mbox.pl populate_mailbox.pl # to add CVS data # # Revision 19991216.8 2000/03/02 19:57:13 dkernen # # Modified Files: build_ldif.pl -- to support new option to all "To:" and "Cc:" to be included in ldif file # # Revision 19991216.7 2000/02/21 16:16:10 dkernen # # Modified Files: build_ldif.pl -- to allow for "To:" and "Cc:" header handling and # to handle quoted names in headers # # Revision 19991216.6 1999/12/28 13:56:59 dkernen # Fixed -h option (help). # # Revision 19991216.5 1999/12/16 17:19:10 dkernen # Bring up to same level # # Revision 19991124.3 1999/12/16 17:14:24 dkernen # Incorporate changes for exists method performance enhancement # # Revision 19991124.02 1999/11/24 17:46:18 dkernen # More fixes to t/basic.t # # Revision 19991124.01 1999/11/24 16:51:48 dkernen # Changed t/basic.t to test for UIDPLUS before trying UID cmds # # Revision 1.8 1999/11/23 17:51:05 dkernen # Committing version 1.06 distribution copy # Mail-IMAPClient-3.38/examples/build_dist.pl0000755000175000017500000001012512535524202020043 0ustar ppearlppearl#!/usr/local/bin/perl #$Id$ use Mail::IMAPClient; =head1 DESCRIPTION B accepts the name of a target folder as an argument. It then opens that folder and rummages through all the mail files in it, looking for "Reply-to:" headers (or "From:" headers, where there is no "Reply-to:"). It then appends a message into the folder containing all of the addresses in thus found as a list of recipients. This message can be used to conveniently drag and drop names into an address book, distribution list, or e-mail message, using the GUI client of choice. The email appended to the folder specified in the I<-f> option will have the subject "buid_dist.pl I Output". =head1 SYNTAX b I<-h> b I<-s servername -u username -p password -f folder [ -d ]> =over 4 =item -f The folder name to process. =item -s The servername of the IMAP server =item -u The user to log in as =item -p The password for the user specified in the I<-u> option =item -d Tells the IMAP client to turn on debugging info =item -h Prints out this document =back B You can supply defaults for the above options by updating the script. =cut use Getopt::Std; getopts('s:u:p:f:d'); # Update the following to supply defaults: $opt_f ||= "default folder"; $opt_s ||= "default server"; $opt_u ||= "default user"; $opt_p ||= "default password"; # security risk: use with caution! # Let the compiler know we're serious about these two variables: $opt_h = $opt_h or $opt_d = $opt_d ; exec "perldoc $0" if $opt_h; my $imap = Mail::IMAPClient->new( Server => $opt_s , User => $opt_u , Password=> $opt_p , Debug => $opt_d||0 , ) or die "can't connect to server\n"; $imap->select($opt_f); my @msgs = $imap->search("NOT SUBJECT",qq("buid_dist.pl $opt_f Output")); my %list; foreach my $m (@msgs) { my $ref = $imap->parse_headers($m,"Reply-to","From"); warn "Couldn't get recipient address from msg#$m\n" unless scalar(@{$ref->{'Reply-to'}}) || scalar(@{$ref->{'From'}}) ; my $from = scalar(@{$ref->{'Reply-to'}}) ? $ref->{'Reply-to'}[0] : $ref->{'From'}[0] ; my $addr = $from; $addr =~ s/.*]//g; $list{$addr} = $from unless exists $list{$addr}; } $append = <<"EOMSG"; To: ${\(join(",",values %list))} From: $opt_u\@$opt_s Date: ${\($imap->Rfc822_date(time))} Subject: build_dist.pl $opt_f Output The above note was never actually sent to the following people: ${\(join("\n",keys %list))} Interesting, eh? Love, $opt_u EOMSG $imap->append($opt_f,$append) or warn "Couldn't append the message."; $imap->logout; =head1 AUTHOR David J. Kernen The Kernen Group, Inc. imap@kernengroup.com =head1 COPYRIGHT This example and Mail::IMAPClient are Copyright (c) 2003 by The Kernen Group, Inc. All rights reserved. This example is distributed with Mail::IMAPClient and subject to the same licensing requirements as Mail::IMAPClient. imtest is a utility distributed with Cyrus IMAP server, Copyright (c) 1994-2000 Carnegie Mellon University. All rights reserved. =cut # $Id$ # $Log: build_dist.pl,v $ # Revision 19991216.7 2003/06/12 21:38:29 dkernen # # Preparing 2.2.8 # Added Files: COPYRIGHT # Modified Files: Parse.grammar # Added Files: Makefile.old # Makefile.PL Todo sample.perldb # BodyStructure.pm # Parse.grammar Parse.pod # range.t # Thread.grammar # draft-crispin-imapv-17.txt rfc1731.txt rfc2060.txt rfc2062.txt # rfc2221.txt rfc2359.txt rfc2683.txt # # Revision 19991216.6 2000/12/11 21:58:50 dkernen # # Modified Files: # build_dist.pl build_ldif.pl copy_folder.pl find_dup_msgs.pl # imap_to_mbox.pl populate_mailbox.pl # to add CVS data # # Revision 19991216.5 1999/12/16 17:19:09 dkernen # Bring up to same level # # Revision 19991124.3 1999/12/16 17:14:22 dkernen # Incorporate changes for exists method performance enhancement # # Revision 19991124.02 1999/11/24 17:46:16 dkernen # More fixes to t/basic.t # # Revision 19991124.01 1999/11/24 16:51:46 dkernen # Changed t/basic.t to test for UIDPLUS before trying UID cmds # # Revision 1.8 1999/11/23 17:51:05 dkernen # Committing version 1.06 distribution copy #