#!/usr/bin/perl # structure # pod documentation # pragmas # main program # global variables initialisation # default values # folder loop # subroutines # IMAPClient 2.2.9 overrides # IMAPClient 2.2.9 3.xx ads =pod =head1 NAME imapsync - IMAP synchronisation, sync, copy or migration tool. Synchronise mailboxes between two imap servers. Good at IMAP migration. More than 36 different IMAP server softwares supported with success. $Revision: 1.404 $ =head1 SYNOPSIS To synchronise imap account "foo" on "imap.truc.org" to imap account "bar" on "imap.trac.org" with foo password "secret1" and bar password "secret2": imapsync \ --host1 imap.truc.org --user1 foo --password1 secret1 \ --host2 imap.trac.org --user2 bar --password2 secret2 =head1 INSTALL imapsync works fine under any Unix OS with perl. imapsync works fine under Windows (2000, XP) with Strawberry Perl 5.10 or 5.12 or as a standalone binary software imapsync.exe imapsync is already available directly on the following distributions (at least): FreeBSD, Debian, Ubuntu, Gentoo, Fedora, NetBSD, Darwin, Mandriva and OpenBSD. Get imapsync at http://www.linux-france.org/prj/imapsync/ You'll receive a link to a compressed tarball called imapsync-x.xx.tgz where x.xx is the version number. Untar the tarball where you want (on Unix): tar xzvf imapsync-x.xx.tgz Go into the directory imapsync-x.xx and read the INSTALL file. The INSTALL file is also at http://www.linux-france.org/prj/imapsync/INSTALL The freshmeat record is at http://freshmeat.net/projects/imapsync/ =head1 USAGE imapsync [options] To get a description of each option just run imapsync like this: imapsync --help imapsync The option list: imapsync [--host1 server1] [--port1 ] [--user1 ] [--passfile1 ] [--host2 server2] [--port2 ] [--user2 ] [--passfile2 ] [--ssl1] [--ssl2] [--tls1] [--tls2] [--authmech1 ] [--authmech2 ] [--proxyauth1] [--proxyauth2] [--domain1] [--domain2] [--authmd51] [--authmd52] [--folder --folder ...] [--folderrec --folderrec ...] [--include ] [--exclude ] [--prefix2 ] [--prefix1 ] [--regextrans2 --regextrans2 ...] [--sep1 ] [--sep2 ] [--justfolders] [--justfoldersizes] [--justconnect] [--justbanner] [--syncinternaldates] [--idatefromheader] [--syncacls] [--regexmess ] [--regexmess ] [--maxsize ] [--minsize ] [--maxage ] [--minage ] [--skipheader ] [--useheader ] [--useheader ] [--nouid1] [--nouid1] [--usecache] [--skipsize] [--allowsizemismatch] [--delete] [--delete2] [--expunge] [--expunge1] [--expunge2] [--uidexpunge2] [--delete2folders] [--delete2foldersonly] [--delete2foldersbutnot] [--subscribed] [--subscribe] [--subscribe_all] [--nofoldersizes] [--dry] [--debug] [--debugimap][--debugimap1][--debugimap2] [--timeout ] [--fast] [--split1] [--split2] [--reconnectretry1 ] [--reconnectretry2 ] [--noreleasecheck] [--pidfile ] [--tmpdir ] [--version] [--help] [--tests] [--tests_debug] =cut # comment =pod =head1 DESCRIPTION The command imapsync is a tool allowing incremental and recursive imap transfer from one mailbox to another. By default all folders are transferred, recursively. We sometimes need to transfer mailboxes from one imap server to another. This is called migration. imapsync is a good tool because it reduces the amount of data transferred by not transferring a given message if it is already on both sides. Same headers and the transfer is done only once. All flags are preserved, unread will stay unread, read will stay read, deleted will stay deleted. You can stop the transfer at any time and restart it later, imapsync works well with bad connections. imapsync is CPU hungry so nice and renice commands can be a good help. imapsync can be memory hungry too, especially with large messages. You can decide to delete the messages from the source mailbox after a successful transfer (it is a good feature when migrating). In that case, use the --delete option. Option --delete implies also option --expunge so all messages marked deleted on host1 will be really deleted. (you can use --noexpunge to avoid this but I don't see any real world scenario for the combinaison --delete --noexpunge). You can also just synchronize a mailbox A from another mailbox B in case you just want to keep a "live" copy of B in A (--delete2 may help) =head1 OPTIONS To get a description of each option just invoke: imapsync --help =head1 HISTORY I wrote imapsync because an enterprise (basystemes) paid me to install a new imap server without losing huge old mailboxes located on a far away remote imap server accessible by a low bandwidth link. The tool imapcp (written in python) could not help me because I had to verify every mailbox was well transferred and delete it after a good transfer. imapsync started life as a copy_folder.pl patch. The tool copy_folder.pl comes from the Mail-IMAPClient-2.1.3 perl module tarball source (in the examples/ directory of the tarball). =head1 EXAMPLE While working on imapsync parameters please run imapsync in dry mode (no modification induced) with the --dry option. Nothing bad can be done this way. To synchronize the imap account "buddy" (with password "secret1") on host "imap.src.fr" to the imap account "max" (with password "secret2") on host "imap.dest.fr": imapsync --host1 imap.src.fr --user1 buddy --password1 secret1 \ --host2 imap.dest.fr --user2 max --password2 secret2 Then you will have max's mailbox updated from buddy's mailbox. =head1 SECURITY You can use --passfile1 instead of --password1 to give the password since it is safer. With --password1 option any user on your host can see the password by using the 'ps auxwwww' command. Using a variable (like $PASSWORD1) is also dangerous because of the 'ps auxwwwwe' command. So, saving the password in a well protected file (600 or rw-------) is the best solution. imasync is not totally protected against sniffers on the network since passwords may be transferred in plain text if CRAM-MD5 is not supported by your imap servers. Use --ssl1 (or --tls1) and --ssl2 (or --tls2) to enable encryption on host1 and host2. You may authenticate as one user (typically an admin user), but be authorized as someone else, which means you don't need to know every user's personal password. Specify --authuser1 "adminuser" to enable this on host1. In this case, --authmech1 PLAIN will be used by default since it is the only way to go for now. So don't use --authmech1 SOMETHING with --authuser1 "adminuser", it will not work. Same behavior with the --authuser2 option. When working on Sun/iPlanet/Netscape IMAP servers you must use --proxyauth1 to enable administrative user to masquerade as another user. Can also be used on destination server with --proxyauth2 =head1 EXIT STATUS imapsync will exit with a 0 status (return code) if everything went good. Otherwise, it exits with a non-zero status. So if you have an unreliable internet connection, you can use this loop in a Bourne shell: while ! imapsync ...; do echo imapsync not complete done =head1 LICENSE imapsync is free, open source but not always gratis software cover by the Do What The Fuck You Want To Public License (WTFPL). See COPYING file included in the distribution or the web site http://sam.zoy.org/wtfpl/COPYING =head1 MAILING-LIST The public mailing-list may be the best way to get support. To write on the mailing-list, the address is: To subscribe, send any message (even empty) to: then just reply to the confirmation message. To unsubscribe, send a message to: To contact the person in charge for the list: The list archives may be available at: http://www.linux-france.org/prj/imapsync_list/ So consider that the list is public, anyone can see your post. Use a pseudonym or do not post to this list if you want to stay private. Thank you for your participation. =head1 AUTHOR Gilles LAMIRAL Feedback good or bad is always welcome. The newsgroup comp.mail.imap may be a good place to talk about imapsync. I read it when imapsync is concerned. A better place is the public imapsync mailing-list (see below). Gilles LAMIRAL earns his living writing, installing, configuring and teaching free, open and often gratis softwares. Do not hesitate to pay him for that services. =head1 BUG REPORT GUIDELINES Help us to help you: follow the following guidelines. Report any bugs or feature requests to the public mailing-list or to the author. Before reporting bugs, read the FAQ, the README and the TODO files. http://www.linux-france.org/prj/imapsync/ Upgrade to last imapsync release, maybe the bug is already fixed. Upgrade to last Mail-IMAPClient Perl module. http://search.cpan.org/dist/Mail-IMAPClient/ maybe the bug is already fixed. Make a good title with word "imapsync" in it (my spam filter won't filter it), Don't write an email title with just "imapsync" or "problem", a good title is made of keywords summary, not too long (one visible line). Don't write imapsync in uppercase in the email title, we'll know you run Windows and you haven't read this README yet. Help us to help you: in your report, please include: - imapsync version. - output given with --debug --debugimap near the failure point. Isolate a message or two in a folder 'BUG' and use imapsync ... --folder 'BUG' --debug --debugimap - imap server software on both side and their version number. - imapsync with all the options you use, the full command line you use (except the passwords of course). - IMAPClient.pm version. - operating system running imapsync. - operating systems on both sides and the third side in case you run imapsync on a foreign host from the both. - virtual software context (vmware, xen etc.) Most of those values can be found as a copy/paste at the begining of the output. One time in your life, read the paper "How To Ask Questions The Smart Way" http://www.catb.org/~esr/faqs/smart-questions.html and then forget it. =head1 IMAP SERVERS Failure stories reported with the following 3 imap servers: - MailEnable 1.54 (Proprietary) http://www.mailenable.com/ - DBMail 0.9, 2.0.7 (GPL). But DBMail 1.2.1 works. Patient and confident testers are welcome. - Imail 7.04 (maybe). Success stories reported with the following 40 imap servers (software names are in alphabetic order): - 1und1 H mimap1 84498 [host1] - a1.net imap.a1.net IMAP4 Ready WARSBL614 00029c23 [host1] - Archiveopteryx 2.03, 2.04, 2.09, 2.10 [host2], 3.0.0 [host2] (OSL 3.0) http://www.archiveopteryx.org/ - BincImap 1.2.3 (GPL) (http://www.bincimap.org/) - CommuniGatePro server (Redhat 8.0) (Solaris), CommuniGate Pro 5.2.17[host2] (CentOS 5.4) - Courier IMAP 1.5.1, 2.2.0, 2.1.1, 2.2.1, 3.0.8, 3.0.3, 4.1.1 (GPL) (http://www.courier-mta.org/) - Critical Path (7.0.020) - Cyrus IMAP 1.5, 1.6, 2.1, 2.1.15, 2.1.16, 2.1.18 2.2.1, 2.2.2-BETA, 2.2.10, 2.2.12, v2.2.3-Invoca-RPM-2.2.3-8, 2.3-alpha (OSI Approved), v2.2.12-Invoca-RPM-2.2.12-3.RHEL4.1, 2.2.13, v2.3.1-Invoca-RPM-2.3.1-2.7.fc5, v2.3.7, (http://asg.web.cmu.edu/cyrus/) - David Tobit V8 (proprietary Message system). - DBMail 1.2.1, 2.0.4, 2.0.9, 2.2rc1 (GPL) (http://www.dbmail.org/). 2.0.7 seems buggy. - Deerfield VisNetic MailServer 5.8.6 [host1] - dkimap4 [host1] - Domino (Notes) 4.61[host1], 6.5[host1], 5.0.6, 5.0.7, 7.0.2, 6.0.2CF1, 7.0.1[host1], 8.0.1[host1], 8.5.2[host2] - Dovecot 0.99.10.4, 0.99.14, 0.99.14-8.fc4, 1.0-0.beta2.7, 1.0.0 [dest/source] (LGPL) (http://www.dovecot.org/) - Eudora WorldMail v2 - GMX IMAP4 StreamProxy. - Groupwise IMAP (Novell) 6.x and 7.0. Buggy so see the FAQ. - hMailServer 5.3.3 [host2], 4.4.1 [host1] (see FAQ) - iPlanet Messaging server 4.15, 5.1, 5.2 - IMail 7.15 (Ipswitch/Win2003), 8.12 - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform) - Mercury 4.1 (Windows server 2000 platform) - Microsoft Exchange Server 5.5, 6.0.6249.0[host1], 6.0.6487.0[host1], 6.5.7638.1 [host2], Exchange 2007 SP1 (with Update Rollup 2), Exchange2007-EP-SP2, Exchange 2010 RTM (Release to Manufacturing) [host2] - Mirapoint - Netscape Mail Server 3.6 (Wintel !) - Netscape Messaging Server 4.15 Patch 7 - OpenMail IMAP server B.07.00.k0 (Samsung Contact ?) - OpenWave - Oracle Beehive [host1] - Qualcomm Worldmail (NT) - Rockliffe Mailsite 5.3.11, 4.5.6 - Samsung Contact IMAP server 8.5.0 - Scalix v10.1, 10.0.1.3, 11.0.0.431 - SmarterMail, Smarter Mail 5.0 Enterprise, Smarter Mail 5.5 [host1]. - SunONE Messaging server 5.2, 6.0 (SUN JES - Java Enterprise System) - Sun Java(tm) System Messaging Server 6.2-2.05, 6.2-7.05, 6.3 - Surgemail 3.6f5-5 - UW-imap servers (imap-2000b) rijkkramer IMAP4rev1 2000.287 (RedHat uses UW like 2003.338rh), v12.264 Solaris 5.7 (OSI Approved) (http://www.washington.edu/imap/) - UW - QMail v2.1 - Imap part of TCP/IP suite of VMS 7.3.2 - Zimbra-IMAP 3.0.1 GA 160, 3.1.0 Build 279, 4.0.5, 4.5.2, 4.5.6, 5.5, 6.x Please report to the author any success or bad story with imapsync and do not forget to mention the IMAP server software names and version on both sides. This will help future users. To help the author maintaining this section report the two lines at the begining of the output if they are useful to know the softwares. Example: Host1 software:* OK louloutte Cyrus IMAP4 v1.5.19 server ready Host2 software:* OK Courier-IMAP ready You can use option --justconnect to get those lines. Example: imapsync --host1 imap.troc.org --host2 imap.trac.org --justconnect =head1 HUGE MIGRATION Pay special attention to options --subscribed --subscribe --delete --delete2 --delete2folders --expunge --expunge1 --expunge2 --uidexpunge2 --maxage --minage --maxsize --useheader --fast --useuid --usecache If you have many mailboxes to migrate think about a little shell program. Write a file called file.csv (for example) containing users and passwords. The separator used in this example is ';' The file.csv file contains: user0001;password0001;user0002;password0002 user0011;password0011;user0012;password0012 ... And the shell program is just: { while IFS=';' read u1 p1 u2 p2; do imapsync --user1 "$u1" --password1 "$p1" --user2 "$u2" --password2 "$p2" ... done ; } < file.csv Welcome in shell programming ! =head1 Hacking Feel free to hack imapsync as the WTFPL Licence permits it. =head1 Links Entries for imapsync: http://www.imap.org/products/showall.php =head1 SIMILAR SOFTWARES imap_tools : http://www.athensfbc.com/imap_tools offlineimap : http://software.complete.org/offlineimap mailsync : http://mailsync.sourceforge.net/ imapxfer : http://www.washington.edu/imap/ part of the imap-utils from UW. mailutil : replace imapxfer in part of the imap-utils from UW. http://www.gsp.com/cgi-bin/man.cgi?topic=mailutil imaprepl : http://www.bl0rg.net/software/ http://freshmeat.net/projects/imap-repl/ imap_migrate : http://freshmeat.net/projects/imapmigration/ imapcopy : http://home.arcor.de/armin.diehl/imapcopy/imapcopy.html migrationtool : http://sourceforge.net/projects/migrationtool/ imapmigrate : http://sourceforge.net/projects/cyrus-utils/ wonko_imapsync: http://wonko.com/article/554 see also tools/wonko_ruby_imapsync pop2imap : http://www.linux-france.org/prj/pop2imap/ Feedback (good or bad) will often be welcome. $Id: imapsync,v 1.404 2011/02/21 03:35:39 gilles Exp $ =cut # pragmas use warnings; ++$|; use strict; use Carp; use Getopt::Long; use Mail::IMAPClient; use Digest::MD5 qw(md5_base64); #use Term::ReadKey; #use IO::Socket::SSL; use MIME::Base64; use English; use File::Basename; use POSIX qw(uname SIGALRM); use Fcntl; use File::Spec; use File::Path qw(mkpath rmtree); use IO::Socket qw(:crlf SOL_SOCKET SO_KEEPALIVE); use Errno qw(EAGAIN EPIPE ECONNRESET); use File::Glob qw( :glob ) ; use IO::File; use Test::More 'no_plan'; eval { require 'usr/include/sysexits.ph' }; use constant { Unconnected => 0, Connected => 1, # connected; not logged in Authenticated => 2, # logged in; no mailbox selected Selected => 3, # mailbox selected }; # global variables my( $rcs, $pidfile, $debug, $debugimap, $debugimap1, $debugimap2, $nb_errors, $host1, $host2, $port1, $port2, $user1, $user2, $domain1, $domain2, $password1, $password2, $passfile1, $passfile2, @folder, @include, @exclude, @folderrec, $prefix1, $prefix2, @regextrans2, @regexmess, @regexflag, $sep1, $sep2, $syncinternaldates, $idatefromheader, $usedatemanip, $syncacls, $fastio1, $fastio2, $maxsize, $minsize, $maxage, $minage, $skipheader, @useheader, $skipsize, $allowsizemismatch, $foldersizes, $buffersize, $delete, $delete2, $expunge, $expunge1, $expunge2, $uidexpunge2, $dry, $justfoldersizes, $authmd5, $authmd51, $authmd52, $subscribed, $subscribe, $subscribe_all, $version, $help, $justconnect, $justfolders, $justbanner, $fast, $total_bytes_transferred, $total_bytes_skipped, $total_bytes_error, $nb_msg_transferred, $nb_msg_skipped, $nb_msg_skipped_dry_mode, $h1_nb_msg_duplicate, $h2_nb_msg_duplicate, $h1_nb_msg_noheader, $h2_nb_msg_noheader, $h1_total_bytes_duplicate, $h2_total_bytes_duplicate, $h1_nb_msg_deleted, $h2_nb_msg_deleted, $timeout, $timestart, $timeend, $timediff, $timesize, $timebefore, $ssl1, $ssl2, $tls1, $tls2, $uid1, $uid2, $authuser1, $authuser2, $proxyauth1, $proxyauth2, $authmech1, $authmech2, $split1, $split2, $reconnectretry1, $reconnectretry2, $tests, $test_builder, $tests_debug, $allow3xx, $justlogin, $tmpdir, $releasecheck, $max_msg_size_in_bytes, $modules_version, $delete2folders, $delete2foldersonly, $delete2foldersbutnot, $usecache, $debugcache, $takebody, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess, ); # main program # global variables initialisation $rcs = '$Id: imapsync,v 1.404 2011/02/21 03:35:39 gilles Exp $ '; $total_bytes_transferred = 0; $total_bytes_skipped = 0; $total_bytes_error = 0; $nb_msg_transferred = 0; $nb_msg_skipped = $nb_msg_skipped_dry_mode = 0; $h1_nb_msg_deleted = $h2_nb_msg_deleted = 0; $h1_nb_msg_duplicate = $h2_nb_msg_duplicate = 0; $h1_nb_msg_noheader = $h2_nb_msg_noheader = 0; $h1_total_bytes_duplicate = $h2_total_bytes_duplicate = 0; $nb_errors = 0; $max_msg_size_in_bytes = 0; unless(defined(&_SYSEXITS_H)) { # 64 on my linux box. eval 'sub EX_USAGE () {64;}' unless defined(&EX_USAGE); } # @ARGV will be eat by get_options() my @argv_copy = @ARGV; get_options(); $modules_version = defined($modules_version) ? $modules_version : 1; # $SIG{ INT } = \&catch_continue ; $releasecheck = defined($releasecheck) ? $releasecheck : 1; my $warn_release = ($releasecheck) ? check_last_release() : ''; $SIG{ INT } = \&catch_exit ; # default values $tmpdir ||= File::Spec->tmpdir(); $pidfile ||= $tmpdir . '/imapsync.pid'; # allow Mail::IMAPClient 3.0.xx by default $allow3xx = defined($allow3xx) ? $allow3xx : 1; $takebody = defined($takebody) ? $takebody : 1; if ( $fast ) { $useuid = 1 ; $foldersizes = 0 ; } # Activate --usecache if --useuid is set and no --nousecache $usecache = 1 if ( $useuid and ( ! defined( $usecache ) ) ) ; print banner_imapsync(@argv_copy); print "Temp directory is $tmpdir\n"; is_valid_directory($tmpdir); write_pidfile($pidfile) if ($pidfile); $modules_version and print "Modules version list:\n", modules_VERSION(), "\n"; check_lib_version() or die "imapsync needs perl lib Mail::IMAPClient release 2.2.9, or 3.25 or superior \n"; exit_clean(0) if ($justbanner); # By default, 1000 at a time, not more. $split1 ||= 1000; $split2 ||= 1000; $host1 || missing_option("--host1") ; $port1 ||= (defined $ssl1 and !defined $tls1) ? 993 : 143; $host2 || missing_option("--host2") ; $port2 ||= (defined $ssl2 && !defined $tls2) ? 993 : 143; $debugimap1 = $debugimap2 = 1 if ( $debugimap ) ; $debug = 1 if ( $debugimap1 or $debugimap2 ) ; # By default, don't take size to compare $skipsize = (defined $skipsize) ? $skipsize : 1; $uid1 = defined($uid1) ? $uid1 : 1; $uid2 = defined($uid2) ? $uid2 : 1; # Allow size mismatch by default $allowsizemismatch = defined($allowsizemismatch) ? $allowsizemismatch : 1; $delete2folders = 1 if ( defined( $delete2foldersbutnot ) or defined( $delete2foldersonly ) ) ; if ($justconnect) { justconnect(); exit_clean(0); } $user1 || missing_option("--user1"); $user2 || missing_option("--user2"); $syncinternaldates = defined($syncinternaldates) ? $syncinternaldates : 1; # Turn on expunge if there is not explicit option --noexpunge and option # --delete is given. # Done because --delete --noexpunge is very dangerous on the second run: # the Deleted flag is then synced to all previously transfered messages. # So --delete implies --expunge is a better usability default behaviour. if ($delete) { if ( ! defined($expunge)) { $expunge = 1; } } if($idatefromheader) { print "Turned ON idatefromheader, ", "will set the internal dates on host2 from the 'Date:' header line.\n"; $syncinternaldates = 0; } if ($syncinternaldates) { print "Turned ON syncinternaldates, ", "will set the internal dates (arrival dates) on host2 same as host1.\n"; }else{ print "Turned OFF syncinternaldates\n"; } if(defined($authmd5) and ($authmd5)) { $authmd51 = 1 ; $authmd52 = 1 ; } if(defined($authmd51) and ($authmd51)) { $authmech1 ||= 'CRAM-MD5'; } else{ $authmech1 ||= $authuser1 ? 'PLAIN' : 'LOGIN'; } if(defined($authmd52) and ($authmd52)) { $authmech2 ||= 'CRAM-MD5'; } else{ $authmech2 ||= $authuser2 ? 'PLAIN' : 'LOGIN'; } $authmech1 = uc($authmech1); $authmech2 = uc($authmech2); if (defined $proxyauth1 && !$authuser1) { missing_option("With --proxyauth1, --authuser1"); } if (defined $proxyauth2 && !$authuser2) { missing_option("With --proxyauth2, --authuser2"); } $authuser1 ||= $user1; $authuser2 ||= $user2; print "Will try to use $authmech1 authentication on host1\n"; print "Will try to use $authmech2 authentication on host2\n"; $syncacls = (defined($syncacls)) ? $syncacls : 0; $foldersizes = (defined($foldersizes)) ? $foldersizes : 1; $fastio1 = (defined($fastio1)) ? $fastio1 : 0; $fastio2 = (defined($fastio2)) ? $fastio2 : 0; $reconnectretry1 = (defined($reconnectretry1)) ? $reconnectretry1 : 3; $reconnectretry2 = (defined($reconnectretry2)) ? $reconnectretry2 : 3; @useheader = ("Message-Id") unless (@useheader); print "Host1: imap server [$host1] port [$port1] user [$user1]\n"; print "Host2: imap server [$host2] port [$port2] user [$user2]\n"; $password1 || $passfile1 || do { $password1 = ask_for_password($authuser1 || $user1, $host1); }; $password1 = (defined($passfile1)) ? firstline ($passfile1) : $password1; $password2 || $passfile2 || do { $password2 = ask_for_password($authuser2 || $user2, $host2); }; $password2 = (defined($passfile2)) ? firstline ($passfile2) : $password2; my $imap1 = (); my $imap2 = (); $timestart = time(); $timebefore = $timestart; $debugimap1 and print "Host1 connection\n"; $imap1 = login_imap($host1, $port1, $user1, $domain1, $password1, $debugimap1, $timeout, $fastio1, $ssl1, $tls1, $authmech1, $authuser1, $reconnectretry1, $proxyauth1, $uid1); $debugimap2 and print "Host2 connection\n"; $imap2 = login_imap($host2, $port2, $user2, $domain2, $password2, $debugimap2, $timeout, $fastio2, $ssl2, $tls2, $authmech2, $authuser2, $reconnectretry2, $proxyauth2, $uid2); # history $debug and print "Host1 Buffer I/O: ", $imap1->Buffer(), "\n"; $debug and print "Host2 Buffer I/O: ", $imap2->Buffer(), "\n"; die_clean() unless $imap1->IsAuthenticated(); print "Host1: state Authenticated\n"; die_clean() unless $imap2->IsAuthenticated(); print "Host2: state Authenticated\n"; print "Host1 capability: ", join(" ", $imap1->capability_update()), "\n"; print "Host2 capability: ", join(" ", $imap2->capability_update()), "\n"; exit_clean(0) if ($justlogin); $split1 and $imap1->Split($split1); $split2 and $imap2->Split($split2); # # Folder stuff # my ( @h1_folders_all, %h1_folders_all, @h1_folders_wanted, %requested_folder, %subscribed_folder, @h2_folders_all, %h2_folders_all, @h2_folders_from_1, %h2_folders_from_1, ); # Make a hash of subscribed folders in source server. map { $subscribed_folder{$_} = 1 } $imap1->subscribed(); # All folders on host1 and host2 @h1_folders_all = sort $imap1->folders(); @h2_folders_all = sort $imap2->folders(); map { $h1_folders_all{$_} = 1} @h1_folders_all; map { $h2_folders_all{$_} = 1} @h2_folders_all; if (scalar(@folder) or $subscribed or scalar(@folderrec)) { # folders given by option --folder if (scalar(@folder)) { add_to_requested_folders(@folder); } # option --subscribed if ($subscribed) { add_to_requested_folders(keys (%subscribed_folder)); } # option --folderrec if (scalar(@folderrec)) { foreach my $folderrec (@folderrec) { add_to_requested_folders($imap1->folders($folderrec)); } } } else { # no include, no folder/subscribed/folderrec options => all folders if (not scalar(@include)) { add_to_requested_folders(@h1_folders_all); } } # consider (optional) includes and excludes if (scalar(@include)) { foreach my $include (@include) { my @included_folders = grep /$include/, @h1_folders_all; add_to_requested_folders(@included_folders); print "Including folders matching pattern '$include': @included_folders\n"; } } if (scalar(@exclude)) { foreach my $exclude (@exclude) { my @requested_folder = sort(keys(%requested_folder)); my @excluded_folders = grep /$exclude/, @requested_folder; remove_from_requested_folders(@excluded_folders); print "Excluding folders matching pattern '$exclude': @excluded_folders\n"; } } # Remove no selectable folders foreach my $folder (keys(%requested_folder)) { if ( not $imap1->selectable($folder)) { print "Warning: ignoring folder $folder because it is not selectable\n"; remove_from_requested_folders($folder); } } my @requested_folder = sort(keys(%requested_folder)); @h1_folders_wanted = @requested_folder; my($h1_sep,$h2_sep); # what are the private folders separators for each server ? $debug and print "Getting separators\n"; $h1_sep = get_separator($imap1, $sep1, "--sep1"); $h2_sep = get_separator($imap2, $sep2, "--sep2"); #my $h1_namespace = $imap1->namespace(); #my $h2_namespace = $imap2->namespace(); #$debug and print "Host1 namespace:\n", Data::Dumper->Dump([$h1_namespace]); #$debug and print "Host2 namespace:\n", Data::Dumper->Dump([$h2_namespace]); my($h1_prefix,$h2_prefix); $h1_prefix = get_prefix($imap1, $prefix1, "--prefix1"); $h2_prefix = get_prefix($imap2, $prefix2, "--prefix2"); print "Host1 separator and prefix: [$h1_sep][$h1_prefix]\n"; print "Host2 separator and prefix: [$h2_sep][$h2_prefix]\n"; foreach my $h1_fold (@h1_folders_wanted) { my $h2_fold; $h2_fold = imap2_folder_name($h1_fold); $h2_folders_from_1{$h2_fold}++; } @h2_folders_from_1 = sort keys(%h2_folders_from_1); if ($foldersizes) { foldersizes("Host1", $imap1, @h1_folders_wanted); foldersizes("Host2", $imap2, @h2_folders_from_1); } exit_clean(0) if ($justfoldersizes); print "++++ Listing folders\n", "Host1 folders list:\n", map("[$_]\n",@h1_folders_all),"\n", "Host2 folders list:\n", map("[$_]\n",@h2_folders_all),"\n"; print "Host1 subscribed folders list: ", map("[$_] ", sort keys(%subscribed_folder)), "\n" if ($subscribed); my @h2_folders_not_in_1; @h2_folders_not_in_1 = list_folders_in_2_not_in_1(); print "Folders in host2 not in host1:\n", map("[$_]\n", @h2_folders_not_in_1),"\n"; delete_folders_in_2_not_in_1() if $delete2folders; # folder loop print "++++ Looping on each folder\n"; FOLDER: foreach my $h1_fold (@h1_folders_wanted) { my $h2_fold = imap2_folder_name($h1_fold); printf("%-35s -> %-35s\n", "[$h1_fold]", "[$h2_fold]"); select_folder($imap1, $h1_fold, 'Host1') or next FOLDER; if ( ! exists($h2_folders_all{$h2_fold})) { create_folder($imap2, $h2_fold, 'Host2') or next FOLDER; } acls_sync($h1_fold, $h2_fold); select_folder($imap2, $h2_fold, 'Host2') or next FOLDER; my @select_results = $imap2->Results(); #print "%%% @select_results\n"; my $permanentflags2 = permanentflags(@select_results); if ($expunge){ print "Expunging host1 $h1_fold\n"; unless($dry) { $imap1->expunge() }; #print "Expunging host2 $h2_fold\n"; #unless($dry) { $imap2->expunge() }; } if (($subscribe and exists $subscribed_folder{$h1_fold}) or $subscribe_all) { print "Subscribing to folder $h2_fold on destination server\n"; unless($dry) { $imap2->subscribe($h2_fold) }; } next FOLDER if ($justfolders); my @h1_msgs = select_msgs($imap1); $debug and print "LIST Host1: ", scalar(@h1_msgs), " messages [@h1_msgs]\n"; # internal dates on host2 are after the ones on host1 # normally... my @h2_msgs = select_msgs($imap2); $debug and print "LIST Host2: ", scalar(@h2_msgs), " messages [@h2_msgs]\n"; my $cache_base = "$tmpdir/imapsync_cache/$host1/$user1/$host2/$user2"; my $cache_dir = cache_folder( $cache_base, $h1_fold, $h2_fold ); my ( $cache_1_2_ref, $cache_2_1_ref ) = ( {}, {} ); if ( $usecache ) { print "cache directory: $cache_dir\n" ; mkpath( "$cache_dir" ) ; ( $cache_1_2_ref, $cache_2_1_ref ) = get_cache($cache_dir, \@h1_msgs, \@h2_msgs) if ($usecache) ; print "CACHE h1 h2: ", scalar( keys %$cache_1_2_ref ), " files\n" ; $debug and print '[', map ( { "$_->$cache_1_2_ref->{$_} " } keys %$cache_1_2_ref ), " ]\n"; #print "CACHE h2 h1: ", scalar( keys %$cache_2_1_ref ), " files\n" ; #$debug and print '[', # map ( { "$_->$cache_2_1_ref->{$_} " } keys %$cache_2_1_ref ), " ]\n"; } #sleep 4 ; my %h1_hash = (); my %h2_hash = (); my ( %h1_msgs_all, %h2_msgs_all ) ; @h1_msgs_all{ @h1_msgs } = (); @h2_msgs_all{ @h2_msgs } = (); my @h1_msgs_in_cache = sort { $a <=> $b } keys %$cache_1_2_ref ; my @h2_msgs_in_cache = keys %$cache_2_1_ref ; my ( %h1_msgs_no_cache, %h2_msgs_no_cache ) ; %h1_msgs_no_cache = %h1_msgs_all ; %h2_msgs_no_cache = %h2_msgs_all ; delete @h1_msgs_no_cache{ @h1_msgs_in_cache } ; delete @h2_msgs_no_cache{ @h2_msgs_in_cache } ; my @h1_msgs_no_cache = keys %h1_msgs_no_cache ; my @h2_msgs_no_cache = keys %h2_msgs_no_cache ; if ( $useuid ) { @h1_msgs_copy_by_uid{ @h1_msgs_no_cache } = ( ) ; @h1_msgs_no_cache = ( ) ; @h2_msgs_no_cache = ( ) ; } $debug and print "Host1 folder [$h1_fold] parsing headers\n"; my ($h1_heads_ref, $h1_fir_ref) = ({}, {}); $h1_heads_ref = $imap1->parse_headers([@h1_msgs_no_cache], @useheader) if (@h1_msgs_no_cache); $debug and print "Time headers: ", timenext(), " s\n"; @$h1_fir_ref{@h1_msgs} = (undef); $h1_fir_ref = $imap1->fetch_hash_2("FLAGS", "INTERNALDATE", "RFC822.SIZE", $h1_fir_ref) if (@h1_msgs); $debug and print "Time fir: ", timenext(), " s\n"; unless ($h1_fir_ref) { warn "Host1 folder $h1_fold: Could not fetch_hash_2 ", scalar(@h1_msgs), " msgs: ", $imap1->LastError, "\n"; $nb_errors++; next FOLDER; } my @h1_msgs_duplicate; foreach my $m (@h1_msgs_no_cache) { my $rc = parse_header_msg($imap1, $m, $h1_heads_ref, $h1_fir_ref, "F", \%h1_hash); if (! defined($rc)) { my $h1_size = $h1_fir_ref->{$m}->{"RFC822.SIZE"} || 0; print "+ Skipping msg #$m:$h1_size on host1 folder $h1_fold (no header so we ignore this message)\n"; $total_bytes_skipped += $h1_size; $nb_msg_skipped += 1; $h1_nb_msg_noheader +=1; } elsif(0 == $rc) { # duplicate push(@h1_msgs_duplicate, $m); # duplicate, same id same size? my $h1_size = $h1_fir_ref->{$m}->{"RFC822.SIZE"} || 0; $nb_msg_skipped += 1; $h1_total_bytes_duplicate += $h1_size; $h1_nb_msg_duplicate += 1; } } $debug and print "Time parsing headers on host1: ", timenext(), " s\n"; $debug and print "Host2 folder [$h2_fold] parsing headers\n"; my ($h2_heads_ref, $h2_fir_ref) = ( {}, {} ); $h2_heads_ref = $imap2->parse_headers([@h2_msgs_no_cache], @useheader) if (@h2_msgs_no_cache); $debug and print "Time headers: ", timenext(), " s\n"; @$h2_fir_ref{@h2_msgs} = ( ); # fetch_hash_2 can select by uid with last arg as ref $h2_fir_ref = $imap2->fetch_hash_2("FLAGS", "INTERNALDATE", "RFC822.SIZE", $h2_fir_ref) if (@h2_msgs); $debug and print "Time fir: ", timenext(), " s\n"; my @h2_msgs_duplicate; foreach my $m (@h2_msgs_no_cache) { my $rc = parse_header_msg($imap2, $m, $h2_heads_ref, $h2_fir_ref, "T", \%h2_hash); my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; if (! defined($rc)) { print "+ Skipping msg #$m:$h2_size in host2 folder $h2_fold (no header so we ignore this message)\n"; $h2_nb_msg_noheader += 1 ; } elsif(0 == $rc) { # duplicate $h2_nb_msg_duplicate += 1; $h2_total_bytes_duplicate += $h2_size; push(@h2_msgs_duplicate, $m); } } $debug and print "Time parsing headers on host2: ", timenext(), " s\n"; $debug and print "++++ Verifying [$h1_fold] -> [$h2_fold]\n"; # messages in host1 that are not in host2 my @h1_hash_keys_sorted_by_uid = sort {$h1_hash{$a}{'m'} <=> $h1_hash{$b}{'m'}} keys(%h1_hash); #print map { $h1_hash{$_}{'m'} . " "} @h1_hash_keys_sorted_by_uid; my @h2_hash_keys_sorted_by_uid = sort {$h2_hash{$a}{'m'} <=> $h2_hash{$b}{'m'}} keys(%h2_hash); if($delete2) { my @h2_expunge; foreach my $m_id (@h2_hash_keys_sorted_by_uid) { #print "$m_id "; unless (exists($h1_hash{$m_id})) { my $h2_msg = $h2_hash{$m_id}{'m'}; my $h2_flags = $h2_hash{$m_id}{'F'} || ""; my $isdel = $h2_flags =~ /\B\\Deleted\b/ ? 1 : 0; print "msg $h2_fold/$h2_msg deleted on host2 [$m_id]\n" if ! $isdel; push(@h2_expunge, $h2_msg) if $uidexpunge2; unless ($dry or $isdel) { $imap2->delete_message($h2_msg); $h2_nb_msg_deleted += 1; } } } foreach my $h2_msg (@h2_msgs_duplicate) { print "msg $h2_fold/$h2_msg deleted [duplicate] on host2\n"; push(@h2_expunge, $h2_msg) if $uidexpunge2; unless ($dry) { $imap2->delete_message($h2_msg); $h2_nb_msg_deleted += 1; } } my $cnt = scalar @h2_expunge; if(@h2_expunge and !$imap2->can("uidexpunge")) { warn "uidexpunge not supported (< IMAPClient 3.17)\n"; } elsif(@h2_expunge) { print "uidexpunge $cnt message(s)\n"; $imap2->uidexpunge(\@h2_expunge) if !$dry; } } my $h2_uidnext = $imap2->uidnext( $h2_fold ) ; $h2_uidguess = $h2_uidnext ; MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) { my $h1_size = $h1_hash{$m_id}{'s'}; my $h1_msg = $h1_hash{$m_id}{'m'}; my $h1_idate = $h1_hash{$m_id}{'D'}; if (defined $maxsize and $h1_size >= $maxsize) { print "msg $h1_fold/$h1_msg skipping ($h1_size exceeds maxsize limit $maxsize bytes)\n"; $total_bytes_skipped += $h1_size; $nb_msg_skipped += 1; next MESS; } if (defined $minsize and $h1_size <= $minsize) { print "msg $h1_fold/$h1_msg skipping ($h1_size smaller than minsize $minsize bytes)\n"; $total_bytes_skipped += $h1_size; $nb_msg_skipped += 1; next MESS; } unless (exists($h2_hash{$m_id})) { # copy copy_message( $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; next MESS; } else{ # already on host2 my $h2_msg = $h2_hash{$m_id}{'m'} ; $debug and print "msg $h1_fold/$h1_msg equals $h2_fold/$h2_msg\n" ; $total_bytes_skipped += $h1_size ; $nb_msg_skipped += 1 ; $debugcache and print "touch $cache_dir/${h1_msg}_$h2_msg\n" if ( $usecache ) ; touch( "$cache_dir/${h1_msg}_$h2_msg" ) if ( $usecache ) ; } #$debug and print "MESSAGE $m_id\n"; my $h2_msg = $h2_hash{$m_id}{'m'}; sync_flags( $h1_msg, $h2_msg, $h2_fold, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; # Good my $h2_size = $h2_hash{$m_id}{'s'}; $debug and print "msg $h1_fold/$h1_msg sizes $h1_size <> $h2_size $h2_fold/$h2_msg\n"; if( $delete ) { print "msg $h1_fold/$h1_msg deleted on host1\n"; unless( $dry ) { $imap1->delete_message( $h1_msg ); $h1_nb_msg_deleted += 1; $imap1->expunge() if ( $expunge ); } } } # END MESS: loop MESS_IN_CACHE: foreach my $h1_msg ( @h1_msgs_in_cache ) { my $h2_msg = $cache_1_2_ref->{ $h1_msg } ; $debugcache and print "cache messages update $h1_msg->$h2_msg\n"; sync_flags( $h1_msg, $h2_msg, $h2_fold, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } ; $total_bytes_skipped += $h1_size; $nb_msg_skipped += 1; } MESS_BY_UID: foreach my $h1_msg ( sort { $a <=> $b } keys %h1_msgs_copy_by_uid ) { # copy_message #print "Copy by uid $h1_fold/$h1_msg\n" ; copy_message( $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; } if ($expunge1){ print "Expunging host1 folder $h1_fold\n"; unless($dry) { $imap1->expunge() }; } if ($expunge2){ print "Expunging host2 folder $h2_fold\n"; unless($dry) { $imap2->expunge() }; } $debug and print "Time: ", timenext(), " s\n"; } sub sync_flags { my ( $h1_msg, $h2_msg, $h2_fold, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ; $debug and print "sync flags $h1_msg->$h2_msg\n"; # used cached flag values for efficiency my $h1_flags = $h1_fir_ref->{ $h1_msg }->{ "FLAGS" } ; my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ "FLAGS" } ; # RFC 2060: This flag can not be altered by any client $h1_flags =~ s@\\Recent\s?@@gi; $h1_flags = flags_regex($h1_flags) if @regexflag; $h1_flags = flags_filter($h1_flags, $permanentflags2) if ( $permanentflags2 ); # compare flags - set flags if there a difference my @h1_flags = sort split(' ', $h1_flags ); my @h2_flags = sort split(' ', $h2_flags ); my $diff = compare_lists( \@h1_flags, \@h2_flags ); #$diff = 1 ; $diff and $debug and print "msg $h2_fold/$h2_msg replacing h2 flags( $h2_flags ) with h1 flags( $h1_flags )\n"; # This sets flags so flags can be removed with this # When you remove a \Seen flag on host1 you want to it # to be removed on host2. Just add flags is not what # we need most of the time. if ( ! $dry and $diff and ! $imap2->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) { warn "- msg $h2_fold/$h2_msg could not add flags @h1_flags", $imap2->LastError, "\n"; #$nb_errors++; } } print "++++ End looping on each folder\n"; #print memory_consumption(); $imap1->logout(); $imap2->logout(); stats(); exit_clean(1) if( $nb_errors ); exit_clean(0); # END of main program # subroutines sub max { return(undef) if (0 == scalar(@_)); my @sorted = sort { $a <=> $b } @_; return(pop(@sorted)); } sub tests_max { ok(0 == max(0), "max 0"); ok(1 == max(1), "max 1"); ok(-1 == max(-1), "max -1"); ok(! defined(max()), "max no arg"); ok(100 == max(1, 100), "max 1 100"); ok(100 == max(100, 1), "max 100 1"); ok(100 == max(100, 42, 1), "max 100 42 1"); ok(100 == max(100, "42", 1), "max 100 42 1"); ok(100 == max("100", "42", 1), "max 100 42 1"); #ok(100 == max(100, "haha", 1), "max 100 42 1"); } sub check_lib_version { $debug and print "IMAPClient $Mail::IMAPClient::VERSION\n"; if ($Mail::IMAPClient::VERSION eq '2.2.9') { override_imapclient(); return(1); } else{ # 3.x.x is no longer buggy with imapsync. if ($allow3xx) { return(1); }else{ return(0); } } } sub modules_VERSION { my @list_version; foreach my $module (qw( Mail::IMAPClient IO::Socket IO::Socket::SSL Digest::MD5 Digest::HMAC_MD5 Term::ReadKey Authen::NTLM)) { my $v = "?"; if (eval "require $module") { # module is here $v = eval "\$${module}::VERSION"; }else{ # no module $v = "?"; } #print ("$module ", $v, "\n"); push (@list_version, sprintf("%-20s %s\n", $module, $v)); } return(@list_version); } # Construct a command line copy with passwords replaced by MASKED. sub command_line_nopassword { my @argv_copy = @_; my @argv_nopassword; while (@argv_copy) { my $arg = shift(@argv_copy); # option name or value if ($arg =~ m/-password[12]/) { shift(@argv_copy); # password value push(@argv_nopassword, $arg, "MASKED"); # option name and fake value }else{ push(@argv_nopassword, $arg); # same option or value } } return("@argv_nopassword"); } sub tests_command_line_nopassword { ok('' eq command_line_nopassword(), 'command_line_nopassword void'); ok('--blabla' eq command_line_nopassword('--blabla'), 'command_line_nopassword --blabla'); #print command_line_nopassword((qw{ --password1 secret1 })), "\n"; ok('--password1 MASKED' eq command_line_nopassword(qw{ --password1 secret1}), 'command_line_nopassword --password1'); ok('--blabla --password1 MASKED --blibli' eq command_line_nopassword(qw{ --blabla --password1 secret1 --blibli }), 'command_line_nopassword --password1 --blibli'); } sub ask_for_password { my ($user, $host) = @_; print "What's the password for $user\@$host? "; Term::ReadKey::ReadMode(2); my $password = <>; chomp $password; printf "\n"; Term::ReadKey::ReadMode(0); return $password; } sub catch_exit { my $signame = shift ; print "\nGot a SIG$signame!\n" ; stats( ) ; exit_clean( ) ; } sub catch_continue { my $signame = shift ; print "\nGot a SIG$signame!\n" ; } sub myconnect { my $self = shift; $debug and print "Entering myconnect\n"; %$self = (%$self, @_); my $sock = (($self->Ssl) ? IO::Socket::SSL->new : IO::Socket::INET->new); my $dp = ($self->Ssl ? 'imaps(993)' : 'imap(143)'); $debug and print "Calling configure\n"; my $ret = $sock->configure({ PeerAddr => $self->Server , PeerPort => $self->Port||$dp , Proto => 'tcp' , Timeout => $self->Timeout||0 , Debug => $self->Debug , }); unless ( defined($ret) ) { $self->LastError( "$@\n"); $@ = "$@"; carp "$@" unless defined wantarray; return undef; } $sock->autoflush(1); my $banner = $sock->getline(); $debug and print "Read: $banner"; $self->Banner($banner); $self->RawSocket2($sock); $self->State(Connected); if ($self->Tls) { starttls($self); } $self->Ignoresizeerrors($allowsizemismatch); if ($self->User and $self->Password) { $debug and print "Calling login\n"; return $self->login ; } else { return $self; } } sub starttls { my $self = shift; my $socket = $self->RawSocket2(); $debug and print "Entering starttls\n"; unless ($self->has_capability("STARTTLS")) { die_clean( "No STARTTLS capability" ); } print $socket, "\n"; print $socket "z00 STARTTLS\015\012"; CORE::select( undef, undef, undef, 0.025 ); my $txt = $socket->getline(); $debug and print "Read tls: $txt"; unless($txt =~ /^z00 OK/){ die_clean( "Invalid response for STARTTLS: $txt\n" ); } $debug and print "Calling start_SSL\n"; unless(IO::Socket::SSL->start_SSL($socket, { SSL_version => "TLSV1", SSL_startHandshake => 1, SSL_verify_depth => 1, })) { die_clean( "Couldn't start TLS: ".IO::Socket::SSL::errstr()."\n"); } if (ref($socket) ne "IO::Socket::SSL") { die_clean( "Socket has NOT been converted to SSL"); }else{ $debug and print "Socket successfuly converted to SSL\n"; } $debug and print "Ending starttls\n"; } sub connect_imap { my($host, $port, $debugimap, $ssl, $tls) = @_; my $imap = Mail::IMAPClient->new(); $imap->Ssl($ssl) if ($ssl); $imap->Tls($tls) if ($tls); $imap->Server($host); $imap->Port($port); $imap->Debug($debugimap); #$imap->connect() myconnect($imap) or die_clean("Can not open imap connection on [$host]: $@\n"); } sub justconnect { my $imap1 = (); my $imap2 = (); $imap1 = connect_imap($host1, $port1, $debugimap1, $ssl1, $tls1); print "Host1 software: ", server_banner($imap1); print "Host1 capability: ", join(" ", $imap1->capability()), "\n"; $imap2 = connect_imap($host2, $port2, $debugimap2, $ssl2, $tls2); print "Host2 software: ", server_banner($imap2); print "Host2 capability: ", join(" ", $imap2->capability()), "\n"; $imap1->logout(); $imap2->logout(); } sub login_imap { my($host, $port, $user, $domain, $password, $debugimap, $timeout, $fastio, $ssl, $tls, $authmech, $authuser, $reconnectretry, $proxyauth, $uid) = @_; my ($imap); $imap = Mail::IMAPClient->new(); $imap->Ssl($ssl) if ($ssl); $imap->Tls($tls) if ($tls); $imap->Clear(1); $imap->Server($host); $imap->Port($port); $imap->Fast_io($fastio); $imap->Buffer($buffersize || 4096); $imap->Uid($uid); #$imap->Uid(0); $imap->Peek(1); $imap->Debug($debugimap); $timeout and $imap->Timeout($timeout); $imap->Reconnectretry($reconnectretry) if ($reconnectretry); #$imap->connect() myconnect($imap) or die_clean("Can not open imap connection on [$host] with user [$user]: $@\n"); print "Banner: ", server_banner($imap); if ($imap->has_capability("AUTH=$authmech") or $imap->has_capability($authmech) ) { printf("Host %s says it has CAPABILITY for AUTHENTICATE %s\n", $imap->Server, $authmech); } else { printf("Host %s says it has NO CAPABILITY for AUTHENTICATE %s\n", $imap->Server, $authmech); if ($authmech eq 'PLAIN') { print "Frequently PLAIN is only supported with SSL, ", "try --ssl1 or --ssl2 option\n"; } } if ($proxyauth) { $imap->Authmechanism(""); } else { $imap->Authmechanism($authmech) unless ($authmech eq 'LOGIN'); } $imap->Authcallback(\&plainauth) if $authmech eq "PLAIN"; if ($proxyauth) { $imap->User($authuser); $imap->Domain($domain) if (defined($domain)); $imap->Authuser($authuser); $imap->Password($password); } else { $imap->User($user); $imap->Domain($domain) if (defined($domain)); $imap->Authuser($authuser); $imap->Password($password); } unless ($imap->login()) { my $info = "Error login: [$host] with user [$user] auth"; my $einfo = $imap->LastError || @{$imap->History}[-1]; chomp($einfo); my $error = "$info [$authmech]: $einfo\n"; print $error; # note: duplicating error on stdout/stderr die_clean($error) if ($authmech eq 'LOGIN' or $imap->IsUnconnected() or $authuser); print "Trying LOGIN Auth mechanism on [$host] with user [$user]\n"; $imap->Authmechanism(""); $imap->login() or die_clean("$info [LOGIN]: ", $imap->LastError, "\n"); } $proxyauth && $imap->proxyauth($user); print "Success login on [$host] with user [$user] auth [$authmech]\n"; return($imap); } sub plainauth() { my $code = shift; my $imap = shift; my $string = sprintf("%s\x00%s\x00%s", $imap->User, $imap->Authuser, $imap->Password); return encode_base64("$string", ""); } sub server_banner { my $imap = shift; my $banner = $imap->Banner() || "No banner\n"; return $banner; } sub banner_imapsync { my @argv_copy = @_; my $banner_imapsync = join("", '$RCSfile: imapsync,v $ ', '$Revision: 1.404 $ ', '$Date: 2011/02/21 03:35:39 $ ', "\n",localhost_info(), "\n", "Command line used:\n", "$0 ", command_line_nopassword(@argv_copy), "\n", ); } sub is_valid_directory { my $dir = shift; return(1) if (-d $dir and -r _ and -w _); # Trying to create it mkpath($dir) or die "Error creating tmpdir $tmpdir : $!"; die "Error with tmpdir $tmpdir : $!" if not (-d $dir and -r _ and -w _); return(1); } sub write_pidfile { my $pidfile = shift; print "PID file is $pidfile\n"; if (-e $pidfile) { warn "$pidfile already exists, overwriting it\n"; } open(PIDFILE, ">$pidfile") or do { warn "Could not open $pidfile for writing"; return undef; }; print PIDFILE $PROCESS_ID; close PIDFILE; return($PROCESS_ID); } sub exit_clean { my $status = shift; $status = defined( $status ) ? $status : 1 ; unlink($pidfile); exit($status); } sub die_clean { unlink($pidfile); die @_; } sub missing_option { my ($option) = @_; die_clean("$option option must be used, run $0 --help for help\n"); } sub select_folder { my ($imap, $folder, $hostside) = @_; if ( ! $imap->select($folder)) { warn "$hostside folder $folder: Could not select: ", $imap->LastError, "\n"; $nb_errors++; return(0); }else{ # ok select succeeded return(1); } } sub create_folder { my ($imap, $folder, $hostside) = @_; print "$hostside folder $folder does not exist\n"; print "Creating folder [$folder]\n"; if ( ! $dry){ if ( ! $imap->create($folder)){ warn "Couldn't create [$folder] on $hostside: ", $imap->LastError,"\n"; $nb_errors++; return(0); }else{ #create succeeded return(1); } }else{ # dry mode, no folder so many imap will fail, assuming failure return(0); } } sub tests_folder_routines { ok( !is_requested_folder('folder_foo') ); ok( add_to_requested_folders('folder_foo') ); ok( is_requested_folder('folder_foo') ); ok( !is_requested_folder('folder_NO_EXIST') ); ok( !remove_from_requested_folders('folder_foo'), "removed folder_foo"); ok( !is_requested_folder('folder_foo') ); my @f; ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f"); ok( is_requested_folder('folder_bar') ); ok( is_requested_folder('folder_toto') ); ok( remove_from_requested_folders('folder_toto') ); ok( !is_requested_folder('folder_toto') ); } sub is_requested_folder { my ( $folder ) = @_; defined( $requested_folder{ $folder } ); } sub add_to_requested_folders { my @wanted_folders = @_; foreach my $folder ( @wanted_folders ) { ++$requested_folder{ $folder }; } return( keys( %requested_folder ) ); } sub remove_from_requested_folders { my @wanted_folders = @_; foreach my $folder (@wanted_folders) { delete $requested_folder{$folder}; } return( keys(%requested_folder) ); } sub compare_lists { my ($list_1_ref, $list_2_ref) = @_; return(-1) if ((not defined($list_1_ref)) and defined($list_2_ref)); return(0) if ((not defined($list_1_ref)) and not defined($list_2_ref)); # end if no list return(1) if (not defined($list_2_ref)); # end if only one list if (not ref($list_1_ref)) {$list_1_ref = [$list_1_ref]}; if (not ref($list_2_ref)) {$list_2_ref = [$list_2_ref]}; my $last_used_indice = -1; #print "\$#$list_1_ref:", $#$list_1_ref, "\n"; #print "\$#$list_2_ref:", $#$list_2_ref, "\n"; ELEMENT: foreach my $indice ( 0 .. $#$list_1_ref ) { $last_used_indice = $indice; # End of list_2 return 1 if ($indice > $#$list_2_ref); my $element_list_1 = $list_1_ref->[$indice]; my $element_list_2 = $list_2_ref->[$indice]; my $balance = $element_list_1 cmp $element_list_2 ; next ELEMENT if ($balance == 0) ; return $balance; } # each element equal until last indice of list_1 return -1 if ($last_used_indice < $#$list_2_ref); # same size, each element equal return 0 } sub tests_compare_lists { my $empty_list_ref = []; ok( 0 == compare_lists() , 'compare_lists, no args'); ok( 0 == compare_lists(undef) , 'compare_lists, undef = nothing'); ok( 0 == compare_lists(undef, undef) , 'compare_lists, undef = undef'); ok(-1 == compare_lists(undef , []) , 'compare_lists, undef < []'); ok(-1 == compare_lists(undef , [1]) , 'compare_lists, undef < [1]'); ok(-1 == compare_lists(undef , [0]) , 'compare_lists, undef < [0]'); ok(+1 == compare_lists([]) , 'compare_lists, [] > nothing'); ok(+1 == compare_lists([], undef) , 'compare_lists, [] > undef'); ok( 0 == compare_lists([] , []) , 'compare_lists, [] = []'); ok(-1 == compare_lists([] , [1]) , 'compare_lists, [] < [1]'); ok(+1 == compare_lists([1] , []) , 'compare_lists, [1] > []'); ok( 0 == compare_lists([1], 1 ) , "compare_lists, [1] = 1 ") ; ok( 0 == compare_lists( 1 , [1]) , "compare_lists, 1 = [1]") ; ok( 0 == compare_lists( 1 , 1 ) , "compare_lists, 1 = 1 ") ; ok(-1 == compare_lists( 0 , 1 ) , "compare_lists, 0 < 1 ") ; ok(-1 == compare_lists(-1 , 0 ) , "compare_lists, -1 < 0 ") ; ok(-1 == compare_lists( 1 , 2 ) , "compare_lists, 1 < 2 ") ; ok(+1 == compare_lists( 2 , 1 ) , "compare_lists, 2 > 1 ") ; ok( 0 == compare_lists([1,2], [1,2]) , "compare_lists, [1,2] = [1,2]") ; ok(-1 == compare_lists([1], [1,2]) , "compare_lists, [1] < [1,2]") ; ok(+1 == compare_lists([2], [1,2]) , "compare_lists, [2] > [1,2]") ; ok(-1 == compare_lists([1], [1,1]) , "compare_lists, [1] < [1,1]") ; ok(+1 == compare_lists([1, 1], [1]) , "compare_lists, [1, 1] > [1]") ; ok( 0 == compare_lists([1 .. 20_000] , [1 .. 20_000]) , "compare_lists, [1..20_000] = [1..20_000]") ; ok(-1 == compare_lists([1], [3]) , 'compare_lists, [1] < [3]') ; ok( 0 == compare_lists([2], [2]) , 'compare_lists, [0] = [2]') ; ok(+1 == compare_lists([3], [1]) , 'compare_lists, [3] > [1]') ; ok(-1 == compare_lists(["a"], ["b"]) , 'compare_lists, ["a"] < ["b"]') ; ok( 0 == compare_lists(["a"], ["a"]) , 'compare_lists, ["a"] = ["a"]') ; ok( 0 == compare_lists(["ab"], ["ab"]) , 'compare_lists, ["ab"] = ["ab"]') ; ok(+1 == compare_lists(["b"], ["a"]) , 'compare_lists, ["b"] > ["a"]') ; ok(-1 == compare_lists(["a"], ["aa"]) , 'compare_lists, ["a"] < ["aa"]') ; ok(-1 == compare_lists(["a"], ["a", "a"]), 'compare_lists, ["a"] < ["a", "a"]') ; ok( 0 == compare_lists([split(" ", "a b")], ["a", "b"]), 'compare_lists, split') ; ok( 0 == compare_lists([sort split(" ", "b a")], ["a", "b"]), 'compare_lists, sort split') ; } sub get_prefix { my($imap, $prefix_in, $prefix_opt) = @_; my($prefix_out); $debug and print "Getting prefix namespace\n"; if (defined($prefix_in)) { print "Using [$prefix_in] given by $prefix_opt\n"; $prefix_out = $prefix_in; return($prefix_out); } $debug and print "Calling namespace capability\n"; if ($imap->has_capability("namespace")) { my $r_namespace = $imap->namespace(); $prefix_out = $r_namespace->[0][0][0]; return($prefix_out); } else{ print "No NAMESPACE capability in imap server ", $imap->Server(),"\n", help_to_guess_prefix($imap, $prefix_opt); exit_clean(1); } } sub get_separator { my($imap, $sep_in, $sep_opt) = @_; my($sep_out); if ($sep_in) { print "Using [$sep_in] given by $sep_opt\n"; $sep_out = $sep_in; return($sep_out); } $debug and print "Calling namespace capability\n"; if ($imap->has_capability("namespace")) { $sep_out = $imap->separator(); return($sep_out) if defined $sep_out; print "NAMESPACE request failed for ", $imap->Server(), ": ", $imap->LastError, "\n"; exit_clean(1); } else{ print "No NAMESPACE capability in imap server ", $imap->Server(),"\n", help_to_guess_sep($imap, $sep_opt); exit_clean(1); } } sub help_to_guess_sep { my($imap, $sep_opt) = @_; my $help = "Give the separator character with the $sep_opt option,\n" . "the folowing listing of folders may help you to find it:\n" . folders_list_to_help($imap) . "Most of the time it is character . or /\n" . "so try $sep_opt . or $sep_opt /\n"; return($help); } sub help_to_guess_prefix { my($imap, $prefix_opt) = @_; my $help = "Give the prefix namespace with the $prefix_opt option,\n" . "the folowing listing of folders may help you to find it:\n" . folders_list_to_help($imap) . "Most of the time it is INBOX. or an empty string\n" . "so try $prefix_opt INBOX. or $prefix_opt ''\n"; return($help); } sub folders_list_to_help { my($imap) = @_; my @folders = $imap->folders; my $listing = join('', map { "[$_]\n" } @folders); return $listing; } sub separator_invert { # The separator we hope we'll never encounter: 00000000 my $o_sep="\000"; my($h1_fold, $h1_sep, $h2_sep) = @_; my $h2_fold = $h1_fold; $h2_fold =~ s@\Q$h2_sep@$o_sep@g; $h2_fold =~ s@\Q$h1_sep@$h2_sep@g; $h2_fold =~ s@\Q$o_sep@$h1_sep@g; return($h2_fold); } sub tests_imap2_folder_name { $h1_prefix = $h2_prefix = ''; $h1_sep = '/'; $h2_sep = '.'; $debug and print "prefix1: [$h1_prefix] prefix2: [$h2_prefix] sep1:[$h1_sep] sep2:[$h2_sep] "; ok('' eq imap2_folder_name(''), 'imap2_folder_name: empty string'); ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla'); ok('spam.spam' eq imap2_folder_name('spam/spam'), 'imap2_folder_name: spam/spam'); ok('spam/spam' eq imap2_folder_name('spam.spam'), 'imap2_folder_name: spam.spam'); ok('spam.spam/spam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam'); @regextrans2 = ('s,/,X,g'); ok('' eq imap2_folder_name(''), 'imap2_folder_name: empty string [s,/,X,g]'); ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla [s,/,X,g]'); ok('spam.spam' eq imap2_folder_name('spam/spam'), 'imap2_folder_name: spam/spam [s,/,X,g]'); ok('spamXspam' eq imap2_folder_name('spam.spam'), 'imap2_folder_name: spam.spam [s,/,X,g]'); ok('spam.spamXspam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam [s,/,X,g]'); @regextrans2 = ('s, ,_,g'); ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla [s, ,_,g]'); ok('bla_bla' eq imap2_folder_name('bla bla'), 'imap2_folder_name: blabla [s, ,_,g]'); @regextrans2 = ('s,(.*),\U$1,'); ok('BLABLA' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla [s,\U(.*)\E,$1,]'); } sub imap2_folder_name { my ($h2_fold); my ($x_fold) = @_; # first we remove the prefix $x_fold =~ s/^\Q$h1_prefix\E//; $debug and print "removed host1 prefix: [$x_fold]\n"; $h2_fold = separator_invert($x_fold,$h1_sep, $h2_sep); $debug and print "inverted separators: [$h2_fold]\n"; # Adding the prefix supplied by namespace or the --prefix2 option $h2_fold = $h2_prefix . $h2_fold unless(($h2_prefix eq "INBOX" . $h2_sep) and ($h2_fold =~ m/^INBOX$/i)); $debug and print "added host2 prefix: [$h2_fold]\n"; # Transforming the folder name by the --regextrans2 option(s) foreach my $regextrans2 (@regextrans2) { my $h2_fold_before = $h2_fold; eval("\$h2_fold =~ $regextrans2"); $debug and print "[$h2_fold_before] -> [$h2_fold] using re [$regextrans2]\n"; die_clean("error: eval regextrans2 '$regextrans2': $@\n") if $@; } return($h2_fold); } sub foldersizes { my ($side, $imap, @folders) = @_; my $tot = 0; my $tmess = 0; my $biggest = 0 ; print "++++ Calculating sizes\n"; foreach my $folder (@folders) { my $stot = 0; my $smess = 0; printf("$side folder %-35s", "[$folder]"); unless($imap->exists($folder)) { print("does not exist yet\n"); next; } unless ($imap->examine($folder)) { warn "$side Folder $folder: Could not examine: ", $imap->LastError, "\n"; $nb_errors++; next; } my $hash_ref = {}; my @msgs = select_msgs($imap); $smess = scalar(@msgs); my $smax = 0 ; @$hash_ref{@msgs} = (undef); unless ($smess == 0) { $imap->fetch_hash_2("RFC822.SIZE",$hash_ref) or die_clean("$@"); #print map {$hash_ref->{$_}->{"RFC822.SIZE"}, " "} keys %$hash_ref; map {$stot += $hash_ref->{$_}->{"RFC822.SIZE"}} keys %$hash_ref ; $smax = max( map {$hash_ref->{$_}->{"RFC822.SIZE"}} keys %$hash_ref ); $biggest = max( $biggest, $smax ); } printf(" Size: %9s", $stot); printf(" Messages: %5s", $smess); printf(" Biggest: %9s\n", $smax); $tot += $stot; $tmess += $smess; } printf ("Nb messages: %11s\n", $tmess ) ; printf ("Total size: %11s bytes\n", $tot ) ; printf ("Biggest message: %11s bytes\n", $biggest ) ; printf ("Time: %11s secondes\n", timenext( ) ) ; } sub timenext { my ($timenow, $timerel); # $timebefore is global, beurk ! $timenow = time; $timerel = $timenow - $timebefore; $timebefore = $timenow; return($timerel); } sub tests_flags_regex { my $string; ok('' eq flags_regex(''), "flags_regex, null string ''"); ok('\Seen NonJunk $Spam' eq flags_regex('\Seen NonJunk $Spam'), 'flags_regex, nothing to do'); ok('\Seen NonJunk $Spam' eq flags_regex('\Seen NonJunk $Spam'), 'flags_regex,'); @regexflag = ('s/NonJunk//g'); ok('\Seen $Spam' eq flags_regex('\Seen NonJunk $Spam'), "flags_regex, remove NonJunk: 's/NonJunk//g'"); @regexflag = ('s/\$Spam//g'); ok('\Seen NonJunk ' eq flags_regex('\Seen NonJunk $Spam'), 'flags_regex, remove $Spam: '."'s/\$Spam//g'"); @regexflag = ('s/\\\\Seen//g'); ok(' NonJunk $Spam' eq flags_regex('\Seen NonJunk $Spam'), 'flags_regex, remove \Seen: '. "'s/\\\\\\\\Seen//g'"); @regexflag = ('s/(\s|^)[^\\\\]\w+//g'); ok('\Seen \Middle \End' eq flags_regex('\Seen NonJunk \Middle $Spam \End'), 'flags_regex, only \word [' . flags_regex('\Seen NonJunk \Middle $Spam \End'.']')); ok(' \Seen \Middle \End1' eq flags_regex('Begin \Seen NonJunk \Middle $Spam \End1 End'), 'flags_regex, only \word [' . flags_regex('Begin \Seen NonJunk \Middle $Spam \End1 End'.']')); @regexflag = ('s/.*?(Keep1|Keep2|Keep3)/$1 /g'); ok('Keep1 Keep2 ReB' eq flags_regex('ReA Keep1 REM Keep2 ReB'), "Keep only regex"); #ok('Keep1 Keep2' eq flags_regex('Keep1 Keep2 Remove1'), "Keep only regex"); ok('Keep1 Keep2 ' eq flags_regex('REM REM Keep1 Keep2'), "Keep only regex"); ok('Keep1 Keep2 ' eq flags_regex('Keep1 REM REM Keep2'), "Keep only regex"); ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM REM Keep2'), "Keep only regex"); ok('Keep1 Keep2 ' eq flags_regex('Keep1 Keep2'), "Keep only regex"); ok('Keep1 ' eq flags_regex('REM Keep1'), "Keep only regex"); @regexflag = ('s/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g'); ok('Keep1 Keep2 ' eq flags_regex('Keep1 Keep2 ReB'), "Keep only regex"); ok('Keep1 Keep2 ' eq flags_regex('Keep1 Keep2 REM REM REM'), "Keep only regex"); ok('Keep2 ' eq flags_regex('Keep2 REM REM REM'), "Keep only regex"); #ok('' eq flags_regex('REM REM'), "Keep only regex"); @regexflag = ('s/.*?(Keep1|Keep2|Keep3)/$1 /g', 's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g'); ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), "Keep only regex"); ok('Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), "Keep only regex"); ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), "Keep only regex"); ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), "Keep only regex"); ok('Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), "Keep only regex"); ok('Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), "Keep only regex"); ok('Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), "Keep only regex"); @regexflag = ('s/(.*)/$1 jrdH8u/'); ok('REM REM REM REM REM jrdH8u' eq flags_regex('REM REM REM REM REM'), "Keep only regex 's/(.*)/\$1 jrdH8u/'"); @regexflag = ('s/jrdH8u *//'); ok('REM REM REM REM REM ' eq flags_regex('REM REM REM REM REM jrdH8u'), "Keep only regex s/jrdH8u *//"); @regexflag = ( 's/(.*)/$1 jrdH8u/', 's/.*?(Keep1|Keep2|Keep3|jrdH8u)/$1 /g', 's/(Keep1|Keep2|Keep3|jrdH8u) (?!(Keep1|Keep2|Keep3|jrdH8u)).*/$1 /g', 's/jrdH8u *//' ); ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), "Keep only regex 'REM Keep1 REM Keep2 REM'"); ok('Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), "Keep only regex"); ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), "Keep only regex"); ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), "Keep only regex"); ok('Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), "Keep only regex"); ok('Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), "Keep only regex"); ok('Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), "Keep only regex"); ok('' eq flags_regex('REM REM REM REM REM'), "Keep only regex"); @regexflag = ( 's/(.*)/$1 jrdH8u/', 's/.*?(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u)/$1 /g', 's/(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u) (?!(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u)).*/$1 /g', 's/jrdH8u *//' ); ok('\\Deleted \\Answered ' eq flags_regex('Blabla $Junk \\Deleted machin \\Answered truc'), "Keep only regex: Exchange case"); ok('' eq flags_regex(''), "Keep only regex: Exchange case, null string"); ok('' eq flags_regex('Blabla $Junk machin truc'), "Keep only regex: Exchange case, no accepted flags "); ok('\\Deleted \\Answered \\Draft \\Flagged ' eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), "Keep only regex: Exchange case"); @regexflag = ( 's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg' ); ok('\\Deleted \\Answered ' eq flags_regex('Blabla \$Junk \\Deleted machin \\Answered truc'), "Keep only regex: Exchange case (Phil)"); ok('' eq flags_regex(''), "Keep only regex: Exchange case, null string (Phil)"); ok('' eq flags_regex('Blabla $Junk machin truc'), "Keep only regex: Exchange case, no accepted flags (Phil)"); ok('\\Deleted \\Answered \\Draft \\Flagged ' eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), "Keep only regex: Exchange case (Phil)"); } sub flags_regex { my ($h1_flags) = @_; foreach my $regexflag (@regexflag) { my $h1_flags_orig = $h1_flags; $debug and print "eval \$h1_flags =~ $regexflag\n"; eval("\$h1_flags =~ $regexflag"); die_clean("error: eval regexflag '$regexflag': $@\n") if $@; $debug and print "regexflag $regexflag [$h1_flags_orig] -> [$h1_flags]\n"; } return($h1_flags); } sub acls_sync { my($h1_fold, $h2_fold) = @_; if ($syncacls) { my $h1_hash = $imap1->getacl($h1_fold) or warn "Could not getacl for $h1_fold: $@\n"; my $h2_hash = $imap2->getacl($h2_fold) or warn "Could not getacl for $h2_fold: $@\n"; my %users = map({ ($_, 1) } (keys(%$h1_hash), keys(%$h2_hash))); foreach my $user (sort(keys(%users))) { my $acl = $h1_hash->{$user} || "none"; print "acl $user: [$acl]\n"; next if ($h1_hash->{$user} && $h2_hash->{$user} && $h1_hash->{$user} eq $h2_hash->{$user}); unless ($dry) { print "setting acl $h2_fold $user $acl\n"; $imap2->setacl($h2_fold, $user, $acl) or warn "Could not set acl: $@\n"; } } } } sub tests_permanentflags { my $string; ok('' eq permanentflags(' * OK [PERMANENTFLAGS (\* \Draft \Answered)] Limited'), 'permanentflags \*'); ok('\Draft \Answered' eq permanentflags(' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited'), 'permanentflags \Draft \Answered'); ok('\Draft \Answered' eq permanentflags('Blabla', ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited', 'Blabla'), 'permanentflags \Draft \Answered' ); ok('' eq permanentflags('Blabla'), 'permanentflags nothing'); } sub permanentflags { my @lines = @_; foreach my $line (@lines) { if ($line =~ m{\[PERMANENTFLAGS \(([^)]+?)\)\]}) { #print "%%%$1%%%\n"; my $permanentflags = $1; if ($permanentflags =~ m{\\\*}) { $permanentflags = ''; } return($permanentflags); }; } } sub tests_flags_filter { ok( '\Seen' eq flags_filter('\Seen', '\Draft \Seen \Answered'), 'flags_filter ' ); ok( '' eq flags_filter('\Seen', '\Draft \Answered'), 'flags_filter ' ); ok( '\Seen' eq flags_filter('\Seen', '\Seen'), 'flags_filter ' ); ok( '\Seen' eq flags_filter('\Seen', ' \Seen '), 'flags_filter ' ); ok( '\Seen \Draft' eq flags_filter('\Seen \Draft', '\Draft \Seen \Answered'), 'flags_filter ' ); ok( '\Seen \Draft' eq flags_filter('\Seen \Draft', ' \Draft \Seen \Answered '), 'flags_filter ' ); } sub flags_filter { my($flags, $allowed_flags) = @_; my @flags = split(/\s+/, $flags); my %allowed_flags = map { $_ => 1 } split(' ', $allowed_flags ); my @flags_out = map { exists $allowed_flags{$_} ? $_ : () } @flags; my $flags_out = join(' ', @flags_out); #print "%%%$flags_out%%%\n"; return($flags_out); } sub select_msgs { my ($imap) = @_; my (@msgs,@max,@min,@union,@inter); unless (defined($maxage) or defined($minage)) { #@msgs = $imap->search("ALL"); @msgs = $imap->messages(); return(@msgs); } if (defined($maxage)) { @max = $imap->sentsince(time - 86400 * $maxage); } if (defined($minage)) { @min = $imap->sentbefore(time - 86400 * $minage); } SWITCH: { unless(defined($minage)) {@msgs = @max; last SWITCH}; unless(defined($maxage)) {@msgs = @min; last SWITCH}; my (%union, %inter); foreach my $m (@min, @max) {$union{$m}++ && $inter{$m}++} @inter = keys(%inter); @union = keys(%union); # normal case if ($minage <= $maxage) {@msgs = @inter; last SWITCH}; # just exclude messages between if ($minage > $maxage) {@msgs = @union; last SWITCH}; } return(@msgs); } sub lastuid { my $imap = shift ; my $folder = shift ; my $lastuid_guess = shift ; my $lastuid ; # rfc3501: The only reliable way to identify recent messages is to # look at message flags to see which have the \Recent flag # set, or to do a SEARCH RECENT. # SEARCH RECENT doesn't work this way on courrier. my @recent_messages ; # SEARCH RECENT for each transfer can be expensive with a big folder # Call commented for now #@recent_messages = $imap->recent( ) ; #print "Recent: @recent_messages\n"; my $max_recent ; $max_recent = max( @recent_messages ) ; if ( defined( $max_recent ) and ($lastuid_guess <= $max_recent ) ) { $lastuid = $max_recent ; }else{ $lastuid = $lastuid_guess } return( $lastuid ) ; } sub copy_message { # copy my ( $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) = @_ ; $debug and print "msg $h1_fold/$h1_msg copying to $h2_fold\n"; my $h1_size = $h1_fir_ref->{$h1_msg}->{"RFC822.SIZE"}; my $h1_flags = $h1_fir_ref->{$h1_msg}->{"FLAGS"}; my $h1_idate = $h1_fir_ref->{$h1_msg}->{"INTERNALDATE"}; my $string; $string = $imap1->message_string($h1_msg); unless (defined($string)) { warn "- msg $h1_fold/$h1_msg could not be fetched: ", $imap1->LastError, "\n"; $nb_errors++; $total_bytes_error += $h1_size; return( ) ; } if (@regexmess) { $string = regexmess($string); } $debug and print "=" x80, "\n", "F message content begin next line\n", $string, "F message content ended on previous line\n", "=" x 80, "\n"; my $h1_date = ""; if ($syncinternaldates) { $h1_date = $h1_idate; $debug and print "internal date from host1: [$h1_date]\n"; $h1_date = good_date($h1_date); $debug and print "internal date from host1: [$h1_date] (fixed)\n"; } if ($idatefromheader) { $h1_date = $imap1->get_header($h1_msg,"Date"); $debug and print "header date from host1: [$h1_date]\n"; $h1_date = good_date($h1_date); $debug and print "header date from host1: [$h1_date] (fixed)\n"; } # RFC 2060: This flag can not be altered by any client $h1_flags =~ s@\\Recent\s?@@gi; $h1_flags = flags_regex($h1_flags) if @regexflag; $h1_flags = flags_filter($h1_flags, $permanentflags2) if ($permanentflags2); my $new_id; $debug and print "msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n"; $h1_date = undef if ($h1_date eq ""); unless ($dry) { $max_msg_size_in_bytes = max($h1_size, $max_msg_size_in_bytes); $new_id = $imap2->append_string($h2_fold, $string, $h1_flags, $h1_date); unless($new_id){ no warnings 'uninitialized'; warn "- msg $h1_fold/$h1_msg couldn't append (Subject:[". $imap1->subject($h1_msg)."]) to folder $h2_fold: ", $imap2->LastError, "\n"; $nb_errors++; $total_bytes_error += $h1_size; return( ) ; } else{ # good # $new_id is an id if the IMAP server has the # UIDPLUS capability else just a ref if ( $new_id !~ m{^\d+$} ) { $new_id = lastuid( $imap2, $h2_fold, $h2_uidguess ) ; } printf( "msg %s/%-10s copied to %s/%-10s\n", $h1_fold, $h1_msg, $h2_fold, $new_id ); $h2_uidguess++; $total_bytes_transferred += $h1_size; $nb_msg_transferred += 1; $debugcache and print "touch $cache_dir/${h1_msg}_$new_id\n" if ( $usecache ) ; touch( "$cache_dir/${h1_msg}_$new_id" ) if ( $usecache and $new_id =~ m{^\d+$} ); if ( $delete ) { print "msg $h1_fold/$h1_msg deleted on host1\n"; unless($dry) { $imap1->delete_message($h1_msg); $h1_nb_msg_deleted += 1; $imap1->expunge() if ($expunge); } } } } else{ $nb_msg_skipped_dry_mode += 1; } return( ); } sub cache_map { my ( $cache_files_ref, $h1_msgs_ref, $h2_msgs_ref ) = @_; my ( %map1_2, %map2_1, %done2 ) ; my $h1_msgs_hash_ref = { } ; my $h2_msgs_hash_ref = { } ; @$h1_msgs_hash_ref{ @$h1_msgs_ref } = ( ) ; @$h2_msgs_hash_ref{ @$h2_msgs_ref } = ( ) ; foreach my $file ( sort @$cache_files_ref ) { $debugcache and print "C12: $file\n" ; ( $uid1, $uid2 ) = match_a_cache_file( $file ) ; if ( exists( $h1_msgs_hash_ref->{ $uid1 } ) and exists( $h2_msgs_hash_ref->{ $uid2 } ) ) { # keep only the greatest uid2 # 130_2301 and # 130_231 => keep only 130 -> 2301 # keep only the greatest uid1 # 1601_260 and # 161_260 => keep only 1601 -> 260 my $max_uid2 = max( $uid2, $map1_2{ $uid1 } || -1 ) ; if ( exists( $done2{ $max_uid2 } ) ) { if ( $done2{ $max_uid2 } < $uid1 ) { $map1_2{ $uid1 } = $max_uid2 ; delete( $map1_2{ $done2{ $max_uid2 } } ) ; $done2{ $max_uid2 } = $uid1 ; } }else{ $map1_2{ $uid1 } = $max_uid2 ; $done2{ $max_uid2 } = $uid1 ; } }; } %map2_1 = reverse( %map1_2 ) ; return( \%map1_2, \%map2_1) ; } sub tests_cache_map { #$debugcache = 1 ; my @cache_files = qw ( 100_200 101_201 120_220 142_242 143_243 177_277 177_278 177_279 155_255 180_280 181_280 182_280 130_231 130_2301 161_260 1601_260 ) ; my $msgs_1 = [120, 142, 143, 144, 161, 1601, 177, 182, 130 ]; my $msgs_2 = [ 242, 243, 260, 299, 377, 279, 255, 280, 231, 2301 ]; my( $c12, $c21 ) ; ok( ( $c12, $c21 ) = cache_map( \@cache_files, $msgs_1, $msgs_2 ), 'cache_map: 02' ); my $a1 = [ sort { $a <=> $b } keys %$c12 ] ; my $a2 = [ sort { $a <=> $b } keys %$c21 ] ; ok( 0 == compare_lists( [ 130, 142, 143, 177, 182, 1601 ], $a1 ), 'cache_map: 03' ); ok( 0 == compare_lists( [ 242, 243, 260, 279, 280, 2301 ], $a2 ), 'cache_map: 04' ); ok( ! $c12->{161}, 'cache_map: ! 161 -> 260' ); ok( 260 == $c12->{1601}, 'cache_map: 1601 -> 260' ); ok( 2301 == $c12->{130}, 'cache_map: 130 -> 2301' ); #print $c12->{1601}, "\n"; } sub get_cache { $debugcache and print "Entering get_cache\n"; my ($cache_dir, $h1_msgs_ref, $h2_msgs_ref) = @_; -d $cache_dir or return( undef ); # exit if cache directory doesn't exist $debugcache and print "cache_dir: $cache_dir\n"; $cache_dir =~ s{\\}{\\\\}g; my @cache_files = bsd_glob( "$cache_dir/*" ) ; #$debugcache and print "cache_files: [@cache_files]\n"; my( $cache_1_2_ref, $cache_2_1_ref ) = cache_map( \@cache_files, $h1_msgs_ref, $h2_msgs_ref ) ; clean_cache( \@cache_files, $cache_1_2_ref ) if ( ! ( defined( $maxsize ) or defined( $minsize ) or defined( $maxage ) or defined( $minage ) ) ); #print "\n", map { "c12 $_ -> $cache_1_2_ref->{ $_ }\n" } keys %$cache_1_2_ref ; #print "\n", map { "c21 $_ -> $cache_2_1_ref->{ $_ }\n" } keys %$cache_2_1_ref ; $debugcache and print "Exiting get_cache\n"; return ( $cache_1_2_ref, $cache_2_1_ref ) ; } sub tests_get_cache { ok( ! get_cache('/cache_no_exist'), 'get_cache: /cache_no_exist' ); ok( ( ! -d 'tmp/cache/F1/F2' or rmtree( 'tmp/cache/F1/F2' )), 'get_cache: rmtree tmp/cache/F1/F2' ) ; ok( mkpath( 'tmp/cache/F1/F2' ), 'get_cache: mkpath tmp/cache/F1/F2' ) ; my @test_files_cache = ( qw( tmp/cache/F1/F2/100_200 tmp/cache/F1/F2/101_201 tmp/cache/F1/F2/120_220 tmp/cache/F1/F2/142_242 tmp/cache/F1/F2/143_243 tmp/cache/F1/F2/177_277 tmp/cache/F1/F2/177_377 tmp/cache/F1/F2/177_777 tmp/cache/F1/F2/155_255 ) ) ; ok( touch(@test_files_cache), 'get_cache: touch tmp/cache/F1/F2/...' ) ; # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 # on live: my $msgs_1 = [120, 142, 143, 144, 177 ]; my $msgs_2 = [ 242, 243, 299, 377, 777, 255 ]; my( $c12, $c21 ) ; ok( ( $c12, $c21 ) = get_cache('tmp/cache/F1/F2', $msgs_1, $msgs_2), 'get_cache: 02' ); my $a1 = [ sort { $a <=> $b } keys %$c12 ] ; my $a2 = [ sort { $a <=> $b } keys %$c21 ] ; ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: 03' ); ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: 04' ); ok( -f 'tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); ok( -f 'tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); ok( ! -f 'tmp/cache/F1/F2/100_200', 'get_cache: file removed 100_200'); ok( ! -f 'tmp/cache/F1/F2/101_201', 'get_cache: file removed 101_201'); # test clean_cache not executed $maxage = 2 ; ok( touch(@test_files_cache), 'get_cache: touch tmp/cache/F1/F2/...' ) ; ok( ( $c12, $c21 ) = get_cache('tmp/cache/F1/F2', $msgs_1, $msgs_2), 'get_cache: 02' ); ok( -f 'tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); ok( -f 'tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); ok( -f 'tmp/cache/F1/F2/100_200', 'get_cache: file NOT removed 100_200'); ok( -f 'tmp/cache/F1/F2/101_201', 'get_cache: file NOT removed 101_201'); # strange files #$debugcache = 1 ; $maxage = undef ; ok( ( ! -d 'tmp/cache/rr\uee' or rmtree( 'tmp/cache/rr\uee' )), 'get_cache: rmtree tmp/cache/rr\uee' ) ; ok( mkpath( 'tmp/cache/rr\uee' ), 'get_cache: mkpath tmp/cache/rr\uee' ) ; @test_files_cache = ( qw( tmp/cache/rr\uee/100_200 tmp/cache/rr\uee/101_201 tmp/cache/rr\uee/120_220 tmp/cache/rr\uee/142_242 tmp/cache/rr\uee/143_243 tmp/cache/rr\uee/177_277 tmp/cache/rr\uee/177_377 tmp/cache/rr\uee/177_777 tmp/cache/rr\uee/155_255 ) ) ; ok( touch(@test_files_cache), 'get_cache: touch strange tmp/cache/...' ) ; # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 # on live: $msgs_1 = [120, 142, 143, 144, 177 ]; $msgs_2 = [ 242, 243, 299, 377, 777, 255 ]; ok( ( $c12, $c21 ) = get_cache('tmp/cache/rr\uee', $msgs_1, $msgs_2), 'get_cache: strange path 02' ); $a1 = [ sort { $a <=> $b } keys %$c12 ] ; $a2 = [ sort { $a <=> $b } keys %$c21 ] ; ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: strange path 03' ); ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: strange path 04' ); ok( -f 'tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 142_242'); ok( -f 'tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 143_243'); ok( ! -f 'tmp/cache/rr\uee/100_200', 'get_cache: strange path file removed 100_200'); ok( ! -f 'tmp/cache/rr\uee/101_201', 'get_cache: strange path file removed 101_201'); } sub match_a_cache_file { my $file = shift ; my ( $uid1, $uid2 ) ; return( ( undef, undef ) ) if ( ! $file ) ; if ( $file =~ m{(?:^|/)(\d+)_(\d+)$} ) { $uid1 = $1 ; $uid2 = $2 ; } return( $uid1, $uid2 ) ; } sub tests_match_a_cache_file { my ( $uid1, $uid2 ) ; ok( ( $uid1, $uid2 ) = match_a_cache_file( ), 'match_a_cache_file: no arg' ) ; ok( ! defined( $uid1 ), 'match_a_cache_file: no arg 1' ) ; ok( ! defined( $uid2 ), 'match_a_cache_file: no arg 2' ) ; ok( ( $uid1, $uid2 ) = match_a_cache_file( '' ), 'match_a_cache_file: empty arg' ) ; ok( ! defined( $uid1 ), 'match_a_cache_file: empty arg 1' ) ; ok( ! defined( $uid2 ), 'match_a_cache_file: empty arg 2' ) ; ok( ( $uid1, $uid2 ) = match_a_cache_file( '000_000' ), 'match_a_cache_file: 000_000' ) ; ok( '000' eq $uid1, 'match_a_cache_file: 000_000 1' ) ; ok( '000' eq $uid2, 'match_a_cache_file: 000_000 2' ) ; ok( ( $uid1, $uid2 ) = match_a_cache_file( '123_456' ), 'match_a_cache_file: 123_456' ) ; ok( '123' eq $uid1, 'match_a_cache_file: 123_456 1' ) ; ok( '456' eq $uid2, 'match_a_cache_file: 123_456 2' ) ; ok( ( $uid1, $uid2 ) = match_a_cache_file( '/tmp/truc/123_456' ), 'match_a_cache_file: /tmp/truc/123_456' ) ; ok( '123' eq $uid1, 'match_a_cache_file: /tmp/truc/123_456 1' ) ; ok( '456' eq $uid2, 'match_a_cache_file: /tmp/truc/123_456 2' ) ; ok( ( $uid1, $uid2 ) = match_a_cache_file( '/lala123_456' ), 'match_a_cache_file: NO /lala123_456' ) ; ok( ! $uid1, 'match_a_cache_file: /lala123_456 1' ) ; ok( ! $uid2, 'match_a_cache_file: /lala123_456 2' ) ; ok( ( $uid1, $uid2 ) = match_a_cache_file( 'la123_456' ), 'match_a_cache_file: NO la123_456' ) ; ok( ! $uid1, 'match_a_cache_file: la123_456 1' ) ; ok( ! $uid2, 'match_a_cache_file: la123_456 2' ) ; } sub clean_cache { my $cache_files_ref = shift ; my $cache_1_2_ref = shift ; $debugcache and print "Entering clean_cache\n"; $debugcache and print map { "$_ -> " . $cache_1_2_ref->{ $_ } . "\n" } keys %$cache_1_2_ref ; foreach my $file ( @$cache_files_ref ) { $debugcache and print "$file\n" ; my ( $uid1, $uid2 ) = match_a_cache_file( $file ) ; $debugcache and print "u1: $uid1 u2: $uid2 c12: ", $cache_1_2_ref->{ $uid1 } || '', "\n" ; if ( ( ! defined( $uid1 ) ) or ( ! defined( $uid2 ) ) or ( ! exists( $cache_1_2_ref->{ $uid1 } ) ) or ( ! ( $uid2 == $cache_1_2_ref->{ $uid1 } ) ) ) { $debugcache and print "remove $file\n" ; unlink( $file ) or warn "$!" ; } } $debugcache and print "Exiting clean_cache\n"; return( 1 ) ; } sub tests_clean_cache { ok( ( ! -d 'tmp/cache/G1/G2' or rmtree( 'tmp/cache/G1/G2' )), 'clean_cache: rmtree tmp/cache/G1/G2' ) ; ok( mkpath( 'tmp/cache/G1/G2' ), 'clean_cache: mkpath tmp/cache/G1/G2' ) ; my @test_files_cache = ( qw( tmp/cache/G1/G2/100_200 tmp/cache/G1/G2/101_201 tmp/cache/G1/G2/120_220 tmp/cache/G1/G2/142_242 tmp/cache/G1/G2/143_243 tmp/cache/G1/G2/177_277 tmp/cache/G1/G2/177_377 tmp/cache/G1/G2/177_777 tmp/cache/G1/G2/155_255 ) ) ; ok( touch(@test_files_cache), 'clean_cache: touch tmp/cache/G1/G2/...' ) ; ok( -f 'tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 before' ); ok( -f 'tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 before' ); ok( -f 'tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 before' ); ok( -f 'tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 before' ); ok( -f 'tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 before' ); ok( -f 'tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 before' ); my $cache = { 142 => 242, 177 => 777, } ; ok( clean_cache( \@test_files_cache, $cache ), 'clean_cache: ' ) ; ok( ! -f 'tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 after' ); ok( -f 'tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 after' ); ok( ! -f 'tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 after' ); ok( ! -f 'tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 after' ); ok( -f 'tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 after' ); ok( ! -f 'tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 after' ); } sub tests_touch { ok( (-d 'tmp/tests/' or mkpath( 'tmp/tests/' )), 'tests_touch: mkpath tmp/tests/' ) ; ok( 1 == touch( 'tmp/tests/lala'), 'tests_touch: tmp/tests/lala') ; ok( 1 == touch( 'tmp/tests/\y'), 'tests_touch: tmp/tests/\y') ; ok( 0 == touch( '/aaa'), 'tests_touch: not /aaa') ; ok( 2 == touch( 'tmp/tests/lili', 'tmp/tests/lolo'), 'tests_touch: 2 files') ; ok( 1 == touch( 'tmp/tests/\y', '/aaa'), 'tests_touch: 2 files, 1 fails' ) ; } sub touch { my @files = @_ ; my @result; foreach my $file ( @files ) { my $fh = new IO::File ; if ($fh->open(">> $file")) { $fh->close ; push(@result, $file) ; } } return(@result); } sub cache_folder { my( $cache_dir, $h1_fold, $h2_fold ) = @_ ; #print "sep1 $h1_sep sep2 $h2_sep\n"; my $sep1 = $h1_sep || '/'; my $sep2 = $h2_sep || '/'; my $h1_fold_slash = convert_sep_to_slash( $h1_fold, $sep1 ); my $h2_fold_slash = convert_sep_to_slash( $h2_fold, $sep2 ); return( "$cache_dir/$h1_fold_slash/$h2_fold_slash" ) ; } sub convert_sep_to_slash { my ($folder, $sep) = @_; $folder =~ s{\Q$sep\E}{/}g; return($folder); } sub tests_convert_sep_to_slash { ok('' eq convert_sep_to_slash('', '/'), 'convert_sep_to_slash: no folder'); ok('INBOX' eq convert_sep_to_slash('INBOX', '/'), 'convert_sep_to_slash: INBOX'); ok('INBOX/foo' eq convert_sep_to_slash('INBOX/foo', '/'), 'convert_sep_to_slash: INBOX/foo'); ok('INBOX/foo' eq convert_sep_to_slash('INBOX_foo', '_'), 'convert_sep_to_slash: INBOX_foo'); ok('INBOX/foo/zob' eq convert_sep_to_slash('INBOX_foo_zob', '_'), 'convert_sep_to_slash: INBOX_foo_zob'); ok('INBOX/foo' eq convert_sep_to_slash('INBOX.foo', '.'), 'convert_sep_to_slash: INBOX.foo'); ok('INBOX/foo/hi' eq convert_sep_to_slash('INBOX.foo.hi', '.'), 'convert_sep_to_slash: INBOX.foo.hi'); } sub tests_regexmess { ok("blabla" eq regexmess("blabla"), "regexmess, no regexmess, nothing to do"); @regexmess = ('s/p/Z/g'); ok("ZoZoZo" eq regexmess("popopo"), "regexmess, s/p/Z/g"); @regexmess = 's{c}{C}gxms'; ok("H1: abC\nH2: Cde\n\nBody abC" eq regexmess("H1: abc\nH2: cde\n\nBody abc"), "regexmess, c->C"); @regexmess = 's{\AFrom\ }{From:}gxms'; ok( '' eq regexmess(''), 'From mbox 1 add colon blank'); ok( 'From:' eq regexmess('From '), 'From mbox 2 add colo'); ok( "\n" . 'From ' eq regexmess("\n" . 'From '), 'From mbox 3 add colo'); ok( "From: zzz\n" . 'From ' eq regexmess("From zzz\n" . 'From '), 'From mbox 4 add colo'); @regexmess = 's{\AFrom\ [^\n]*(\n)?}{}gxms'; ok( '' eq regexmess(''), 'From mbox 1 remove, blank'); ok( '' eq regexmess('From '), 'From mbox 2 remove'); ok( "\n" . 'From ' eq regexmess("\n" . 'From '), 'From mbox 3 remove'); #print "[", regexmess("From zzz\n" . 'From '), "]"; ok( "" . 'From ' eq regexmess("From zzz\n" . 'From '), 'From mbox 4 remove'); ok( 'Date: Sat, 10 Jul 2010 05:34:45 -0700 From: Hello, Bye.' eq regexmess( 'From zzz Date: Sat, 10 Jul 2010 05:34:45 -0700 From: Hello, Bye.' ), 'From mbox 5 remove'); } sub regexmess { my ($string) = @_; foreach my $regexmess (@regexmess) { $debug and print "eval \$string =~ $regexmess\n"; eval("\$string =~ $regexmess"); die_clean("error: eval regexmess '$regexmess': $@\n") if $@; } return($string); } sub stats { $timeend = time(); $timediff = $timeend - $timestart; my $memory_consumption = memory_consumption(); my $memory_ratio = ($max_msg_size_in_bytes) ? sprintf('%.1f', $memory_consumption / $max_msg_size_in_bytes) : "NA"; my $host1_reconnect_count = $imap1->Reconnect_counter() || 0; my $host2_reconnect_count = $imap2->Reconnect_counter() || 0; print "++++ Statistics\n"; print "Transfer time : $timediff sec\n"; print "Messages transferred : $nb_msg_transferred "; print "(could be $nb_msg_skipped_dry_mode without dry mode)" if ($dry); print "\n"; print "Messages skipped : $nb_msg_skipped\n"; print "Messages found duplicate on host1 : $h1_nb_msg_duplicate\n"; print "Messages found duplicate on host2 : $h2_nb_msg_duplicate\n"; print "Messages void (noheader) on host1 : $h1_nb_msg_noheader\n"; print "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n"; print "Messages deleted on host1 : $h1_nb_msg_deleted\n"; print "Messages deleted on host2 : $h2_nb_msg_deleted\n"; print "Total bytes transferred : $total_bytes_transferred\n"; print "Total bytes duplicate host1 : $h1_total_bytes_duplicate\n"; print "Total bytes duplicate host2 : $h2_total_bytes_duplicate\n"; print "Total bytes skipped : $total_bytes_skipped\n"; print "Total bytes error : $total_bytes_error\n"; $timediff ||= 1; # No division per 0 printf ("Message rate : %.1f messages/s\n", $nb_msg_transferred / $timediff); printf ("Average bandwidth rate : %.1f KiB/s\n", $total_bytes_transferred / 1024 / $timediff); print "Reconnections to host1 : $host1_reconnect_count\n"; print "Reconnections to host2 : $host2_reconnect_count\n"; printf ("Memory consumption : %.1f MB\n", $memory_consumption / 1024 / 1024); print "Biggest message : $max_msg_size_in_bytes bytes\n"; print "Memory/biggest message ratio : $memory_ratio\n"; print "Detected $nb_errors errors\n\n"; print $warn_release, "\n"; print thank_author(); } sub thank_author { return("Homepage: http://www.linux-france.org/prj/imapsync/\n"); my $basename = imapsync_basename(); $debug and print "[$basename]\n"; return("Homepage: http://www.linux-france.org/prj/imapsync/\n") if ( $basename =~ /\.exe$|\.bin$/ ); return(join("", "Happy with this free, open and gratis DWTFPL software?\n", "Encourage the author (Gilles LAMIRAL) by giving him a book\n", "or just money via paypal:\n", "http://www.linux-france.org/prj/imapsync/\n")); } sub get_options { my $numopt = scalar(@ARGV); my $argv = join("¤", @ARGV); $test_builder = Test::More->builder; $test_builder->no_ending(1); if($argv =~ m/-delete¤2/) { print "May be you mean --delete2 instead of --delete 2\n"; exit 1; } my $opt_ret = GetOptions( "debug!" => \$debug, "debugimap!" => \$debugimap, "debugimap1!" => \$debugimap1, "debugimap2!" => \$debugimap2, "host1=s" => \$host1, "host2=s" => \$host2, "port1=i" => \$port1, "port2=i" => \$port2, "user1=s" => \$user1, "user2=s" => \$user2, "domain1=s" => \$domain1, "domain2=s" => \$domain2, "password1=s" => \$password1, "password2=s" => \$password2, "passfile1=s" => \$passfile1, "passfile2=s" => \$passfile2, "authmd5!" => \$authmd5, "authmd51!" => \$authmd51, "authmd52!" => \$authmd52, "sep1=s" => \$sep1, "sep2=s" => \$sep2, "folder=s" => \@folder, "folderrec=s" => \@folderrec, "include=s" => \@include, "exclude=s" => \@exclude, "prefix1=s" => \$prefix1, "prefix2=s" => \$prefix2, "regextrans2=s" => \@regextrans2, "regexmess=s" => \@regexmess, "regexflag=s" => \@regexflag, "delete!" => \$delete, "delete2!" => \$delete2, "delete2folders!" => \$delete2folders, "delete2foldersonly=s" => \$delete2foldersonly, "delete2foldersbutnot=s" => \$delete2foldersbutnot, "syncinternaldates!" => \$syncinternaldates, "idatefromheader!" => \$idatefromheader, "syncacls!" => \$syncacls, "maxsize=i" => \$maxsize, "minsize=i" => \$minsize, "maxage=i" => \$maxage, "minage=i" => \$minage, "foldersizes!" => \$foldersizes, "dry!" => \$dry, "expunge!" => \$expunge, "expunge1!" => \$expunge1, "expunge2!" => \$expunge2, "uidexpunge2!" => \$uidexpunge2, "subscribed!" => \$subscribed, "subscribe!" => \$subscribe, "subscribe_all!" => \$subscribe_all, "justbanner!" => \$justbanner, "justconnect!"=> \$justconnect, "justfolders!"=> \$justfolders, "justfoldersizes!" => \$justfoldersizes, "fast!" => \$fast, "version" => \$version, "help" => \$help, "timeout=i" => \$timeout, "skipheader=s" => \$skipheader, "useheader=s" => \@useheader, "skipsize!" => \$skipsize, "allowsizemismatch!" => \$allowsizemismatch, "fastio1!" => \$fastio1, "fastio2!" => \$fastio2, "ssl1!" => \$ssl1, "ssl2!" => \$ssl2, "tls1!" => \$tls1, "tls2!" => \$tls2, "uid1!" => \$uid1, "uid2!" => \$uid2, "authmech1=s" => \$authmech1, "authmech2=s" => \$authmech2, "authuser1=s" => \$authuser1, "authuser2=s" => \$authuser2, "proxyauth1" => \$proxyauth1, "proxyauth2" => \$proxyauth1, "split1=i" => \$split1, "split2=i" => \$split2, "buffersize=i" => \$buffersize, "reconnectretry1=i" => \$reconnectretry1, "reconnectretry2=i" => \$reconnectretry2, "tests" => \$tests, "tests_debug" => \$tests_debug, "allow3xx!" => \$allow3xx, "justlogin!" => \$justlogin, "tmpdir=s" => \$tmpdir, "pidfile=s" => \$pidfile, "releasecheck!" => \$releasecheck, "modules_version!" => \$modules_version, "usecache!" => \$usecache, "debugcache!" => \$debugcache, "useuid!" => \$useuid, ); $debug and print "get options: [$opt_ret]\n"; # just the version print imapsync_version(), "\n" and exit if ($version) ; if ($tests) { $test_builder->no_ending(0); tests(); exit; } if ($tests_debug) { $test_builder->no_ending(0); tests_debug(); exit; } $help = 1 if ! $numopt; load_modules(); # exit with --help option or no option at all usage() and exit if ($help or ! $numopt) ; # don't go on if options are not all known. exit(EX_USAGE()) unless ($opt_ret) ; } sub load_modules { require IO::Socket::SSL if ($ssl1 or $ssl2 or $tls1 or $tls2); require Term::ReadKey if ( ((not($password1 or $passfile1)) or (not($password2 or $passfile2))) and (not $help)); #require Data::Dumper if ($debug); } sub parse_header_msg { my ($imap, $m_uid, $s_heads, $s_fir, $s, $s_hash) = @_; my $head = $s_heads->{$m_uid}; my $headnum = scalar(keys(%$head)); $debug and print "Head NUM:", $headnum, "\n"; unless($headnum) { print "Warning: no header used or found for message $m_uid\n"; } my $headstr; foreach my $h (sort keys(%$head)){ foreach my $val (sort @{$head->{$h}}) { # no 8-bit data in headers ! $val =~ s/[\x80-\xff]/X/g; # remove the first blanks (dbmail bug ?) $val =~ s/^\s*(.+)$/$1/; # and uppercase header line # (dbmail and dovecot) my $H = uc("$h: $val"); # show stuff in debug mode $debug and print "${s}H $H", "\n"; if ($skipheader and $H =~ m/$skipheader/i) { $debug and print "Skipping header $H\n"; next; } $headstr .= "$H"; } } if ( ( ! $headstr) and ( $takebody ) ){ print "no header so taking body first 2Ko\n"; $imap->fetch($m_uid, "BODY.PEEK[TEXT]<0.2048>"); $headstr = $imap->_transaction_literals; if ( 4048 <= length( $headstr ) ) { # the imap server might reply the whole message # this is bad for memory on huge mailboxes $takebody = 0 ; $headstr = '' ; $h1_msgs_copy_by_uid{ $m_uid } = 1 ; } } return() if ( ! $headstr ); my $size = $s_fir->{$m_uid}->{"RFC822.SIZE"}; my $flags = $s_fir->{$m_uid}->{"FLAGS"}; my $idate = $s_fir->{$m_uid}->{"INTERNALDATE"}; $size = length($headstr) unless ($size); my $m_md5 = md5_base64($headstr); $debug and print "$s msg $m_uid:$m_md5:$size\n"; my $key; if ($skipsize) { $key = "$m_md5"; } else { $key = "$m_md5:$size"; } # 0 return code is used to identify duplicate message hash return 0 if exists $s_hash->{"$key"}; $s_hash->{"$key"}{'5'} = $m_md5; $s_hash->{"$key"}{'s'} = $size; $s_hash->{"$key"}{'D'} = $idate; $s_hash->{"$key"}{'F'} = $flags; $s_hash->{"$key"}{'m'} = $m_uid; } sub firstline { # extract the first line of a file (without \n) my($file) = @_; my $line = ""; open FILE, $file or die_clean("error [$file]: $! "); chomp($line = ); close FILE; $line = ($line) ? $line: "error !EMPTY! [$file]"; return $line; } sub file_to_string { my($file) = @_; my @string; open FILE, $file or die_clean("error [$file]: $! "); @string = ; close FILE; return join("", @string); } sub string_to_file { my($string, $file) = @_; sysopen(FILE, $file,O_WRONLY|O_TRUNC|O_CREAT, 0600) or die_clean("$! $file"); print FILE $string; close FILE; } sub tests_is_a_release_number { ok(is_a_release_number(1.351), 'is_a_release_number 1.351'); ok(is_a_release_number(42.4242), 'is_a_release_number 42.4242'); ok(is_a_release_number(imapsync_version()), 'is_a_release_number imapsync_version()'); ok(! is_a_release_number('blabla' ), '! is_a_release_number blabla'); } sub is_a_release_number { my $number = shift; $number =~ m{\d\.\d+}; } sub check_last_release { my $public_release = not_long('imapsync_version_lfo'); #print "check_last_release: [$public_release]\n" ; return('unknown') if ($public_release eq 'unknown'); return('timeout') if ($public_release eq 'timeout'); return('unknown') if (! is_a_release_number($public_release)); my $imapsync_here = imapsync_version(); if ($public_release > $imapsync_here) { return("New imapsync release $public_release available"); }else{ return("This current imapsync is up to date"); } } sub imapsync_version { my $rcs = '$Id: imapsync,v 1.404 2011/02/21 03:35:39 gilles Exp $ '; $rcs =~ m/,v (\d+\.\d+)/; my $VERSION = ($1) ? $1: "UNKNOWN"; return($VERSION); } sub tests_imapsync_basename { ok('imapsync' eq imapsync_basename(), 'imapsync_basename: imapsync'); ok('blabla' ne imapsync_basename(), '! imapsync_basename: blabla'); } sub imapsync_basename { return basename($0); } sub imapsync_version_lfo { my $local_version = imapsync_version(); my $imapsync_basename = imapsync_basename(); my $agent_info = "$OSNAME system, perl " . sprintf("%vd", $PERL_VERSION) . ", Mail::IMAPClient $Mail::IMAPClient::VERSION" . " $imapsync_basename"; my $sock = new IO::Socket::INET ( PeerAddr => 'imapsync.lamiral.info', PeerPort => '80', Proto => 'tcp'); return('unknown') if not $sock; print $sock "GET /prj/imapsync/VERSION HTTP/1.0\n", "User-Agent: imapsync/$local_version ($agent_info)\n", "Host: www.linux-france.org\n\n"; my @line = <$sock>; close($sock); my $last_release = $line[-1]; chomp($last_release); return($last_release); } sub not_long { #print "Entering not_long\n"; my ($func) = @_; my $val; # Doesn't work with gethostbyname (see perlipc) #local $SIG{ALRM} = sub { die "alarm\n" }; if ('MSWin32' eq $OSNAME) { local $SIG{ALRM} = sub { die "alarm\n" }; }else{ POSIX::sigaction(SIGALRM, POSIX::SigAction->new(sub { die "alarm" })) or warn "Error setting SIGALRM handler: $!\n"; } eval { alarm(3); #print $func, "\n"; { no strict "refs"; #print "Calling $func\n"; $val = &$func(); #print "End of $func\n"; } alarm(0); }; if ($@) { #print "$@"; if ($@ =~ /alarm/) { # timed out return('timeout'); }else{ alarm(0); return('unknown'); # propagate unexpected errors } }else { # didn't return($val); } } sub localhost_info { my($infos) = join("", "Here is a [$OSNAME] system (", join(" ", uname(), ), ")\n", "With perl ", sprintf("%vd", $PERL_VERSION), " Mail::IMAPClient $Mail::IMAPClient::VERSION", ); return($infos); } sub usage { my $localhost_info = localhost_info(); my $thank = thank_author(); my $warn_release =''; $warn_release = check_last_release() if (not defined($releasecheck)); print < : "from" imap server. Mandatory. --port1 : port to connect on host1. Default is 143. --user1 : user to login on host1. Mandatory. --domain1 : domain on host1 (NTLM authentication). --authuser1 : user to auth with on host1 (admin user). Avoid using --authmech1 SOMETHING with --authuser1. --proxyauth1 : Use proxyauth on host1. Requires --authuser1. Required by Sun/iPlanet/Netscape IMAP servers to be able to use an administrative user --password1 : password for the user1. Dangerous, use --passfile1 --passfile1 : password file for the user1. Contains the password. --host2 : "destination" imap server. Mandatory. --port2 : port to connect on host2. Default is 143. --user2 : user to login on host2. Mandatory. --domain2 : domain on host2 (NTLM authentication). --authuser2 : user to auth with on host2 (admin user). --proxyauth2 : Use proxyauth on host2. Requires --authuser2. Required by Sun/iPlanet/Netscape IMAP servers to be able to use an administrative user --password2 : password for the user2. Dangerous, use --passfile2 --passfile2 : password file for the user2. Contains the password. --authmd51 : Use MD5 authentification for host1. --authmd52 : Use MD5 authentification for host2. --authmech1 : auth mechanism to use with host1: PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE. --authmech2 : auth mechanism to use with host2. See --authmech1 --ssl1 : use an SSL connection on host1. --ssl2 : use an SSL connection on host2. --tls1 : use an TLS connection on host1. --tls2 : use an TLS connection on host2. --folder : sync this folder. --folder : and this one, etc. --folderrec : sync this folder recursively. --folderrec : and this one, etc. --include : sync folders matching this regular expression --include : or this one, etc. in case both --include --exclude options are use, include is done before. --exclude : skips folders matching this regular expression Several folders to avoid: --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3. --exclude : or this one, etc. --tmpdir : where to store temporary files and subdirectories. Will be created if it doesn't exist. Default is system specific and should be ok. --pidfile : the file where imapsync pid is written. --prefix1 : remove prefix to all destination folders (usually INBOX. for cyrus imap servers) you can use --prefix1 if your source imap server does not have NAMESPACE capability. --prefix2 : add prefix to all destination folders (usually INBOX. for cyrus imap servers) use --prefix2 if your target imap server does not have NAMESPACE capability. --regextrans2 : Apply the whole regex to each destination folders. --regextrans2 : and this one. etc. When you play with the --regextrans2 option, first add also the safe options --dry --justfolders Then, when happy, remove --dry, remove --justfolders --regexmess : Apply the whole regex to each message before transfer. Example: 's/\\000/ /g' # to replace null by space. --regexmess : and this one. --regexmess : and this one, etc. --regexflag : Apply the whole regex to each flags list. Example: 's/\"Junk"//g' # to remove "Junk" flag. --regexflag : and this one, etc. --sep1 : separator in case namespace is not supported. --sep2 : idem. --delete : delete messages on host1 server after a successful transfer. Useful in case you want to migrate from one server to another one. With imapsync, --delete tags messages as deleted and they are really deleted unless --noexpunge is used. --delete2 : delete messages in host2 that are not in host1 server. --delete2folders : delete folders in host2 that are not in host1 server. For safety, please try it like this (safe): --delete2folders --dry --justfolders --nofoldersizes --delete2foldersonly : delete only folders matching regex. --delete2foldersbutnot : do not delete folders matching regex. --noexpunge : Do not expunge messages on host1. Expunge really deletes messages marked deleted. Expunge is made at the beginning, on host1 only. Newly transferred messages are also expunged if option --delete is given. No expunge is done on host2 account (unless --expunge2) --expunge1 : expunge messages on host1 after the transfer of messages. --expunge2 : expunge messages on host2 after the transfer of messages. --uidexpunge2 : uidexpunge messages on the host2 account that are not on the host1 account, requires --delete2 --syncinternaldates : sets the internal dates on host2 same as host1. Turned on by default. Internal date is the date a message arrived on a host (mtime). --idatefromheader : sets the internal dates on host2 same as the "Date:" headers. --maxsize : skip messages larger (or equal) than bytes --minsize : skip messages smaller (or equal) than bytes --maxage : skip messages older than days. final stats (skipped) don't count older messages see also --minage --minage : skip messages newer than days. final stats (skipped) don't count newer messages You can do (+ are the messages selected): past|----maxage+++++++++++++++>now past|+++++++++++++++minage---->now past|----maxage+++++minage---->now (intersection) past|++++minage-----maxage++++>now (union) --skipheader : Don't take into account header keyword matching ex: --skipheader 'X.*' --useheader : Use this header to compare messages on both sides. Ex: Message-ID or Subject or Date. --useheader and this one, etc. --skipsize : Don't take message size into account to compare messages on both sides. On by default. Use --no-skipsize for using size comparaison. --allowsizemismatch : allow RFC822.SIZE != fetched msg size consider also --skipsize to avoid duplicate messages when running syncs more than one time per mailbox --dry : do nothing, just print what would be done. --subscribed : transfers subscribed folders. --subscribe : subscribe to the folders transferred on the host2 that are subscribed on host1. --subscribe_all : subscribe to the folders transferred on the host2 even if they are not subscribed on host1. --nofoldersizes : Do not calculate the size of each folder in bytes and message counts. Default is to calculate them. --justfoldersizes : exit after printed the folder sizes. --syncacls : synchronises acls (Access Control Lists). --nosyncacls : does not synchronise acls. This is the default. --usecache : Use cache to speedup. --nousecache : Do not use cache. --useuid : Use uid instead of header as a criterium to sync. --usecache is then implied unless --nousecache --debug : debug mode. --debugimap1 : imap debug mode for host1. imap debug is very verbose. --debugimap2 : imap debug mode for host2. --debugimap : imap debug mode for host1 and host2. --version : print software version. --noreleasecheck : do not check for new imapsync release (a http request). --justconnect : just connect to both servers and print useful information. Need only --host1 and --host2 options. --justlogin : just login to both host1 and host2 with users credentials, then exit. --justfolders : just do things about folders (ignore messages). --fast : be faster, equivalent to --useuid --nofoldersizes --reconnectretry1 : reconnect to host1 if connection is lost up to times per imap command (default is 3) --reconnectretry2 : same as --reconnectretry1 but for host2 --split1 : split the requests in several parts on host1. is the number of messages handled per request. default is like --split1 1000. --split2 : same thing on host2. --timeout : imap connect timeout. --help : print this help. Example: to synchronise imap account "foo" on "imap.truc.org" to imap account "bar" on "imap.trac.org" with foo password "secret1" and bar password "secret2" $0 \\ --host1 imap.truc.org --user1 foo --password1 secret1 \\ --host2 imap.trac.org --user2 bar --password2 secret2 $localhost_info $rcs $warn_release $thank EOF } sub good_date { # two incoming formats: # header Tue, 24 Aug 2010 16:00:00 +0200 # internal 24-Aug-2010 16:00:00 +0200 # outgoing format: internal date format # 24-Aug-2010 16:00:00 +0200 my ($d) = @_; return ('') if not defined($d); if ( $d =~ m{(\d?)(\d-...-\d{4})( \d{2}:\d{2}:\d{2})( (?:\+|-)\d{4})?}o ) { #print "internal: [$1][$2][$3][$4]\n"; my ($day_1, $date_rest, $hour, $zone) = ($1,$2,$3,$4); $day_1 = '0' if ($day_1 eq ''); $zone = '' if not defined($zone); $d = $day_1 . $date_rest . $hour . $zone; }elsif ($d =~ m{(?:.{3}, )(\d?)(\d) (...) (\d{4})( \d{2}:\d{2}:\d{2})( (?:\+|-)\d{4})?}o ) { #print "header: [$1][$2][$3][$4][$5][$6]\n"; my ($day_1, $day_rest, $month, $year, $hour, $zone) = ($1,$2,$3,$4,$5,$6); $day_1 = '0' if ($day_1 eq ''); $zone = '' if not defined($zone); $d = $day_1 . "$day_rest-$month-$year" . $hour . $zone; }else{ # unknown/unmatch => return same string return($d); } $d = qq("$d"); return($d); } sub memory_consumption { # memory consumed by imapsync until now in bytes return((memory_consumption_of_pids())[0]); } sub memory_consumption_of_pids { my @PID = (@_) ? @_ : ($PROCESS_ID); #print "PIDs: @PID\n"; my @val; if ('MSWin32' eq $OSNAME) { @val = memory_consumption_of_pids_win32(@PID); }else{ # Unix my @ps = qx{ ps -o vsz @PID }; shift @ps; # First line is column name "VSZ" chomp @ps; # convert to @val = map { $_ * 1024 } @ps; return(@val); } } sub memory_consumption_of_pids_win32 { # Windows my @PID = @_; my %PID; # hash of pids as key values map { $PID{$_}++ } @PID; # Does not work but should reading the tasklist documentation #@ps = qx{ tasklist /FI "PID eq @PID" }; my @ps = qx{ tasklist /NH /FO CSV }; #print "-" x 80, "\n", @ps, "-" x 80, "\n"; my @val; foreach my $line (@ps) { my($name, $pid, $mem) = (split(',', $line))[0,1,4]; next if (! $pid); #print "[$name][$pid][$mem]"; if ($PID{remove_qq($pid)}) { #print "MATCH !\n"; chomp($mem); $mem = remove_qq($mem); $mem = remove_Ko($mem); $mem = remove_not_num($mem); #print "[$mem]\n"; push(@val, $mem * 1024); } } return(@val); } sub remove_not_num { my $string = shift; $string =~ tr/0-9//cd; #print "tr [$string]\n"; return($string); } sub tests_remove_not_num { ok('123' eq remove_not_num(123), 'remove_not_num( 123 )'); ok('123' eq remove_not_num('123'), "remove_not_num( '123' )"); ok('123' eq remove_not_num('12 3'), "remove_not_num( '12 3' )"); ok('123' eq remove_not_num('a 12 3 Ko'), "remove_not_num( 'a 12 3 Ko' )"); } sub remove_Ko { my $string = shift; if ($string =~ /^(.*) Ko$/) { return($1); }else{ return($string); } } sub remove_qq { my $string = shift; if ($string =~ /^"(.*)"$/) { return($1); }else{ return($string); } } sub memory_consumption_ratio { my ($base) = @_; $base ||= 1; my $consu = memory_consumption(); return($consu / $base); } sub tests_memory_consumption { ok(print join("\n", memory_consumption_of_pids()), "\n"); ok(print join("\n", memory_consumption_of_pids('1')), "\n"); ok(print join("\n", memory_consumption_of_pids('1', $$)), "\n"); ok(print memory_consumption_ratio(), "\n"); ok(print memory_consumption_ratio(1), "\n"); ok(print memory_consumption_ratio(10), "\n"); ok(print memory_consumption(), "\n"); } sub tests_good_date { ok('' eq good_date(), 'good_date no arg'); ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24-Aug-2010 16:00:00 +0200'), 'good_date internal 2digit zone'); ok('"24-Aug-2010 16:00:00"' eq good_date('24-Aug-2010 16:00:00'), 'good_date internal 2digit no zone'); ok('"01-Sep-2010 16:00:00 +0200"' eq good_date( '1-Sep-2010 16:00:00 +0200'), 'good_date internal SP 1digit'); ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('Tue, 24 Aug 2010 16:00:00 +0200'), 'good_date header 2digit zone'); ok('"01-Sep-2010 16:00:00"' eq good_date('Wed, 1 Sep 2010 16:00:00'), 'good_date header SP 1digit zone'); ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200'), 'good_date header SP 1digit zone'); ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200 (CEST)'), 'good_date header SP 1digit zone'); } sub tests_list_keys_in_2_not_in_1 { my @list; ok( ! list_keys_in_2_not_in_1( {}, {}), 'list_keys_in_2_not_in_1: {} {}'); ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {}, {} ) ] ), 'list_keys_in_2_not_in_1: {} {}'); ok( 0 == compare_lists( ['a','b'], [ list_keys_in_2_not_in_1( {}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {} {a, b}'); ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a} {a, b}'); ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b} {a, b}'); ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}'); ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}'); } sub list_keys_in_2_not_in_1 { my $folders1_ref = shift; my $folders2_ref = shift; my @list; foreach my $folder ( sort keys %$folders2_ref ) { next if exists($folders1_ref->{$folder}); push(@list, $folder); } return(@list); } sub list_folders_in_2_not_in_1 { my (@h2_folders_not_in_1, %h2_folders_not_in_1); @h2_folders_not_in_1 = list_keys_in_2_not_in_1( \%h1_folders_all, \%h2_folders_all); map { $h2_folders_not_in_1{$_} = 1} @h2_folders_not_in_1; @h2_folders_not_in_1 = list_keys_in_2_not_in_1( \%h2_folders_from_1, \%h2_folders_not_in_1); return( reverse @h2_folders_not_in_1 ); } sub delete_folders_in_2_not_in_1 { my $dry_message = ''; $dry_message = "\t(not really since --dry mode)" if $dry; foreach my $folder (@h2_folders_not_in_1) { if ( defined($delete2foldersonly) and eval("\$folder !~ $delete2foldersonly" ) ) { print "Not deleting $folder because of --delete2foldersonly $delete2foldersonly\n"; next; } if ( defined($delete2foldersbutnot) and eval("\$folder =~ $delete2foldersbutnot" ) ) { print "Not deleting $folder because of --delete2foldersbutnot $delete2foldersbutnot\n"; next; } my $res = $dry; # always success in dry mode! $res = $imap2->delete($folder) if ( ! $dry ) ; if ($res) { print "Delete $folder", "$dry_message", "\n"; }else{ print "Delete $folder failure", "\n"; } } } sub tests_debug { SKIP: { skip "No test in normal run" if ( not $tests_debug ); tests_clean_cache( ) ; tests_match_a_cache_file( ) ; tests_touch( ) ; tests_cache_map( ) ; tests_get_cache( ) ; } } sub tests { SKIP: { skip "No test in normal run" if (not $tests); tests_folder_routines(); tests_compare_lists(); tests_regexmess(); tests_flags_regex(); tests_permanentflags(); tests_flags_filter(); tests_imap2_folder_name(); tests_command_line_nopassword(); tests_good_date(); tests_max(); tests_remove_not_num(); tests_memory_consumption(); tests_is_a_release_number(); tests_imapsync_basename(); tests_list_keys_in_2_not_in_1(); tests_convert_sep_to_slash( ) ; tests_cache_map( ) ; tests_get_cache( ) ; tests_clean_cache( ) ; tests_match_a_cache_file( ) ; tests_touch( ) ; } } # IMAPClient 2.2.9 overrides sub override_imapclient { no warnings 'redefine'; no strict 'subs'; use constant Unconnected => 0; use constant Connected => 1; # connected; not logged in use constant Authenticated => 2; # logged in; no mailbox selected use constant Selected => 3; # mailbox selected use constant INDEX => 0; # Array index for output line number use constant TYPE => 1; # Array index for line type # (either OUTPUT, INPUT, or LITERAL) use constant DATA => 2; # Array index for output line data use constant NonFolderArg => 1; # Value to pass to Massage to # indicate non-folder argument *Mail::IMAPClient::_transaction_literals = sub { my $self = shift; my $string = ""; foreach my $result (@{$self->{"History"}{$self->Transaction}}) { $string .= $result->[DATA] if defined($result) and $self->_is_literal($result) ; } return $string; }; # Got from 3.25 *Mail::IMAPClient::append_string = sub { my $self = shift; my $folder = $self->Massage(shift); my ( $text, $flags, $date ) = @_; defined $text or $text = ''; if ( defined $flags ) { $flags =~ s/^\s+//g; $flags =~ s/\s+$//g; $flags = "($flags)" if $flags !~ /^\(.*\)$/; } if ( defined $date ) { $date =~ s/^\s+//g; $date =~ s/\s+$//g; $date = qq("$date") if $date !~ /^"/; } $text =~ s/\r?\n/$CRLF/og; my $command = "APPEND $folder " . ( $flags ? "$flags " : "" ) . ( $date ? "$date " : "" ) . "{" . length($text) . "}$CRLF"; $command .= $text . $CRLF; $self->_imap_command( $command ) or return undef; my $data = join '', $self->Results; #print "ZZZ|$data|ZZZ\n"; # look for something like return size or self if no size found: # OK [APPENDUID ] APPEND completed # 18 OK [APPENDUID 1286144680 1539] APPEND Ok. my $ret = $data =~ m#^\d+ OK \[APPEND.*\s+(\d+)\].*\Z#m ? $1 : $self; return $ret; }; *Mail::IMAPClient::fetch_hash = sub { # taken from original lib, # just added split code. my $self = shift; my $hash = ref($_[-1]) ? pop @_ : {}; my @words = @_; for (@words) { s/([\( ])FAST([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE$2/i ; s/([\( ])FULL([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE ENVELOPE BODY$2/i ; } my $msgs_ref_all = scalar($self->messages); my $split = $self->Split() || scalar(@$msgs_ref_all); while(my @msgs = splice(@$msgs_ref_all, 0, $split)) { #print "SPLIT: @msgs\n"; my $msgs_ref = \@msgs; my $output = scalar($self->fetch($msgs_ref,"(" . join(" ",@_) . ")")) ; # unless grep(/\b(?:FAST|FULL)\b/i,@words); my $x; for ($x = 0; $x <= $#$output ; $x++) { my $entry = {}; my $l = $output->[$x]; if ($self->Uid) { my($uid) = $l =~ /\((?:.* )?UID (\d+).*\)/i; next unless $uid; if ( exists $hash->{$uid} ) { $entry = $hash->{$uid} ; } else { $hash->{$uid} ||= $entry; } } else { my($mid) = $l =~ /^\* (\d+) FETCH/i; next unless $mid; if ( exists $hash->{$mid} ) { $entry = $hash->{$mid} ; } else { $hash->{$mid} ||= $entry; } } foreach my $w (@words) { if ( $l =~ /\Q$w\E\s*$/i ) { $entry->{$w} = $output->[$x+1]; $entry->{$w} =~ s/(?:\x0a?\x0d)+$//g; chomp $entry->{$w}; } else { $l =~ /\( # open paren followed by ... (?:.*\s)? # ...optional stuff and a space \Q$w\E\s # escaped fetch field (?:" # then: a dbl-quote (\\.| # then bslashed anychar(s) or ... [^"]+) # ... nonquote char(s) "| # then closing quote; or ... \( # ...an open paren (\\.| # then bslashed anychar or ... [^\)]*) # ... non-close-paren char \)| # then closing paren; or ... (\S+)) # unquoted string (?:\s.*)? # possibly followed by space-stuff \) # close paren /xi; $entry->{$w}=defined($1)?$1:defined($2)?$2:$3; } } } } return wantarray ? %$hash : $hash; }; *Mail::IMAPClient::login = sub { my $self = shift; return $self->authenticate($self->Authmechanism,$self->Authcallback) if $self->{Authmechanism}; my $id = $self->User; my $has_quotes = $id =~ /^".*"$/ ? 1 : 0; my $string = "Login " . ( $has_quotes ? $id : qq("$id") ) . " " . $self->Password . "\r\n"; $self->_imap_command($string) and $self->State(Authenticated); # $self->folders and $self->separator unless $self->NoAutoList; unless ( $self->IsAuthenticated) { my($carp) = $self->LastError; $carp =~ s/^[\S]+ ([^\x0d\x0a]*)\x0d?\x0a/$1/; carp $carp unless defined wantarray; return undef; }; return $self; }; *Mail::IMAPClient::get_header = sub { my($self , $msg, $header ) = @_; my $val; #eval { $val = $self->parse_headers([$msg],$header)->{$header}[0] }; my $h = $self->parse_headers([$msg],$header); #require Data::Dumper; #print Data::Dumper->Dump([$h]); #$val = $self->parse_headers([$msg],$header)->{$header}[0]; $val = $h->{$msg}{$header}[0]; return defined($val)? $val : undef; }; *Mail::IMAPClient::parse_headers = sub { my($self,$msgspec_all,@fields) = @_; my(%fieldmap) = map { ( lc($_),$_ ) } @fields; my $msg; my $string; my $field; #print ref($msgspec_all), "\n"; #if(ref($msgspec_all) eq 'HASH') { # print ref($msgspec_all), "\n"; #$msgspec_all = [$msgspec_all]; #} unless(ref($msgspec_all) eq 'ARRAY') { print "parse_headers want an ARRAY ref\n"; #exit 1; return undef; } my $headers = {}; # hash from message ids to header hash my $split = $self->Split() || scalar(@$msgspec_all); while(my @msgs = splice(@$msgspec_all, 0, $split)) { $debug and print "SPLIT: @msgs\n"; my $msgspec = \@msgs; # Make $msg a comma separated list, of messages we want $msg = $self->Range($msgspec); if ($fields[0] =~ /^[Aa][Ll]{2}$/ ) { $string = "$msg body" . # use ".peek" if Peek parameter is a) defined and true, # or b) undefined, but not if it's defined and untrue: ( defined($self->Peek) ? ( $self->Peek ? ".peek" : "" ) : ".peek" ) . "[header]" ; }else { $string = "$msg body" . # use ".peek" if Peek parameter is a) defined and true, or # b) undefined, but not if it's defined and untrue: ( defined($self->Peek) ? ( $self->Peek ? ".peek" : "" ) : ".peek" ) . "[header.fields (" . join(" ",@fields) . ')]' ; } my @raw=$self->fetch( $string ) or return undef; my $h = 0; # reference to hash of current msgid, or 0 between msgs for my $header (map { split(/(?:\x0d\x0a)/,$_) } @raw) { no warnings; if ( $header =~ /^\*\s+\d+\s+FETCH\s+\(.*BODY\[HEADER(?:\]|\.FIELDS)/i) { if ($self->Uid) { if ( my($msgid) = $header =~ /UID\s+(\d+)/ ) { $h = {}; $headers->{$msgid} = $h; } else { $h = {}; } } else { if ( my($msgid) = $header =~ /^\*\s+(\d+)/ ) { #start of new message header: $h = {}; $headers->{$msgid} = $h; } } } next if $header =~ /^\s+$/; # ( for vi if ($header =~ /^\)/) { # end of this message $h = 0; # set to be between messages next; } # check for 'UID)' # when parsing headers by UID. if ($self->Uid and my($msgid) = $header =~ /^\s*UID\s+(\d+)\s*\)/) { $headers->{$msgid} = $h; # store in results against this message $h = 0; # set to be between messages next; } if ($h != 0) { # do we expect this to be a header? my $hdr = $header; chomp $hdr; $hdr =~ s/\r$//; #print "W[$hdr]", ref($hdr), "!\n"; #next if ( ! defined($hdr)); #print "X[$hdr]\n"; if (defined($hdr) and ($hdr =~ s/^(\S+):\s*//)) { # if ($hdr =~ s/^(\S+):\s*//) { #print "X1\n"; $field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ; push @{$h->{$field}} , $hdr ; } elsif ($hdr =~ s/^.*FETCH\s\(.*BODY\[HEADER\.FIELDS.*\)\]\s(\S+):\s*//) { #print "X2\n"; $field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ; push @{$h->{$field}} , $hdr ; } elsif ( ref($h->{$field}) eq 'ARRAY') { #print "X3\n"; $hdr =~ s/^\s+/ /; $h->{$field}[-1] .= $hdr ; } } } use warnings; # my $candump = 0; # if ($self->Debug) { # eval { # require Data::Dumper; # Data::Dumper->import; # }; # $candump++ unless $@; # } } # if we asked for one message, just return its hash, # otherwise, return hash of numbers => header hash # if (ref($msgspec) eq 'ARRAY') { return $headers; }; *Mail::IMAPClient::authenticate = sub { my $self = shift; my $scheme = shift; my $response = shift; $scheme ||= $self->Authmechanism; $response ||= $self->Authcallback; my $clear = $self->Clear; $self->Clear($clear) if $self->Count >= $clear and $clear > 0; my $count = $self->Count($self->Count+1); my $string = "$count AUTHENTICATE $scheme"; $self->_record($count,[ $self->_next_index($self->Transaction), "INPUT", "$string\x0d\x0a"] ); my $feedback = $self->_send_line("$string"); unless ($feedback) { $self->LastError("Error sending '$string' to IMAP: $!\n"); return undef; } my ($code, $output); until ($code) { $output = $self->_read_line or return undef; foreach my $o (@$output) { $self->_record($count,$o); # $o is a ref ($code) = $o->[DATA] =~ /^\+(.*)$/ ; if ($o->[DATA] =~ /^\*\s+BYE/) { $self->State(Unconnected); return undef ; } if ($o->[DATA]=~ /^\d+\s+(NO|BAD)/i) { return undef ; } } } if ('CRAM-MD5' eq $scheme && ! $response) { if ($Mail::IMAPClient::_CRAM_MD5_ERR) { $self->LastError($Mail::IMAPClient::_CRAM_MD5_ERR); carp $Mail::IMAPClient::_CRAM_MD5_ERR; } else { $response = \&Mail::IMAPClient::_cram_md5; } } $feedback = $self->_send_line($response->($code, $self)); unless ($feedback) { $self->LastError("Error sending append msg text to IMAP: $!\n"); return undef; } $code = ""; # clear code until ($code) { $output = $self->_read_line or return undef; foreach my $o (@$output) { $self->_record($count,$o); # $o is a ref if ( ($code) = $o->[DATA] =~ /^\+ (.*)$/ ) { $feedback = $self->_send_line($response->($code,$self)); unless ($feedback) { $self->LastError("Error sending append msg text to IMAP: $!\n"); return undef; } $code = "" ; # Clear code; we're still not finished } else { $o->[DATA] =~ /^$count (OK|NO|BAD)/ and $code = $1; if ($o->[DATA] =~ /^\*\s+BYE/) { $self->State(Unconnected); return undef ; } } } } $code =~ /^OK/ and $self->State(Authenticated) ; return $code =~ /^OK/ ? $self : undef ; }; *Mail::IMAPClient::_cram_md5 = sub { my ($code, $client) = @_; my $hmac = Digest::HMAC_MD5::hmac_md5_hex(MIME::Base64::decode($code), $client->Password()); return MIME::Base64::encode($client->User() . " $hmac", ""); }; *Mail::IMAPClient::message_string = sub { my $self = shift; my $msg = shift; my $expected_size = $self->size($msg); return undef unless(defined $expected_size); # unable to get size my $cmd = $self->has_capability('IMAP4REV1') ? "BODY" . ( $self->Peek ? '.PEEK[]' : '[]' ) : "RFC822" . ( $self->Peek ? '.PEEK' : '' ) ; #print "Message_string Beg fetch:\n", memory_consumption(); $self->fetch($msg,$cmd) or return undef; #print "Message_string End fetch:\n", memory_consumption(); my $string = ""; foreach my $result (@{$self->{"History"}{$self->Transaction}}) { $string .= $result->[DATA] if defined($result) and $self->_is_literal($result) ; } #print "Message_string End string:\n", memory_consumption(); # BUG? should probably return undef if length != expected # No bug, somme servers are buggy. if (! $self->Ignoresizeerrors ) { if ( length($string) != $expected_size ) { warn "message_string: " . "expected $expected_size bytes but received " . length($string) . "\n"; $self->LastError("message_string: expected ". "$expected_size bytes but received " . length($string)."\n"); } } return $string; }; { no warnings 'once'; *Mail::IMAPClient::Ssl = sub { my $self = shift; if (@_) { $self->{SSL} = shift } return $self->{SSL}; }; *Mail::IMAPClient::exists = sub { my ( $self, $folder ) = @_; $self->status($folder) ? $self : undef; }; *Mail::IMAPClient::Authuser = sub { my $self = shift; if (@_) { $self->{AUTHUSER} = shift } return $self->{AUTHUSER}; }; *Mail::IMAPClient::Ignoresizeerrors = sub { my $self = shift; if (@_) { $self->{IGNORESIZEERRORS} = shift } return $self->{IGNORESIZEERRORS}; }; *Mail::IMAPClient::Reconnectretry = sub { my $self = shift; if (@_) { $self->{RECONNECTRETRY} = shift } return $self->{RECONNECTRETRY}; }; *Mail::IMAPClient::reconnect = sub { my $self = shift; if ( $self->IsAuthenticated ) { $self->_debug("reconnect called but already authenticated"); return $self; } my $einfo = $self->LastError || ""; $self->_debug( "reconnecting to ", $self->Server, ", last error: $einfo" ); # reconnect and select appropriate folder $self->connect or return undef; return ( defined $self->Folder ) ? $self->select( $self->Folder ) : $self; }; # wrapper for _imap_command_do to enable retrying on lost connections *Mail::IMAPClient::_imap_command = sub { my $self = shift; my $tries = 0; my $retry = $self->Reconnectretry || 0; my ( $rc, @err ); #print "@_ Beg _imap_command:\n", memory_consumption(); # LastError (if set) will be overwritten masking any earlier errors while ( $tries++ <= $retry ) { # do command on the first try or if Connected (reconnect ongoing) if ( $tries == 1 or $self->IsConnected ) { #print "call @_\n"; $rc = $self->_imap_command_do(@_); push( @err, $self->LastError ) if $self->LastError; #print "call @_ done [", $rc || '', "] [$tries/$retry][" . $self->IsUnconnected . "]\n"; } if ( !defined($rc) and $retry and $self->IsUnconnected and ( $self->LastIMAPCommand !~ /LOGOUT/ ) ) { print "\nWarning: disconnected. "; if ( $self->reconnect ) { print "Reconnect successful on try #$tries\n"; $self->Reconnect_counter($self->Reconnect_counter() + 1); } else { print "Reconnect failed on try #$tries\n"; push( @err, $self->LastError ) if $self->LastError; } } else { last; } } unless ($rc) { my ( %seen, @keep, @info ); foreach my $str (@err) { my ( $sz, $len ) = ( 96, length($str) ); $str =~ s/$CR?$LF$/\\n/omg; if ( !$self->Debug and $len > $sz * 2 ) { my $beg = substr( $str, 0, $sz ); my $end = substr( $str, -$sz, $sz ); $str = $beg . "..." . $end; } next if $seen{$str}++; push( @keep, $str ); } foreach my $msg (@keep) { push( @info, $msg . ( $seen{$msg} > 1 ? " ($seen{$msg}x)" : "" ) ); } $self->LastError( join( "; ", @info ) ); } #print "@_ End _imap_command:\n", memory_consumption(); return $rc; }; *Mail::IMAPClient::_imap_command_do = sub { my $self = shift; my $string = shift or return undef; my $good = shift || 'GOOD'; my $qgood = quotemeta($good); my $clear = ""; $clear = $self->Clear; $self->Clear($clear) if $self->Count >= $clear and $clear > 0; my $count = $self->Count($self->Count+1); $string = "$count $string" ; #print "$string\n", memory_consumption(); $self->_record($count,[ 0, "INPUT", "$string\x0d\x0a"] ); #print "\n2 $count\n", memory_consumption(); my $feedback = $self->_send_line("$string"); unless ($feedback) { $self->LastError( "Error sending '$string' to IMAP: $!\n"); $@ = "Error sending '$string' to IMAP: $!"; carp "Error sending '$string' to IMAP: $!"; return undef; } my ($code, $output); $output = ""; READ: until ( $code) { # escape infinite loop if read_line never returns any data: $output = $self->_read_line or return undef; for my $o (@$output) { $self->_record($count,$o); # $o is a ref # $self->_debug("Received from readline: ${\($o->[DATA])}<>\n"); next unless $self->_is_output($o); if ( $good eq '+' ) { $o->[DATA] =~ /^$count (OK|BAD|NO|$qgood)|^($qgood)/mi ; $code = $1||$2 ; } else { ($code) = $o->[DATA] =~ /^$count (OK|BAD|NO|$qgood)/mi ; } if ($o->[DATA] =~ /^\*\s+BYE/im) { $self->State(Unconnected); return undef ; } } } #print "$string: returned $code\n", memory_consumption(); # $self->_debug("Command $string: returned $code\n"); return $code =~ /^OK|$qgood/im ? $self : undef ; }; # capability 2.2.9 is stupid: it caches and return first imap CAPABILITY call # but call imap CAPABILITY each time. # Copy/paste from 3.25 *Mail::IMAPClient::capability = sub { my $self = shift; if ( $self->{CAPABILITY} ) { my @caps = keys %{ $self->{CAPABILITY} }; return wantarray ? @caps : \@caps; } $self->_imap_command('CAPABILITY') or return undef; my @caps = map { split } grep s/^\*\s+CAPABILITY\s+//, $self->History; foreach (@caps) { $self->{CAPABILITY}{ uc $_ }++; $self->{ uc $1 } = uc $2 if /(.*?)\=(.*)/; } return wantarray ? @caps : \@caps; }; *Mail::IMAPClient::_read_line = sub { my $self = shift; my $sh = $self->Socket; my $literal_callback = shift; my $output_callback = shift; unless ($self->IsConnected and $self->Socket) { $self->LastError("NO Not connected.\n"); carp "Not connected" if $^W; return undef; } my $iBuffer = ""; my $oBuffer = []; my $count = 0; my $index = $self->_next_index($self->Transaction); my $rvec = my $ready = my $errors = 0; my $timeout = $self->Timeout; my $readlen = 1; my $fast_io = $self->Fast_io; # Remember setting to reduce future method calls if ( $fast_io ) { # set fcntl if necessary: exists $self->{_fcntl} or $self->Fast_io($fast_io); $readlen = $self->{Buffer}||4096; } until ( # there's stuff in output buffer: scalar(@$oBuffer) and # the last thing there has cr-lf: $oBuffer->[-1][DATA] =~ /\x0d\x0a$/ and # that thing is an output line: $oBuffer->[-1][TYPE] eq "OUTPUT" and # and the input buffer has been MT'ed: $iBuffer eq "" ) { #print memory_consumption(); my $transno = $self->Transaction; # used below in several places if ($timeout) { vec($rvec, fileno($self->Socket), 1) = 1; my @ready = $self->{_select}->can_read($timeout) ; unless ( @ready ) { $self->LastError("Tag $transno: " . "Timeout after $timeout seconds " . "waiting for data from server\n"); $self->_record($transno, [ $self->_next_index($transno), "ERROR", "$transno * NO Timeout after ". "$timeout seconds " . "during read from " . "server\x0d\x0a" ] ); $self->LastError( "Timeout after $timeout seconds " . "during read from server\x0d\x0a" ); return undef; } } #local($^W) = undef; # Now quiet down warnings # read "$readlen" bytes (or less): # need to check return code from $self->_sysread # in case other end has shut down!!! my $ret = $self->_sysread( $sh, \$iBuffer, $readlen, length($iBuffer)) ; # $self->_debug("Read so far: $iBuffer<>\n"); redo if(! defined($ret)) ; if(($timeout and ! defined($ret))) { # Blocking read error... my $msg = "Error while reading data from server: $!\x0d\x0a"; $self->LastError('Error while reading data from server'); $self->State(Unconnected); print $msg; $self->_record($transno, [ $self->_next_index($transno), "ERROR", "$transno * NO $msg " ]); $@ = "$msg"; return undef; } elsif(defined($ret) and $ret == 0) { # Caught EOF... my $msg="Socket closed while reading data from server [$!]\x0d\x0a"; print "$msg"; $self->LastError('Socket closed while reading data from server'); $self->State(Unconnected); $self->_record($transno, [ $self->_next_index($transno), "ERROR", "$transno * NO $msg " ]); $@ = "$msg"; return undef; } # successfully wrote to other end, keep going... $count += $ret; LINES: while ( $iBuffer =~ s/^(.*?\x0d?\x0a)// ) { my $current_line = $1; #print memory_consumption(); # $self->_debug("BUFFER: pulled from buffer: ${current_line}\n" . # "and left with buffer contents of: ${iBuffer}\n"); LITERAL: if ($current_line =~ s/\{(\d+)\}\x0d\x0a$//) { # This part handles IMAP "Literals", # which according to rfc2060 look something like this: # [tag]|* BLAH BLAH {nnn}\r\n # [nnn bytes of literally transmitted stuff] # [part of line that follows literal data]\r\n # Set $len to be length of impending literal: my $len = $1 ; $self->_debug("LITERAL: received literal in line ". "$current_line of length $len; ". "attempting to ". "retrieve from the " . length($iBuffer) . " bytes in: $iBuffer\n"); # Xfer up to $len bytes from front of $iBuffer to $litstring: my $litstring = substr($iBuffer, 0, $len); $iBuffer = substr($iBuffer, length($litstring), length($iBuffer) - length($litstring) ) ; # Figure out what's left to read (i.e. what part of # literal wasn't in buffer): my $remainder_count = $len - length($litstring); my $callback_value = ""; if ( defined($literal_callback) ) { if ( $literal_callback =~ /GLOB/) { print $literal_callback $litstring ; $litstring = ""; } elsif ($literal_callback =~ /CODE/ ) { # Don't do a thing } else { $self->LastError( ref($literal_callback) . " is an invalid callback type; " . "must be a filehandle or coderef\n" ); } } if ($remainder_count > 0 and $timeout) { # If we're doing timeouts then here we set up select # and wait for data from the the IMAP socket. vec($rvec, fileno($self->Socket), 1) = 1; unless ( CORE::select( $ready = $rvec, undef, $errors = $rvec, $timeout) ) { # Select failed; that means bad news. # Better tell someone. $self->LastError("Tag " . $transno . ": Timeout waiting for literal data " . "from server\n"); carp "Tag " . $transno . ": Timeout waiting for literal data " . "from server\n" if $self->Debug or $^W; return undef; } } fcntl($sh, F_SETFL, $self->{_fcntl}) if $fast_io and defined($self->{_fcntl}); while ( $remainder_count > 0 ) { # As long as not done, $self->_debug("Still need $remainder_count to " . "complete literal string\n"); my $ret = $self->_sysread( # bytes read $sh, # IMAP handle \$litstring, # place to read into $remainder_count, # bytes left to read length($litstring) # offset to read into ) ; $self->_debug("Received ret=$ret and buffer = " . "\n$litstring\nwhile processing LITERAL\n"); if ( $timeout and !defined($ret)) { # possible timeout $self->_record($transno, [ $self->_next_index($transno), "ERROR", "$transno * NO Error reading data " . "from server: $!\n" ] ); return undef; } elsif ( $ret == 0 and eof($sh) ) { $self->_record($transno, [ $self->_next_index($transno), "ERROR", "$transno * ". "BYE Server unexpectedly " . "closed connection: $!\n" ] ); $self->State(Unconnected); return undef; } # decrement remaining bytes by amt read: $remainder_count -= $ret; if ( length($litstring) > $len ) { # copy the extra struff into the iBuffer: $iBuffer = substr( $litstring, $len, length($litstring) - $len ); $litstring = substr($litstring, 0, $len) ; } if ( defined($literal_callback) ) { if ( $literal_callback =~ /GLOB/ ) { print $literal_callback $litstring; $litstring = ""; } } } $literal_callback->($litstring) if defined($litstring) and defined($literal_callback) and $literal_callback =~ /CODE/; $self->Fast_io($fast_io) if $fast_io; # Now let's make sure there are no IMAP server output lines # (i.e. [tag|*] BAD|NO|OK Text) embedded in the literal string # (There shouldn't be but I've seen it done!), but only if # EnableServerResponseInLiteral is set to true my $embedded_output = 0; my $lastline = ( split(/\x0d?\x0a/,$litstring))[-1] if $litstring; if ( $self->EnableServerResponseInLiteral and $lastline and $lastline =~ /^(?:\*|(\d+))\s(BAD|NO|OK)/i ) { $litstring =~ s/\Q$lastline\E\x0d?\x0a//; $embedded_output++; $self->_debug("Got server output mixed in " . "with literal: $lastline\n" ) if $self->Debug; } # Finally, we need to stuff the literal onto the # end of the oBuffer: push @$oBuffer, [ $index++, "OUTPUT" , $current_line], [ $index++, "LITERAL", $litstring ]; push @$oBuffer, [ $index++, "OUTPUT", $lastline ] if $embedded_output; } else { push @$oBuffer, [ $index++, "OUTPUT" , $current_line ]; } } #$self->_debug("iBuffer is now: $iBuffer<>\n"); } # _debug $self, "Buffer is now $buffer\n"; _debug $self, "Read: " . join("",map {$_->[DATA]} @$oBuffer) ."\n" if $self->Debug; return scalar(@$oBuffer) ? $oBuffer : undef ; }; } # End of sub override_imapclient (yes, very bad indentation) } # IMAPClient 2.2.9 3.xx ads package Mail::IMAPClient; sub Split { my $self = shift; if (@_) { $self->{SPLIT} = shift; $self->{Maxcommandlength} = 10 * $self->{SPLIT}; } return $self->{SPLIT}; } sub Tls { my $self = shift; if (@_) { $self->{TLS} = shift } return $self->{TLS}; } sub Reconnect_counter { my $self = shift; $self->{Reconnect_counter} = 0 if ( not defined( $self->{Reconnect_counter} ) ) ; if (@_) { $self->{Reconnect_counter} = shift } return $self->{Reconnect_counter}; } sub Banner { my $self = shift; if (@_) { $self->{BANNER} = shift } return $self->{BANNER}; } sub RawSocket2 { my ( $self, $sock ) = @_; defined $sock or return $self->{Socket}; $self->{Socket} = $sock; $self->{_select} = IO::Select->new($sock); delete $self->{_fcntl}; #$self->Fast_io( $self->Fast_io ); $sock; } sub capability_update { my $self = shift; delete $self->{CAPABILITY}; $self->capability; } sub fetch_hash_2 { # taken from above *Mail::IMAPClient::fetch_hash # if last arg is a ref then the fetch is done only # on the messages listed as the keys of this hash. # Init an "empty" $hash_ref by value can be done this way: # @$hash_ref{2, 3, 4, 55} = (undef); my $self = shift; my $hash_ref = ref($_[-1]) ? pop @_ : {}; my @words = @_; for (@words) { s/([\( ])FAST([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE$2/i ; s/([\( ])FULL([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE ENVELOPE BODY$2/i ; } my $msgs_ref_all; if (scalar %$hash_ref) { $msgs_ref_all = [ sort { $a <=> $b } keys (%$hash_ref) ]; #print "ZZZZ 1 [@$msgs_ref_all]\n"; }else{ $msgs_ref_all = scalar($self->messages); #print "ZZZZ 2 [@$msgs_ref_all]\n"; } my $split = $self->Split() || scalar(@$msgs_ref_all); while(my @msgs = splice(@$msgs_ref_all, 0, $split)) { #print "SPLIT: @msgs\n"; my $msgs_ref = \@msgs; my $output = scalar($self->fetch($msgs_ref,"(" . join(" ",@_) . ")")) ; # unless grep(/\b(?:FAST|FULL)\b/i,@words); my $x; for ($x = 0; $x <= $#$output ; $x++) { my $entry = {}; my $l = $output->[$x]; if ($self->Uid) { my($uid) = $l =~ /\((?:.* )?UID (\d+).*\)/i; next unless $uid; if ( defined $hash_ref->{$uid} ) { $entry = $hash_ref->{$uid} ; } else { $hash_ref->{$uid} ||= $entry; } } else { my($mid) = $l =~ /^\* (\d+) FETCH/i; next unless $mid; if ( defined $hash_ref->{$mid} ) { $entry = $hash_ref->{$mid} ; } else { $hash_ref->{$mid} ||= $entry; } } foreach my $w (@words) { if ( $l =~ /\Q$w\E\s*$/i ) { $entry->{$w} = $output->[$x+1]; $entry->{$w} =~ s/(?:\x0a?\x0d)+$//g; chomp $entry->{$w}; } else { $l =~ /\( # open paren followed by ... (?:.*\s)? # ...optional stuff and a space \Q$w\E\s # escaped fetch field (?:" # then: a dbl-quote (\\.| # then bslashed anychar(s) or ... [^"]+) # ... nonquote char(s) "| # then closing quote; or ... \( # ...an open paren (\\.| # then bslashed anychar or ... [^\)]*) # ... non-close-paren char \)| # then closing paren; or ... (\S+)) # unquoted string (?:\s.*)? # possibly followed by space-stuff \) # close paren /xi; $entry->{$w}=defined($1)?$1:defined($2)?$2:$3; } } } } return wantarray ? %$hash_ref : $hash_ref; }