diff --git a/CONCEPTION b/CONCEPTION new file mode 100644 index 0000000..a786035 --- /dev/null +++ b/CONCEPTION @@ -0,0 +1,26 @@ + +===== Synopsis ===== + +$mailbox_1 = Mail::imapsync::mailbox->new(); +$mailbox_2 = Mail::imapsync::mailbox->new(); + + +$mailbox_1->host('imap1.lala.org'); +$mailbox_1->user('toto1'); +... + +$mailbox_2->host('imap2.lala.org'); +$mailbox_2->user('toto2'); +... + + +$transfer = Mail::imapsync::transfer->new(); +$transfer->sync($mailbox_1, $mailbox_2); + + +- an object for mailbox +- an object for a transfer +- ?an object for a folder? +- ?an object for a message? + + diff --git a/CREDITS b/CREDITS index 881a2f5..1acafef 100644 --- a/CREDITS +++ b/CREDITS @@ -1,7 +1,8 @@ #!/bin/cat -# $Id: CREDITS,v 1.144 2010/09/06 01:08:41 gilles Exp gilles $ +# $Id: CREDITS,v 1.150 2010/10/24 23:54:09 gilles Exp gilles $ -If you want to make a donation to the author, Gilles LAMIRAL: +If you want to make a donation to the author, Gilles LAMIRAL, +use any of the following ways: a) you can use the imapsync wishlist : http://www.amazon.com/gp/registry/wishlist/1C9UNDIH3P7R7/ @@ -14,12 +15,50 @@ b) If you can read french, please use the following wishlist : c) its paypal account : gilles.lamiral@laposte.net http://www.linux-france.org/prj/imapsync/paypal.html -Here are the persons who helped me to develop imapsync. -Feel free to tell me if a name is missing or if you want -to remove one. +d) If you prefer making your donation with +cash or cheque then my postal address is: + +Gilles LAMIRAL +4 La Billais +35580 Baulon +FRANCE + +Here are the persons who helped me to develop and maintain imapsync. +Feel free to tell me if a name is missing or if you want to remove one. I thank very much all of these people. +Roger Schmid +Contributed by giving money 100 USD + +Danny Schulz +Contributed by giving money 15 USD + +Christian Kowarzik +Contributed by giving money 90 USD +for --deletefolder2 option. + +Harald Petrovitsch +Contributed by giving the book +29.95 "Families and How to Survive Them" + +Tobias Fink +Contributed by giving money 5 Eur + +Yanick Cyr +Contributed by giving money 25 USD + +Trony Tigno +Contributed by giving money 5 USD + +Paul Garner +Contributed by giving money 5 USD + +Kevin Kretz +Contributed by giving the books +15.25 "Tres Cubano: A Complete Guide To Playing The Cuban Tres Guitar (Book & CD)" +24.00 "Creative Clowning" + Kirk Ismay Contributed by giving money 50 USD @@ -907,6 +946,8 @@ Eric Yung Total amount of book prices : c \ +29.95 +\ 11.20+\ 24.95+\ 13.57+\ diff --git a/ChangeLog b/ChangeLog index 53083e3..b2e7178 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,17 +1,90 @@ RCS file: RCS/imapsync,v Working file: imapsync -head: 1.350 +head: 1.366 branch: locks: strict - gilles: 1.350 + gilles: 1.366 access list: symbolic names: keyword substitution: kv -total revisions: 350; selected revisions: 350 +total revisions: 366; selected revisions: 366 description: ---------------------------- -revision 1.350 locked by: gilles; +revision 1.366 locked by: gilles; +date: 2010/10/25 17:15:52; author: gilles; state: Exp; lines: +11 -12 +Permit host* to have change the case of headers. +---------------------------- +revision 1.365 +date: 2010/10/25 11:42:41; author: gilles; state: Exp; lines: +131 -157 +Fix tls getline pb (read too early) +Changes place of starttls() myconnect() and other functions. +---------------------------- +revision 1.364 +date: 2010/10/25 09:56:27; author: gilles; state: Exp; lines: +10 -15 +Fix STARTTLS capability detection bug. +---------------------------- +revision 1.363 +date: 2010/10/24 17:16:43; author: gilles; state: Exp; lines: +99 -48 +Added --delete2folders option. Deletes folders in host2 that are not in host1. +---------------------------- +revision 1.362 +date: 2010/10/22 19:23:34; author: gilles; state: Exp; lines: +24 -8 +Added imapsync basename to see how imapsync.exe is used. +---------------------------- +revision 1.361 +date: 2010/10/19 22:58:06; author: gilles; state: Exp; lines: +28 -8 +Added --nomodules_version option to avoid Roger libeay32.dll missing problem. +Added test to ckeck if the release number from lfo VERSION file is a number. +---------------------------- +revision 1.360 +date: 2010/10/19 22:08:23; author: gilles; state: Exp; lines: +8 -7 +Better documentation to subscribe to the imapsync list. +---------------------------- +revision 1.359 +date: 2010/10/08 01:17:29; author: gilles; state: Exp; lines: +15 -9 +Fixed "Your vendor has not defined POSIX macro SIGALRM" bug on win32. +---------------------------- +revision 1.358 +date: 2010/10/08 00:40:42; author: gilles; state: Exp; lines: +97 -18 +Add memory_consumption for win32. +---------------------------- +revision 1.357 +date: 2010/10/04 21:50:56; author: gilles; state: Exp; lines: +10 -10 +Suppressed ref passage in foldersizes() sub. +---------------------------- +revision 1.356 +date: 2010/10/04 02:44:00; author: gilles; state: Exp; lines: +1270 -1251 +Move all subroutines below main. +Changed "local $SIG{ALRM}" to "POSIX::sigaction(SIGALRM" +---------------------------- +revision 1.355 +date: 2010/09/21 01:50:34; author: gilles; state: Exp; lines: +39 -19 +Added tests_max() max() functions. +Added memory consumption. +Added memory consumption ratio to biggest message transfered. +---------------------------- +revision 1.354 +date: 2010/09/16 00:25:20; author: gilles; state: Exp; lines: +27 -15 +Added memory_consumption_ratio() +Added memory_consumption_of_pid() +Removed memory_consumption +---------------------------- +revision 1.353 +date: 2010/09/14 22:46:33; author: gilles; state: Exp; lines: +19 -9 +Added --minsize option. +---------------------------- +revision 1.352 +date: 2010/09/14 21:53:55; author: gilles; state: Exp; lines: +48 -12 +Added memory_consumption() +Added tests_memory_consumption() +Started to analyse memory consumption. +---------------------------- +revision 1.351 +date: 2010/09/06 16:28:17; author: gilles; state: Exp; lines: +9 -7 +Fixed PERL_VERSION format in imapsync_version_lfo() +---------------------------- +revision 1.350 date: 2010/09/06 01:05:09; author: gilles; state: Exp; lines: +33 -24 Added --noreleasecheck option. Added User-agent information (OS, perl version, Mail::IMAPClient version) diff --git a/FAQ b/FAQ index 748460b..a571592 100644 --- a/FAQ +++ b/FAQ @@ -1,5 +1,5 @@ #!/bin/cat -# $Id: FAQ,v 1.73 2010/08/08 23:09:04 gilles Exp gilles $ +# $Id: FAQ,v 1.75 2010/10/19 23:31:10 gilles Exp gilles $ +------------------+ | FAQ for imapsync | @@ -595,6 +595,14 @@ Examples: 3) to substitute all characters dot "." by underscores "_" --regextrans2 's/\./_/g' +4) to change folder names like this: +[mail/Sent Items] -> [Sent] +[mail/Test] -> [INBOX/Test] +[mail/Test2] -> [INBOX/Test2] + + --regextrans2 's#^mail/Sent Items$#Sent#' \ + --regextrans2 's#^mail/#INBOX/#' + ======================================================================= Q. I would like to move emails from InBox to a sub-folder called, say "2005-InBox" based on the date (Like all emails received in the @@ -755,13 +763,16 @@ Q. Synchronising from Gmail to XXX R. Gmail needs SSL ./imapsync \ - --host1 imap.gmail.com --ssl1 \ + --host1 imap.gmail.com \ + --ssl1 \ + --authmech1 LOGIN \ --user1 gilles.lamiral@gmail.com \ - --passfile1 /var/tmp/secret.gilles_gmail \ + --password1 gmailsecret \ --host2 localhost - --user2 tata@est.belle \ - --passfile2 /var/tmp/secret.tata \ - --useheader="X-Gmail-Received" --skipsize + --user2 tata \ + --password2 tatasecret \ + --useheader="X-Gmail-Received" \ + --useheader 'Message-Id' If your destination imap server doesn't like "[Gmail]" name, just add option: diff --git a/INSTALL b/INSTALL index 412fca8..bd1b070 100644 --- a/INSTALL +++ b/INSTALL @@ -1,4 +1,4 @@ -# $Id: INSTALL,v 1.17 2010/07/16 22:01:57 gilles Exp gilles $ +# $Id: INSTALL,v 1.18 2010/10/25 09:32:49 gilles Exp gilles $ # # INSTALL file for imapsync # imapsync : IMAP sync or copy tool. @@ -84,9 +84,6 @@ Here is some individual module help: - IO:Socket:SSL.pm perl -mIO::Socket::SSL -e '' -- Date::Manip - perl -mDate::Manip -e '' - - File::Spec perl -mFile::Spec -e '' @@ -98,7 +95,7 @@ Here is some individual module help: Everything in one command: - perl -mMail::IMAPClient -mDigest::MD5 -mTerm::ReadKey -mIO::Socket::SSL -mDate::Manip -mFile::Spec -mDigest::HMAC_MD5 -e '' + perl -mMail::IMAPClient -mDigest::MD5 -mTerm::ReadKey -mIO::Socket::SSL -mFile::Spec -mDigest::HMAC_MD5 -e '' INSTALLING ---------- @@ -115,10 +112,14 @@ or copy the file imapsync where you want it to be. WINDOWS ------- +a) Simplest way: + +- Use imapsync.exe + +b) Hard way: + - Install Perl if it isn't already installed. - ActivePerl from ActiveState is a good candidate if - you understand nothing at free/open software - and want to run imapsync with success. + Strawberry Perl is a good candidate - Use PPM to install modules listed in the PREREQUISITES section. PPM is Perl Package Manager. diff --git a/Makefile b/Makefile index 8f657ab..932d96f 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -# $Id: Makefile,v 1.37 2010/08/24 01:46:36 gilles Exp gilles $ +# $Id: Makefile,v 1.42 2010/10/24 23:52:31 gilles Exp gilles $ .PHONY: help usage all @@ -15,6 +15,7 @@ usage: @echo "make all " @echo "make upload_index" @echo "make imapsync.exe" + @echo "make upload_imapsync_exe" DIST_NAME=imapsync-$(VERSION) @@ -137,6 +138,9 @@ upload_index: index.shtml ../../public_html/www.linux-france.org/html/prj/imapsync/ sh $(HOME)/memo/lfo-rsync + + + .dosify_bat: build_exe.bat test_exe.bat test.bat unix2dos build_exe.bat test.bat test_exe.bat touch .dosify_bat @@ -149,18 +153,39 @@ dosify_bat: .dosify_bat imapsync_cidone: .imapsync_cidone +copy_win32: + scp imapsync Admin@c:'C:/msys/1.0/home/Admin/imapsync/' + +tests_win32: dosify_bat + scp imapsync test.bat Admin@c:'C:/msys/1.0/home/Admin/imapsync/' + ssh Admin@c 'perl C:/msys/1.0/home/Admin/imapsync/imapsync --tests_debug' +# ssh Admin@c 'perl C:/msys/1.0/home/Admin/imapsync/imapsync' +# ssh Admin@c 'C:/msys/1.0/home/Admin/imapsync/test.bat' +# ssh Admin@c 'tasklist /FI "PID eq 0"' +# ssh Admin@c 'tasklist /NH /FO CSV' + +upload_imapsync_exe: + rsync -avH imapsync.exe \ + ../../public_html/www.linux-france.org/html/prj/imapsync/ + #sh $(HOME)/memo/lfo-rsync test_imapsync_exe: dosify_bat scp test_exe.bat Admin@c:'C:/msys/1.0/home/Admin/imapsync/' time ssh Admin@c 'C:/msys/1.0/home/Admin/imapsync/test_exe.bat' imapsync.exe: imapsync imapsync_cidone dosify_bat + (date "+%s"| tr "\n" " "; echo -n "BEGIN " $(VERSION) ": "; date) >> .BUILD_EXE_TIME scp imapsync build_exe.bat test_exe.bat \ Admin@c:'C:/msys/1.0/home/Admin/imapsync/' time ssh Admin@c 'C:/msys/1.0/home/Admin/imapsync/build_exe.bat' time ssh Admin@c 'C:/msys/1.0/home/Admin/imapsync/test_exe.bat' scp Admin@c:'C:/msys/1.0/home/Admin/imapsync/imapsync.exe' . ssh Admin@c 'C:/msys/1.0/home/Admin/imapsync/imapsync.exe --version' > VERSION_EXE + (date "+%s"| tr "\n" " "; echo -n "END " $(VERSION) ": "; date) >> .BUILD_EXE_TIME + +zzz: + (date "+%s"| tr "\n" " "; echo -n "BEGIN " $(VERSION) ": "; date) >> .BUILD_EXE_TIME + (date "+%s"| tr "\n" " "; echo -n "END " $(VERSION) ": "; date) >> .BUILD_EXE_TIME lfo: dist niouze_lfo upload_lfo @@ -173,10 +198,10 @@ upload_lfo: sh ~/memo/lfo-rsync niouze_lfo : VERSION - . memo && lfo_announce + . ./memo && lfo_announce niouze_fm: VERSION - . memo && fm_announce + . ./memo && fm_announce public: niouze_fm diff --git a/README b/README index d6be304..6709d9c 100644 --- a/README +++ b/README @@ -3,7 +3,7 @@ NAME Synchronise mailboxes between two imap servers. Good at IMAP migration. More than 36 different IMAP server softwares supported with success. - $Revision: 1.350 $ + $Revision: 1.366 $ SYNOPSIS To synchronise imap account "foo" on "imap.truc.org" to imap account @@ -16,12 +16,13 @@ SYNOPSIS INSTALL imapsync works fine under any Unix OS with perl. - imapsync works fine under Windows (2000, XP) with ActiveState's 5.8 Perl - or as a standalone binary software. + 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, NetBSD, Darwin, Mandriva - and OpenBSD (yeah!). + (at least): FreeBSD, Debian, Ubuntu, Gentoo, Fedora, NetBSD, Darwin, + Mandriva and OpenBSD (yeah!). Get imapsync at http://www.linux-france.org/prj/imapsync/ @@ -70,6 +71,7 @@ USAGE [--syncacls] [--regexmess ] [--regexmess ] [--maxsize ] + [--minsize ] [--maxage ] [--minage ] [--skipheader ] @@ -185,8 +187,9 @@ MAILING-LIST To write on the mailing-list, the address is: - To subscribe, send a message to: - + To subscribe, send any message (even empty) to: + then just reply to the + confirmation message. To unsubscribe, send a message to: @@ -401,5 +404,5 @@ SIMILAR SOFTWARES Feedback (good or bad) will often be welcome. - $Id: imapsync,v 1.350 2010/09/06 01:05:09 gilles Exp gilles $ + $Id: imapsync,v 1.366 2010/10/25 17:15:52 gilles Exp gilles $ diff --git a/TIME b/TIME index da48536..10aaed3 100644 --- a/TIME +++ b/TIME @@ -1,3 +1,20 @@ + 90 Permit host* to change the case of headers. 1.366 release. +120 Fix tls capability. 1.365 release. +150 1.363 public release. +240 Added --delete2folders option. +150 Try to fix again win32 libeay32.dll issue. Upload 1.361 and .exe +270 Draw imapsync logo with inkscape. Had a crash after 2 hours of drawing and saved file was also buggy... +120 Bugfix win32. Email. Added and tested linkage with --link libeay32.dll --link ssleay32.dll +120 Bugfix about POSIX alarm on win32. imapsync 1.359 public release. +160 Added memory consumption for win32. imapsync 1.358 +300 Local environment. Tests. Moved subroutines below main. Changed alarm call. + 90 Memory consumption on Win32 + 50 Better memory consumption statistics + 35 Added memory consumption to final stats. +240 Wrote a message_string_raw() function. Tests. +120 Thinking about performance. Email to italian compagny. +100 Tracking memory consumption. Wrote learn/memory_consumption. Sent bug report to bug-Mail-IMAPClient [at] rt.cpan.org. +180 Tracking memory consumption. 360 Date::Manip away. good_date() rewriting. release check on lfo 210 Better output when copying messages. Profiling memory. 80 Gmail efficiency. Wanted! on homepage, email on list. diff --git a/TODO b/TODO index 4463230..689e8df 100644 --- a/TODO +++ b/TODO @@ -1,5 +1,5 @@ #!/bin/cat -# $Id: TODO,v 1.85 2010/09/06 01:08:14 gilles Exp gilles $ +# $Id: TODO,v 1.86 2010/10/08 00:43:09 gilles Exp gilles $ TODO file for imapsync ---------------------- @@ -13,6 +13,8 @@ Start a wiki for imapsync. Add a best practice migration tips document. +Write a Mail::imapsync package and use it. + Fix the mailing-list archive bug with From at the beginning of a line http://www.linux-france.org/prj/imapsync_list/msg00307.html @@ -21,19 +23,11 @@ Evaluate http://www.rackspace.com/apps/email_hosting/migrations http://www.yippiemove.com/ -Evaluate memory consumption with (or better): -print qx{ ps o pid,pcpu,comm,vsz,rss,size $$ }, "\n" -Search memory leaks with -Test-Weaken Test-Memory-Cycle Devel-Cycle Devel-Leak Test-Weaken -sh -x tests.sh ll_bigmail -is a good candidate to stress memory. - Suggestion: it's very difficult to track down messages which are behaving funny during the sync. It would be great - and presumably easy to code - to have an option to have imapsync display e.g. the subject of an e-mail when it gets synced, rather than just the message ID and the date/time. - Add --noauthmd51 --noauthmd52 to permit noauthmd5 by host Add a well described problem for each problem detected @@ -109,13 +103,14 @@ Add a --skipheaderinfolder option Fix this: > - Erreur avec la traditionnelle différence entre Windows -> et LInux sur les retour-chariots : le calcul de la +> et Linux sur les retour-chariots : le calcul de la > longueur du message ou des entêtes à envoyer au serveur > cible n'est pas bon sur une machine Windows. > Ci-dessous la modif : > > # No NL Count on Windows my $length = ( -s $file ) + $bare_nl_count; > my $length = ( -s $file ); +I wonder if it is Windows or the imap server used. Add stdin/stdout filter before transfer: @@ -170,6 +165,17 @@ Explain expunge behavior. =========================================================================== +DONE. Evaluate memory consumption with (or better): +print qx{ ps o pid,pcpu,comm,vsz,rss,size $$ }, "\n" +Search memory leaks with +Test-Weaken Test-Memory-Cycle Devel-Cycle Devel-Leak Test-Weaken +sh -x tests.sh ll_bigmail +sh -x tests.sh ll_memory_consumption +are good candidate to stress memory. +No memory leak detected just up to 8 memory copies of the same data +in Mail::IMAPClient. +Wrote ./learn/memory_consumption to show that it is a Mail::IMAPClient issue. + DONE.Be more effiscient with large mailboxes Write a Mail::IMAPClient::fetch_hash allowing selecting messages to fetch 4 hours estimated time coding. Time spent 4h30 (with public release and emails) diff --git a/VERSION b/VERSION index 0b73934..f014005 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -1.350 +1.366 diff --git a/VERSION_EXE b/VERSION_EXE index bcdbccd..a31af01 100644 --- a/VERSION_EXE +++ b/VERSION_EXE @@ -1 +1 @@ -1.350 +1.366 diff --git a/build_exe.bat b/build_exe.bat index f100900..2022c35 100755 --- a/build_exe.bat +++ b/build_exe.bat @@ -1,10 +1,10 @@ -REM $Id: build_exe.bat,v 1.3 2010/09/06 02:16:24 gilles Exp gilles $ +REM $Id: build_exe.bat,v 1.6 2010/10/24 23:51:48 gilles Exp gilles $ echo Building imapsync.exe cd C:\msys\1.0\home\Admin\imapsync perl -mMail::IMAPClient -mDigest::MD5 -mTerm::ReadKey -mIO::Socket::SSL -mFile::Spec -mDigest::HMAC_MD5 -e '' -pp -o imapsync.exe -M Term::ReadKey -M IO::Socket::SSL -M Digest::HMAC_MD5 imapsync +pp -o imapsync.exe -M Mail::IMAPClient -M IO::Socket -M IO::Socket::SSL -M Digest::MD5 -M Digest::HMAC_MD5 -M Term::ReadKey imapsync echo Done building imapsync.exe diff --git a/freshmeat_submition.inp b/freshmeat_submition.inp index 4268236..4d8a193 100644 --- a/freshmeat_submition.inp +++ b/freshmeat_submition.inp @@ -3,8 +3,8 @@ #RELEASE_FOCUS="Initial freshmeat announcement" #RELEASE_FOCUS="Documentation" #RELEASE_FOCUS="Code cleanup" -#RELEASE_FOCUS="Minor feature enhancements" -RELEASE_FOCUS="Major feature enhancements" +RELEASE_FOCUS="Minor feature enhancements" +#RELEASE_FOCUS="Major feature enhancements" #RELEASE_FOCUS="Minor bugfixes" #RELEASE_FOCUS="Major bugfixes" #RELEASE_FOCUS="Minor security fixes" @@ -12,9 +12,4 @@ RELEASE_FOCUS="Major feature enhancements" #TEXT_BODY="Syntax cleanup" #TEXT_BODY="Updated documentation" -TEXT_BODY=" -Since 1.350: -Bug fixes. -Many thanks to the freshmeat folk that correct my bad and poorly English! -" - +TEXT_BODY="Since last public release 1.350: Added --minsize option to transfer messages bigger than a given size. Added memory consumption to know how much concurent imapsync can run in parallel on a system. Thanks to the freshmeat guy who corrects my bad and poorly English!" diff --git a/freshmeat_submition.json b/freshmeat_submition.json index 8b2c6e6..0088346 100644 --- a/freshmeat_submition.json +++ b/freshmeat_submition.json @@ -1,31 +1,9 @@ { "release": { - "tag_list": "Major feature enhancements", - "version": "1.350", + "tag_list": "stable, Minor feature enhancements", + "version": "1.359", "hidden_from_frontpage": false, - "changelog": " -Since 1.286: -Added --noreleasecheck option. -Added new release checking. -Removed Date::Manip dependancy. -Better output when copying messages. -More effiscient with large mailboxes. -Clarity: print capability after authenticated state. -Duplicate messages on host2 are now deleted with --delete2 ---skipsize turned on by default. -Usability fix: examples with --password1 instead of --passfile1 -Added --debugimap1 --debugimap2 to permit imap outpout with only one host. -Added reconnect statistics. -Added reconnect behavior with Mail::IMAPClient 2.2.9 -Added statistic about messages deleted. -Added statistic about average bandwith rate. -Flags are now exactly synced from host1 to host2 -(Previous releases just added flags). -Added TLSv1 support. -Filter flags sync with the list given by PERMANENTFLAGS on --host2 -and bug fixes. -Many thanks to the freshmeat folk that correct my bad and poorly English! -" + "changelog": "Since last public release 1.350: Added --minsize option to transfer messages bigger than a given size.Added memory consumption to know how much concurent imapsync can run in parallel on a system. Many thanks to the freshmeat folk that correct my bad and poorly English!" } } diff --git a/imapsync b/imapsync index 37bcfe5..f20a9dd 100755 --- a/imapsync +++ b/imapsync @@ -20,7 +20,7 @@ tool. Synchronise mailboxes between two imap servers. Good at IMAP migration. More than 36 different IMAP server softwares supported with success. -$Revision: 1.350 $ +$Revision: 1.366 $ =head1 SYNOPSIS @@ -36,12 +36,14 @@ To synchronise imap account "foo" on "imap.truc.org" =head1 INSTALL imapsync works fine under any Unix OS with perl. - imapsync works fine under Windows (2000, XP) with ActiveState's 5.8 Perl - or as a standalone binary software. + 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, NetBSD, Darwin, Mandriva and OpenBSD (yeah!). +FreeBSD, Debian, Ubuntu, Gentoo, Fedora, +NetBSD, Darwin, Mandriva and OpenBSD (yeah!). Get imapsync at http://www.linux-france.org/prj/imapsync/ @@ -91,6 +93,7 @@ The option list: [--syncacls] [--regexmess ] [--regexmess ] [--maxsize ] + [--minsize ] [--maxage ] [--minage ] [--skipheader ] @@ -228,8 +231,9 @@ The public mailing-list may be the best way to get support. To write on the mailing-list, the address is: -To subscribe, send a message to: +To subscribe, send any message (even empty) to: +then just reply to the confirmation message. To unsubscribe, send a message to: @@ -471,7 +475,7 @@ Entries for imapsync: Feedback (good or bad) will often be welcome. -$Id: imapsync,v 1.350 2010/09/06 01:05:09 gilles Exp gilles $ +$Id: imapsync,v 1.366 2010/10/25 17:15:52 gilles Exp gilles $ =cut @@ -489,7 +493,8 @@ use Digest::MD5 qw(md5_base64); #use IO::Socket::SSL; use MIME::Base64; use English; -use POSIX qw(uname); +use File::Basename; +use POSIX qw(uname SIGALRM); use Fcntl; use File::Spec; use File::Path qw(mkpath rmtree); @@ -500,6 +505,14 @@ 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( @@ -516,7 +529,7 @@ my( $usedatemanip, $syncacls, $fastio1, $fastio2, - $maxsize, $maxage, $minage, + $maxsize, $minsize, $maxage, $minage, $skipheader, @useheader, $skipsize, $allowsizemismatch, $foldersizes, $buffersize, $delete, $delete2, @@ -554,13 +567,16 @@ my( $allow3xx, $justlogin, $tmpdir, $releasecheck, + $max_msg_size_in_bytes, + $modules_version, + $delete2folders, ); # main program # global variables initialisation -$rcs = '$Id: imapsync,v 1.350 2010/09/06 01:05:09 gilles Exp gilles $ '; +$rcs = '$Id: imapsync,v 1.366 2010/10/25 17:15:52 gilles Exp gilles $ '; $total_bytes_transferred = 0; $total_bytes_skipped = 0; @@ -573,6 +589,7 @@ $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. @@ -584,6 +601,8 @@ my @argv_copy = @ARGV; get_options(); +$modules_version = defined($modules_version) ? $modules_version : 1; + $releasecheck = defined($releasecheck) ? $releasecheck : 1; my $warn_release = ($releasecheck) ? check_last_release() : ''; @@ -602,7 +621,8 @@ print "Temp directory is $tmpdir\n"; is_valid_directory($tmpdir); write_pidfile($pidfile) if ($pidfile); -print "Modules version list:\n", modules_VERSION(), "\n"; +$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.0.25 or superior \n"; @@ -623,19 +643,6 @@ $debugimap1 = $debugimap2 = 1 if ($debugimap); # By default, don't take size to compare $skipsize = (defined $skipsize) ? $skipsize : 1; -sub connect_imap { - my($host, $port, $debugimap, $ssl, $tls) = @_; - my $imap = Mail::IMAPClient->new(); - $imap->Server($host); - $imap->Port($port); - $imap->Debug($debugimap); - $imap->Ssl($ssl) if ($ssl); - $imap->Tls($tls) if ($tls); - #$imap->connect() - myconnect($imap) - or die_clean("Can not open imap connection on [$host]: $@\n"); -} - if ($justconnect) { justconnect(); @@ -693,19 +700,6 @@ $reconnectretry2 = (defined($reconnectretry2)) ? $reconnectretry2 : 3; print "Host1: imap server [$host1] port [$port1] user [$user1]\n"; print "Host2: imap server [$host2] port [$port2] user [$user2]\n"; - -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; -} - - $password1 || $passfile1 || do { $password1 = ask_for_password($authuser1 || $user1, $host1); }; @@ -740,6 +734,820 @@ $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) { + + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + + my $h2_fold = imap2_folder_name($h1_fold); + + printf("%-35s -> %-35s\n", "[$h1_fold]", "[$h2_fold]"); + unless ($imap1->select($h1_fold)) { + warn + "Host1 folder $h1_fold: Could not select: ", + $imap1->LastError, "\n"; + $nb_errors++; + next FOLDER; + } + + if ( ! exists($h2_folders_all{$h2_fold})) { + print "Host2 folder $h2_fold does not exist\n"; + print "Creating folder [$h2_fold]\n"; + unless ($dry){ + unless ($imap2->create($h2_fold)){ + warn "Couldn't create [$h2_fold]: ", + $imap2->LastError,"\n"; + $nb_errors++; + next FOLDER; + } + } + else{ + next FOLDER; + } + } + + acls_sync($h1_fold, $h2_fold); + + unless ($imap2->select($h2_fold)) { + warn + "Host2 folder $h2_fold: Could not select: ", + $imap2->LastError, "\n"; + $nb_errors++; + 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); + + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + + 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 %h1_hash = (); + my %h2_hash = (); + + $debug and print "Host1 folder [$h1_fold] parsing headers\n"; + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + + my ($h1_heads_ref, $h1_fir_ref) = ({}, {}); + $h1_heads_ref = $imap1->parse_headers([@h1_msgs], @useheader) if (@h1_msgs); + $debug and print "Time headers: ", timenext(), " s\n"; + last FOLDER if $imap1->IsUnconnected(); + + @$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; + } + last FOLDER if $imap1->IsUnconnected(); + + + my @h1_msgs_duplicate; + foreach my $m (@h1_msgs) { + 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], @useheader) if (@h2_msgs); + $debug and print "Time headers: ", timenext(), " s\n"; + last FOLDER if $imap2->IsUnconnected(); + + @$h2_fir_ref{@h2_msgs} = (undef); # 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"; + last FOLDER if $imap2->IsUnconnected(); + + my @h2_msgs_duplicate; + foreach my $m (@h2_msgs) { + my $rc = parse_header_msg($imap2, $m, $h2_heads_ref, $h2_fir_ref, "T", \%h2_hash); + if (! defined($rc)) { + my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; + 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 + my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; + $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; + } + } + + 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 + $debug and print "msg $h1_fold/$h1_msg copying to $h2_fold\n"; + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + my $string; + #print "Message_string Beg\n", memory_consumption(); + $string = $imap1->message_string($h1_msg); + #print "Message_string End\n", memory_consumption(); + unless (defined($string)) { + warn + "- msg $h1_fold/$h1_msg could not fetch [$m_id $h1_size]: ", + $imap1->LastError, "\n"; + $nb_errors++; + $total_bytes_error += $h1_size; + next MESS; + } + + #my $message_file = "tmp_imapsync_$$"; + #$imap1->select($h1_fold); + #unlink($message_file); + #$imap1->message_to_file($message_file, $h1_msg) or do { + # warn "Could not put message #$h1_msg to file $message_file", + # $imap1->LastError; + # $nb_errors++; + # $total_bytes_error += $h1_size; + # next MESS; + #}; + #$string = file_to_string($message_file); + #print "AAA1[$string]ZZZ\n"; + #unlink($message_file); + if (@regexmess) { + $string = regexmess($string); + + #string_to_file($string, $message_file); + } + + + $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"; + } + + my $h1_flags = $h1_hash{$m_id}{'F'} || ""; + # 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"; + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + $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; + next MESS; + } + else{ + # good + # $new_id is an id if the IMAP server has the + # UIDPLUS capability else just a ref + print "msg $h1_fold/$h1_msg copied to $h2_fold/$new_id\n"; + $total_bytes_transferred += $h1_size; + $nb_msg_transferred += 1; + if($delete) { + print "msg $h1_fold/$h1_msg deleted on host1\n"; + unless($dry) { + $imap1->delete_message($h1_msg); + $h1_nb_msg_deleted += 1; + last FOLDER if $imap1->IsUnconnected(); + $imap1->expunge() if ($expunge); + last FOLDER if $imap1->IsUnconnected(); + } + } + } + } + else{ + $nb_msg_skipped_dry_mode += 1; + } + #unlink($message_file); + next MESS; + } + else{ + #my $h2_size = $h2_hash{$m_id}{'s'}; + my $h2_msg = $h2_hash{$m_id}{'m'}; + #my $h2_idate = $h2_hash{$m_id}{'D'}; + $debug and print "msg $h1_fold/$h1_msg equals $h2_fold/$h2_msg\n"; + $total_bytes_skipped += $h1_size; + $nb_msg_skipped += 1; + } + + $fast and next MESS; + #$debug and print "MESSAGE $m_id\n"; + my $h2_size = $h2_hash{$m_id}{'s'}; + my $h2_msg = $h2_hash{$m_id}{'m'}; + + # used cached flag values for efficiency + my $h1_flags = $h1_hash{$m_id}{'F'} || ""; + my $h2_flags = $h2_hash{$m_id}{'F'} || ""; + + # 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 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++; + } + last FOLDER if $imap2->IsUnconnected(); + + $debug and do { + my @h2_flags = @{ $imap2->flags($h2_msg) || [] }; + last FOLDER if $imap2->IsUnconnected(); + + print "host1 flags: $h1_flags\n", + "host2 flags: @h2_flags\n"; + + print "Looking dates\n"; + #my $h1_idate = $imap1->internaldate($h1_msg); + #my $h2_idate = $imap2->internaldate($h2_msg); + my $h1_idate = $h1_hash{$m_id}{'D'}; + my $h2_idate = $h2_hash{$m_id}{'D'}; + print + "host1 internal date: $h1_idate\n", + "host2 internal date: $h2_idate\n"; + + #unless ($h1_idate eq $h2_idate) { + # print "!!! Dates differs !!!\n"; + #} + }; + unless ($skipsize or ($h1_size == $h2_size)) { + # Bad size + print + "- msg $h1_fold/$h1_msg size diff $h1_size != $h2_size $h2_fold/$h2_msg\n"; + $nb_errors++; + } + else { + # Good + $debug and print + "msg $h1_fold/$h1_msg sizes ok $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); + } + } + } + } + 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"; +} + +print "++++ End looping on each folder\n"; +#print memory_consumption(); + +my $memory_consumption = memory_consumption(); +my $memory_ratio = ($max_msg_size_in_bytes) ? + sprintf('%.1f', $memory_consumption / $max_msg_size_in_bytes) : "NA"; + + +$imap1->logout(); +$imap2->logout(); + +my $host1_reconnect_count = $imap1->Reconnect_counter() || 0; +my $host2_reconnect_count = $imap2->Reconnect_counter() || 0; + + +$timeend = time(); +$timediff = $timeend - $timestart; + +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)) + { + 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 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, $password, $debugimap, $timeout, $fastio, @@ -750,7 +1558,7 @@ sub login_imap { $imap->Ssl($ssl) if ($ssl); $imap->Tls($tls) if ($tls); - $imap->Clear(5); + $imap->Clear(1); $imap->Server($host); $imap->Port($port); $imap->Fast_io($fastio); @@ -806,6 +1614,7 @@ sub login_imap { return($imap); } + sub plainauth() { my $code = shift; my $imap = shift; @@ -822,29 +1631,70 @@ sub server_banner { return $banner; } -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"; +sub banner_imapsync { + + my @argv_copy = @_; + my $banner_imapsync = join("", + '$RCSfile: imapsync,v $ ', + '$Revision: 1.366 $ ', + '$Date: 2010/10/25 17:15:52 $ ', + "\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); +} -exit_clean(0) if ($justlogin); -$split1 and $imap1->Split($split1); -$split2 and $imap2->Split($split2); -# -# Folder stuff -# +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; + + 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"); +} + -my (@h1_folders, %requested_folder, -@h2_folders, @h2_folders_list, %h2_folders_list, %subscribed_folder, %h2_folders); sub tests_folder_routines { - ok( !give_requested_folders() ,"no requested folders" ); ok( !is_requested_folder('folder_foo') ); ok( add_to_requested_folders('folder_foo') ); ok( is_requested_folder('folder_foo') ); @@ -857,20 +1707,8 @@ sub tests_folder_routines { ok( is_requested_folder('folder_toto') ); ok( remove_from_requested_folders('folder_toto') ); ok( !is_requested_folder('folder_toto') ); - ok( init_requested_folders() , 'empty requested folders'); - ok( !give_requested_folders() , 'no requested folders' ); } -sub give_requested_folders { - return(keys(%requested_folder)); -} - -sub init_requested_folders { - - %requested_folder = (); - return(1); - -} sub is_requested_folder { my ( $folder ) = @_; @@ -897,74 +1735,6 @@ sub remove_from_requested_folders { return( keys(%requested_folder) ); } - -# Make a hash of subscribed folders in source server. -map { $subscribed_folder{$_} = 1 } $imap1->subscribed(); - - - - -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)) { - my @all_source_folders = sort $imap1->folders(); - add_to_requested_folders(@all_source_folders); - } -} - - -# consider (optional) includes and excludes -if (scalar(@include)) { - my @all_source_folders = sort $imap1->folders(); - foreach my $include (@include) { - my @included_folders = grep /$include/, @all_source_folders; - 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 = @requested_folder; - sub compare_lists { my ($list_1_ref, $list_2_ref) = @_; @@ -1029,6 +1799,7 @@ sub tests_compare_lists { 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]) @@ -1048,21 +1819,6 @@ sub tests_compare_lists { } -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"); sub get_prefix { my($imap, $prefix_in, $prefix_opt) = @_; @@ -1118,99 +1874,6 @@ sub get_separator { } } - -print "Host1 separator and prefix: [$h1_sep][$h1_prefix]\n"; -print "Host2 separator and prefix: [$h2_sep][$h2_prefix]\n"; - - -sub foldersizes { - - my ($side, $imap, $folders_r) = @_; - my $tot = 0; - my $tmess = 0; - my @folders = @{$folders_r}; - 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); - @$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; - } - - printf(" Size: %9s", $stot); - printf(" Messages: %5s\n", $smess); - $tot += $stot; - $tmess += $smess; - } - print "Total size: $tot\n"; - print "Total messages: $tmess\n"; - print "Time: ", timenext(), " s\n"; -} - - -foreach my $h1_fold (@h1_folders) { - my $h2_fold; - $h2_fold = imap2_folder_name($h1_fold); - $h2_folders{$h2_fold}++; -} - -@h2_folders = sort keys(%h2_folders); - -if ($foldersizes) { - foldersizes("Host1", $imap1, \@h1_folders); - foldersizes("Host2", $imap2, \@h2_folders); -} - - -sub timenext { - my ($timenow, $timerel); - # $timebefore is global, beurk ! - $timenow = time; - $timerel = $timenow - $timebefore; - $timebefore = $timenow; - return($timerel); -} - -exit_clean(0) if ($justfoldersizes); - -# needed for setting flags -my $imap2hasuidplus = $imap2->has_capability("UIDPLUS"); - - -@h2_folders_list = sort @{$imap2->folders()}; -foreach my $folder (@h2_folders_list) { - $h2_folders_list{$folder}++; -} - -print - "++++ Listing folders\n", - "Host1 folders list:\n", map("[$_]\n",@h1_folders),"\n", - "Host2 folders list:\n", map("[$_]\n",@h2_folders_list),"\n"; - -print - "Host1 subscribed folders list: ", - map("[$_] ", sort keys(%subscribed_folder)), "\n" - if ($subscribed); - sub separator_invert { # The separator we hope we'll never encounter: 00000000 my $o_sep="\000"; @@ -1283,6 +1946,60 @@ sub imap2_folder_name { return($h2_fold); } + +sub foldersizes { + + my ($side, $imap, @folders) = @_; + my $tot = 0; + my $tmess = 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); + @$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; + } + + printf(" Size: %9s", $stot); + printf(" Messages: %5s\n", $smess); + $tot += $stot; + $tmess += $smess; + } + print "Total size: $tot\n"; + print "Total messages: $tmess\n"; + print "Time: ", timenext(), " s\n"; +} + +sub timenext { + my ($timenow, $timerel); + # $timebefore is global, beurk ! + $timenow = time; + $timerel = $timenow - $timebefore; + $timebefore = $timenow; + return($timerel); +} + + sub tests_flags_regex { my $string; @@ -1477,712 +2194,6 @@ sub flags_filter { } -# folder loop -print "++++ Looping on each folder\n"; - -FOLDER: foreach my $h1_fold (@h1_folders) { - - last FOLDER if $imap1->IsUnconnected(); - last FOLDER if $imap2->IsUnconnected(); - - my $h2_fold = imap2_folder_name($h1_fold); - - printf("%-35s -> %-35s\n", "[$h1_fold]", "[$h2_fold]"); - unless ($imap1->select($h1_fold)) { - warn - "Host1 folder $h1_fold: Could not select: ", - $imap1->LastError, "\n"; - $nb_errors++; - next FOLDER; - } - - if ( ! exists($h2_folders_list{$h2_fold})) { - print "Host2 folder $h2_fold does not exist\n"; - print "Creating folder [$h2_fold]\n"; - unless ($dry){ - unless ($imap2->create($h2_fold)){ - warn "Couldn't create [$h2_fold]: ", - $imap2->LastError,"\n"; - $nb_errors++; - next FOLDER; - } - } - else{ - next FOLDER; - } - } - - acls_sync($h1_fold, $h2_fold); - - unless ($imap2->select($h2_fold)) { - warn - "Host2 folder $h2_fold: Could not select: ", - $imap2->LastError, "\n"; - $nb_errors++; - 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); - - last FOLDER if $imap1->IsUnconnected(); - last FOLDER if $imap2->IsUnconnected(); - - 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 %h1_hash = (); - my %h2_hash = (); - - $debug and print "Host1 folder [$h1_fold] parsing headers\n"; - last FOLDER if $imap1->IsUnconnected(); - last FOLDER if $imap2->IsUnconnected(); - - my ($h1_heads_ref, $h1_fir_ref) = ({}, {}); - $h1_heads_ref = $imap1->parse_headers([@h1_msgs], @useheader) if (@h1_msgs); - $debug and print "Time headers: ", timenext(), " s\n"; - last FOLDER if $imap1->IsUnconnected(); - - @$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; - } - last FOLDER if $imap1->IsUnconnected(); - - - my @h1_msgs_duplicate; - foreach my $m (@h1_msgs) { - 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], @useheader) if (@h2_msgs); - $debug and print "Time headers: ", timenext(), " s\n"; - last FOLDER if $imap2->IsUnconnected(); - - @$h2_fir_ref{@h2_msgs} = (undef); # 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"; - last FOLDER if $imap2->IsUnconnected(); - - my @h2_msgs_duplicate; - foreach my $m (@h2_msgs) { - my $rc = parse_header_msg($imap2, $m, $h2_heads_ref, $h2_fir_ref, "T", \%h2_hash); - if (! defined($rc)) { - my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; - 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 - my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; - $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; - } - } - - 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; - } - unless (exists($h2_hash{$m_id})) { - # copy - $debug and print "msg $h1_fold/$h1_msg copying to $h2_fold\n"; - last FOLDER if $imap1->IsUnconnected(); - last FOLDER if $imap2->IsUnconnected(); - my $string; - $string = $imap1->message_string($h1_msg); - unless (defined($string)) { - warn - "- msg $h1_fold/$h1_msg could not fetch [$m_id $h1_size]: ", - $imap1->LastError, "\n"; - $nb_errors++; - $total_bytes_error += $h1_size; - next MESS; - } - - #my $message_file = "tmp_imapsync_$$"; - #$imap1->select($h1_fold); - #unlink($message_file); - #$imap1->message_to_file($message_file, $h1_msg) or do { - # warn "Could not put message #$h1_msg to file $message_file", - # $imap1->LastError; - # $nb_errors++; - # $total_bytes_error += $h1_size; - # next MESS; - #}; - #$string = file_to_string($message_file); - #print "AAA1[$string]ZZZ\n"; - #unlink($message_file); - if (@regexmess) { - $string = regexmess($string); - - #string_to_file($string, $message_file); - } - - - - 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); - } - - $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"; - } - - my $h1_flags = $h1_hash{$m_id}{'F'} || ""; - # 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"; - last FOLDER if $imap1->IsUnconnected(); - last FOLDER if $imap2->IsUnconnected(); - $h1_date = undef if ($h1_date eq ""); - unless ($dry) { - - if ($OSNAME eq "MSWin32") { - $new_id = $imap2->append_string($h2_fold, $string, $h1_flags, $h1_date); - } - else { - # just back to append_string since append_file 3.05 does not work. - #$new_id = $imap2->append_file($h2_fold, $message_file, "", $h1_flags, $d); - # append_string 3.05 does not work too some times with $d unset. - $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; - next MESS; - } - else{ - # good - # $new_id is an id if the IMAP server has the - # UIDPLUS capability else just a ref - print "msg $h1_fold/$h1_msg copied to $h2_fold/$new_id\n"; - $total_bytes_transferred += $h1_size; - $nb_msg_transferred += 1; - if($delete) { - print "msg $h1_fold/$h1_msg deleted on host1\n"; - unless($dry) { - $imap1->delete_message($h1_msg); - $h1_nb_msg_deleted += 1; - last FOLDER if $imap1->IsUnconnected(); - $imap1->expunge() if ($expunge); - last FOLDER if $imap1->IsUnconnected(); - } - } - } - } - else{ - $nb_msg_skipped_dry_mode += 1; - } - #unlink($message_file); - next MESS; - } - else{ - #my $h2_size = $h2_hash{$m_id}{'s'}; - my $h2_msg = $h2_hash{$m_id}{'m'}; - #my $h2_idate = $h2_hash{$m_id}{'D'}; - $debug and print "msg $h1_fold/$h1_msg equals $h2_fold/$h2_msg\n"; - $total_bytes_skipped += $h1_size; - $nb_msg_skipped += 1; - } - - $fast and next MESS; - #$debug and print "MESSAGE $m_id\n"; - my $h2_size = $h2_hash{$m_id}{'s'}; - my $h2_msg = $h2_hash{$m_id}{'m'}; - - # used cached flag values for efficiency - my $h1_flags = $h1_hash{$m_id}{'F'} || ""; - my $h2_flags = $h2_hash{$m_id}{'F'} || ""; - - # 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 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++; - } - last FOLDER if $imap2->IsUnconnected(); - - $debug and do { - my @h2_flags = @{ $imap2->flags($h2_msg) || [] }; - last FOLDER if $imap2->IsUnconnected(); - - print "host1 flags: $h1_flags\n", - "host2 flags: @h2_flags\n"; - - print "Looking dates\n"; - #my $h1_idate = $imap1->internaldate($h1_msg); - #my $h2_idate = $imap2->internaldate($h2_msg); - my $h1_idate = $h1_hash{$m_id}{'D'}; - my $h2_idate = $h2_hash{$m_id}{'D'}; - print - "host1 internal date: $h1_idate\n", - "host2 internal date: $h2_idate\n"; - - #unless ($h1_idate eq $h2_idate) { - # print "!!! Dates differs !!!\n"; - #} - }; - unless ($skipsize or ($h1_size == $h2_size)) { - # Bad size - print - "- msg $h1_fold/$h1_msg size diff $h1_size != $h2_size $h2_fold/$h2_msg\n"; - $nb_errors++; - } - else { - # Good - $debug and print - "msg $h1_fold/$h1_msg sizes ok $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); - } - } - } - } - 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"; -} - -print "++++ End looping on each folder\n"; - - -# FOLDER loop is exited any time a connection is lost be sure to log it! -# Example: -# lost_connection($imap1,"host1 [$host1]"); -# -# can be tested with a "killall /usr/bin/imapd" (or equivalent) in command line. -# -sub _filter { - my $str = shift or return ""; - my $sz = 64; - my $len = length($str); - if ( ! $debug and $len > $sz*2 ) { - my $beg = substr($str, 0, $sz); - my $end = substr($str, -$sz, $sz); - $str = $beg . "..." . $end; - } - $str =~ s/\012?\015$//; - return "(len=$len) " . $str; -} - -sub lost_connection { - my($imap, $error_message) = @_; - if ( $imap->IsUnconnected() ) { - $nb_errors++; - my $lcomm = $imap->LastIMAPCommand || ""; - my $einfo = $imap->LastError || @{$imap->History}[-1] || ""; - - # if string is long try reduce to a more reasonable size - $lcomm = _filter($lcomm); - $einfo = _filter($einfo); - warn("error: last command: $lcomm\n") if ($debug && $lcomm); - warn("error: lost connection $error_message", $einfo, "\n"); - return(1); - }else{ - return(0); - } -} - -$imap1->logout(); -$imap2->logout(); - -my $host1_reconnect_count = $imap1->Reconnect_counter() || 0; -my $host2_reconnect_count = $imap2->Reconnect_counter() || 0; - -$timeend = time(); - -$timediff = $timeend - $timestart; - -stats(); - -exit_clean(1) if($nb_errors); - -exit_clean(0); - -# END of main program - -# subroutines - -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)) - { - 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 banner_imapsync { - - my @argv_copy = @_; - my $banner_imapsync = join("", - '$RCSfile: imapsync,v $ ', - '$Revision: 1.350 $ ', - '$Date: 2010/09/06 01:05:09 $ ', - "\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 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 exit_clean { - my $status = shift; - - 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_msgs { my ($imap) = @_; @@ -2214,6 +2225,85 @@ sub select_msgs { return(@msgs); } + + + +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 { print "++++ Statistics\n"; print "Transfer time : $timediff sec\n"; @@ -2237,6 +2327,8 @@ sub stats { 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 "Memory/biggest message ratio : $memory_ratio\n"; print "Detected $nb_errors errors\n\n"; print $warn_release, "\n"; @@ -2291,10 +2383,12 @@ sub get_options { "regexflag=s" => \@regexflag, "delete!" => \$delete, "delete2!" => \$delete2, + "delete2folders!" => \$delete2folders, "syncinternaldates!" => \$syncinternaldates, - "idatefromheader!" => \$idatefromheader, + "idatefromheader!" => \$idatefromheader, "syncacls!" => \$syncacls, "maxsize=i" => \$maxsize, + "minsize=i" => \$minsize, "maxage=i" => \$maxage, "minage=i" => \$minage, "buffersize=i" => \$buffersize, @@ -2340,6 +2434,7 @@ sub get_options { "tmpdir=s" => \$tmpdir, "pidfile=s" => \$pidfile, "releasecheck!" => \$releasecheck, + "modules_version!" => \$modules_version, ); $debug and print "get options: [$opt_ret]\n"; @@ -2399,20 +2494,19 @@ sub parse_header_msg { $val =~ s/[\x80-\xff]/X/g; # remove the first blanks (dbmail bug ?) - # and uppercase header keywords - # (dbmail and dovecot) $val =~ s/^\s*(.+)$/$1/; + + # and uppercase header line + # (dbmail and dovecot) - #my $H = uc($h); - my $H = "$h: $val"; + my $H = uc("$h: $val"); # show stuff in debug mode - $debug and print "${s}H $H:", $val, "\n"; + $debug and print "${s}H $H", "\n"; if ($skipheader and $H =~ m/$skipheader/i) { $debug and print "Skipping header $H\n"; next; } - #$headstr .= "$H:". $val; $headstr .= "$H"; } } @@ -2480,11 +2574,26 @@ sub string_to_file { 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'); - return('') if ($public_release eq 'unknown'); + return('unknown') if ($public_release eq 'unknown'); + return('unknown') if (! is_a_release_number($public_release)); + return('timeout') if ($public_release eq 'timeout'); my $imapsync_here = imapsync_version(); @@ -2496,17 +2605,32 @@ sub check_last_release { } sub imapsync_version { - my $rcs = '$Id: imapsync,v 1.350 2010/09/06 01:05:09 gilles Exp gilles $ '; + my $rcs = '$Id: imapsync,v 1.366 2010/10/25 17:15:52 gilles Exp gilles $ '; $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 $agent_info = "$OSNAME system, perl $PERL_VERSION, Mail::IMAPClient $Mail::IMAPClient::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 => 'linux-france.org', PeerPort => '80', @@ -2524,23 +2648,42 @@ sub imapsync_version_lfo { } sub not_long { - + #print "Entering not_long\n"; my ($func) = @_; my $val; - eval { + + # 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" }; - alarm 3; + }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; + alarm(0); }; if ($@) { + if ($@ =~ /alarm/) { # timed out - return('unknown') unless $@ eq "alarm\n"; # propagate unexpected errors - + return('timeout'); + }else{ + alarm(0); + return('unknown'); # propagate unexpected errors + } }else { # didn't return($val); @@ -2566,7 +2709,8 @@ sub localhost_info { sub usage { my $localhost_info = localhost_info(); my $thank = thank_author(); - my $warn_release = check_last_release(); + my $warn_release =''; + $warn_release = check_last_release() if (not defined($releasecheck)); print < : sets the size of a block of I/O. ---maxsize : skip messages larger than bytes +--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 @@ -2767,6 +2915,115 @@ sub good_date { 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'); @@ -2780,11 +3037,65 @@ sub tests_good_date { } + +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) { + + 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_good_date(); + tests_list_keys_in_2_not_in_1(); } } @@ -2801,6 +3112,12 @@ sub tests { 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(); } } @@ -3333,14 +3650,18 @@ use constant NonFolderArg => 1; # Value to pass to Massage to "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. @@ -3426,6 +3747,8 @@ no warnings 'once'; 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) @@ -3472,7 +3795,7 @@ no warnings 'once'; } $self->LastError( join( "; ", @info ) ); } - + #print "@_ End _imap_command:\n", memory_consumption(); return $rc; }; @@ -3495,8 +3818,9 @@ no warnings 'once'; $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) { @@ -3514,6 +3838,7 @@ no warnings 'once'; $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); @@ -3529,7 +3854,7 @@ no warnings 'once'; } } } - + #print "$string: returned $code\n", memory_consumption(); # $self->_debug("Command $string: returned $code\n"); return $code =~ /^OK|$qgood/im ? $self : undef ; @@ -3600,6 +3925,7 @@ no warnings 'once'; $iBuffer eq "" ) { + #print memory_consumption(); my $transno = $self->Transaction; # used below in several places if ($timeout) { vec($rvec, fileno($self->Socket), 1) = 1; @@ -3663,6 +3989,7 @@ no warnings 'once'; $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"); @@ -3841,93 +4168,6 @@ no warnings 'once'; # End of sub override_imapclient (yes, very bad indentation) } -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) { - $debug and print "Calling starttls\n"; - - my $banner = starttls($self); - $debug and print "End starttls: $banner\n"; - } - - $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"; - my $banner = $self->Banner(); - $debug and print $banner; - unless ($banner =~ /^\* OK \[CAPABILITY.*STARTTLS.*\]/) { - die_clean( "No STARTTLS capability: $banner" ); - } - print $socket, "\n"; - print $socket "z00 STARTTLS\015\012"; - my $txt = $socket->getline(); - $debug and print "Read: $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"; - } - $banner; -} - # IMAPClient 2.2.9 3.xx ads package Mail::IMAPClient; diff --git a/index.shtml b/index.shtml index a8f015d..35f2adc 100644 --- a/index.shtml +++ b/index.shtml @@ -5,7 +5,7 @@ imapsync <!--#exec cmd="cat VERSION" --> - + @@ -13,15 +13,37 @@ + + + + + +
+imapsync logo +
+ + +

imapsync web site

What is imapsync?

imapsync software is a command line tool allowing incremental and -recursive imap transfers from one mailbox to another, both anywhere on the internet. +recursive imap transfers from one mailbox to another, both anywhere on the internet +or in your local network.

imapsync is useful for imap account migration or imap account backup. @@ -36,26 +58,37 @@ where the user plays independently on both sides. Use offlineimap

AUTHOR

Gilles LAMIRAL
- Email: lamiral@linux-france.org

+ Email: gilles.lamiral@laposte.net

-

Feedback good or bad is often welcome.

+

Good feedback is always welcome, bad feedback is often welcome.

-

A good place to talk about imapsync is the public +

A nice place to talk about imapsync is the public imapsync mailing-list (see below).

-

Gilles LAMIRAL earns his living writing, installing, configuring and - teaching free, open and gratis softwares.
- Do not hesitate to pay him for that services.

-

If you use imapsync as a professionnal worker you may read this call - for feedback. + for rewarding.

+

Other ways to consider the situation:

+
    +
  • stop beeing a + leech. +
    • +
  • think about + helping back + a software developper and helper. +
    • +
+ +

imapsync call for donation

Are you happy with this free, open and gratis software?

-

Then you can help the author to maintain imapsync and support happy (or unhappy) users: YOU!

+

Then you can help me back to maintain imapsync +and support you!
+I will personally thank each donation +with an email and add an entry in the imapsync CREDITS file.

@@ -68,10 +101,25 @@ where the user plays independently on both sides. Use offlineimap

-Or offer him a book on his +You can also offer me a book on my imapsync amazon wishlist
+

-Thanks in advance!

+

+If you prefer making your donation with cash or cheque then my postal address is:
+Gilles LAMIRAL
+4 La Billais
+35580 Baulon
+FRANCE
 +

+

+My phone numbers are:
++33 951 84 42 42 (home/work)
++33 620 79 76 06 (mobile)
++33 956 84 42 42 (fax)
+

+ +

Thanks in advance!

Latest release @@ -85,13 +133,13 @@ Or offer him a book on his

Standalone imapsync executable for win32, -thanks to Strawberry Perl 5.12 and Par::Packed module.
-(imapsync.exe built time is )

+thanks to Strawberry Perl 5.12 and Par::Packer module.
+The imapsync.exe built time is .
+The build system for imapsync.exe is XP Pro SP2 on a Intel Celeron 400 MHz 256 Mo RAM. +

imapsync installation

- -

README

Frequently Asked Questions

@@ -100,7 +148,9 @@ thanks to Strawberry Perl 5.12 and Par::Packed module.

MAILING-LIST

- The public mailing-list may be the best way to get support.
+ The public mailing-list may be the best way to get free support.
+ You can write to the mailing-list even if you're not subscribed to it.
+ In that case you will receive a confirmation message each time you post (to avoid spam).

To write on the mailing-list, the address is: @@ -123,17 +173,24 @@ thanks to Strawberry Perl 5.12 and Par::Packed module.

- The list archives may be available at + The list archives are available at http://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.
-

+
+

Search in the imapsync list archives: + + + (change the keywords with your own request and press Enter) +

+
+

-Thank you for your participation! +Thank you for your participation to the imapsync mailing-list!

@@ -142,22 +199,24 @@ thanks to Strawberry Perl 5.12 and Par::Packed module.
WANTED -

I code new features for free when I have time and when I find it useful.
-If you really want a feature you can donate money and I'll code it.
+

I code new features and fix bugs for free when I have time and when I find it useful.
+If you really want a feature or a fix you can donate money and my next development time +will be to code it or fix it.

Some features and their time/money to be done evaluation

- - - - - - - - + + + + + + + + +
DONEFeature Time guessedTime spentMoney receivedMoney needed
NoEfficient Gmail backup 8 hours 80 min 0 $ 240 $
NoSpeedup 50% 10 hours 80 min 10 $ 300 $
NoBackup to files 8 hours 60 min 0 $ 240 $
No--deletefolder2 3 hours 30 min 0 $ 90 $
NoNTLM auth 3 hours 60 min 0 $ 90 $
YesWin32 imapsync.exe 8 hours 520 min 0 $ 240 $
YesFix capability changes 1 hour 80 min 0 $ 30 $
YesLarge mailbox --maxage 4 hours 270 min 0 $ 120 $
NoEfficient Gmail backup 8 hours 80 min 0 $ 240 $
NoSpeedup 50% 10 hours 80 min 10 $ 300 $
NoBackup to files 8 hours 60 min 0 $ 240 $
Yes--delete2folders 3 hours 270 min 90 $ 0 $
NoNTLM auth 3 hours 60 min 0 $ 90 $
YesWin32 imapsync.exe 8 hours 520 min 0 $ 240 $
YesWin32 bug fixes various 370 min 100 $ 85 $
YesFix capability changes 1 hour 80 min 0 $ 30 $
YesLarge mailbox --maxage 4 hours 270 min 0 $ 120 $

COPYING

@@ -175,8 +234,8 @@ If you really want a feature you can donate money and I'll code it.
This document last modified
-$Id: index.shtml,v 1.22 2010/08/21 13:39:35 gilles Exp gilles $ +$Id: index.shtml,v 1.31 2010/10/25 00:05:35 gilles Exp gilles $

- \ No newline at end of file + diff --git a/learn/imapclient3xx_skeleton_test b/learn/imapclient3xx_skeleton_test index f6114fd..5524e44 100644 --- a/learn/imapclient3xx_skeleton_test +++ b/learn/imapclient3xx_skeleton_test @@ -13,7 +13,7 @@ my $imap = Mail::IMAPClient->new(); $imap->Debug(1); $imap->Server($host); $imap->connect() or die; -$imap->isUnconnected(); +$imap->IsUnconnected(); $imap->User($user); $imap->Password($password); $imap->login() or die; diff --git a/learn/io_socket_get b/learn/io_socket_get old mode 100644 new mode 100755 diff --git a/learn/memory_consumption b/learn/memory_consumption new file mode 100755 index 0000000..1a4c6bd --- /dev/null +++ b/learn/memory_consumption @@ -0,0 +1,57 @@ +#!/usr/bin/perl + +use warnings; +use strict; +use English; +use Mail::IMAPClient; + +$ARGV[3] or die "usage: $0 host user password folder\n"; + +my $host = $ARGV[0]; +my $user = $ARGV[1]; +my $password = $ARGV[2]; +my $folder = $ARGV[3]; + +my $imap = Mail::IMAPClient->new(); +$imap->Debug(0); +$imap->Server($host); +$imap->connect() or die; +$imap->User($user); +$imap->Password($password); +$imap->login() or die; +$imap->Uid(1); +$imap->Peek(1); +$imap->Clear(1); + +#print map {"$_\n"} $imap->folders(); + +$imap->select($folder) or die; +my @msgs = $imap->messages or die "Could not messages: $@\n"; +print "@msgs\n"; +print memory_consumption(); +foreach my $msg (@msgs) { + my $size = $imap->size($msg); + print "message size of $msg = $size bytes\n"; + my $string = $imap->message_string($msg); + print memory_consumption(); + $imap->append('INBOX.Trash', $string); + print memory_consumption(); +} +$imap->close(); +print memory_consumption(); + + +sub memory_consumption { + + my @PID = (@_) ? @_ : ($PROCESS_ID); + my $val; + + my ($package, $filename, $line, $subroutine) = caller(0); + $val = "$package $filename line $line: "; + my @ps = qx{ ps o vsz @PID }; + my $vsz = $ps[1]; + chomp($vsz); + $val .= $vsz * 1024 . " bytes\n"; + #$val .= '-' x 80 . "\n"; + return($val); +} diff --git a/learn/message_string_raw b/learn/message_string_raw new file mode 100755 index 0000000..25ec062 --- /dev/null +++ b/learn/message_string_raw @@ -0,0 +1,110 @@ +#!/usr/bin/perl + +use warnings; +use strict; +use English; +use Mail::IMAPClient; +use Socket; + +$ARGV[3] or die "usage: $0 host user password folder\n"; + +my $host = $ARGV[0]; +my $user = $ARGV[1]; +my $password = $ARGV[2]; +my $folder = $ARGV[3]; + +my $imap = Mail::IMAPClient->new(); +$imap->Debug(0); +$imap->Server($host); +$imap->connect() or die; +$imap->User($user); +$imap->Password($password); +$imap->login() or die; +$imap->Uid(1); +$imap->Peek(1); +$imap->Clear(1); + +#print map {"$_\n"} $imap->folders(); + +$imap->select($folder) or die; +my @msgs = $imap->messages or die "Could not messages: $@\n"; +print "@msgs\n"; +print memory_consumption_ratio(), "\n"; + +my $size_max = 0; +foreach my $msg (@msgs) { + my $size = $imap->size($msg); + $size_max = ($size_max > $size) ? $size_max : $size; + print "message size of $msg = $size bytes\n"; + my $string_raw = $imap->message_string_raw($msg); + print "ms raw: ", memory_consumption_ratio($size_max), "\n"; + my $string = $imap->message_string($msg); + print "ms nor: ", memory_consumption_ratio($size_max), "\n"; + print "NOT EQUAL\n" if ($string_raw ne $string); + #print substr($string_raw, 0, 80), "]\n"; + #print substr($string_raw, -80, 80), "]\n"; + $imap->append('INBOX.Trash', $string_raw); + $imap->append('INBOX.Trash', $string); +} +$imap->close(); +print "ap nor: ", memory_consumption_ratio($size_max), "\n"; + + +sub memory_consumption_of_pid { + + my @PID = (@_) ? @_ : ($PROCESS_ID); + my $val; + + my @ps = qx{ ps o vsz @PID }; + shift @ps; + chomp @ps; + my @val = map { $_ * 1024 } @ps; + return(@val); +} + +sub memory_consumption_ratio { + + my ($base) = @_; + $base ||= 1; + my ($consu) = memory_consumption_of_pid(); + return($consu / $base); +} + +package Mail::IMAPClient; + +sub message_string_raw { + + my $self = shift; + my ($msg) = @_; + my $sock = $self->{Socket}; + print "Socket:[$sock]\n"; + my $count = $self->Count($self->Count+1); + + print $sock "$count UID FETCH 1 BODY.PEEK[]\r\n"; + my $buf; + my $line; + CORE::select( undef, undef, undef, 0.025 ); + my $expected_size; + + local $/ = "\r\n"; + $line = <$sock>; + print $line; + + if ( $line =~ m/.*{(\d+)\}\r\n/o ) { + $expected_size = $1; + print "\nEXPECT $expected_size\n"; + } + + #local $/; + while ($buf .= <$sock> and (length $buf <= $expected_size)){ + #print length $buf, "\n"; + #CORE::select( undef, undef, undef, 0.025 ); + } + $line = <$sock>; + print $line; + if ( $line =~ m/$count OK FETCH.*\r\n/o ) { + return(substr($buf, 0, $expected_size)) + }else{ + return(undef); + } +} diff --git a/learn/message_string_raw_pb b/learn/message_string_raw_pb new file mode 100755 index 0000000..19652c0 --- /dev/null +++ b/learn/message_string_raw_pb @@ -0,0 +1,209 @@ +#!/usr/bin/perl + +use warnings; +use strict; +use English; +use Mail::IMAPClient; +use Socket; + +$ARGV[3] or die "usage: $0 host user password folder\n"; + +my $host = $ARGV[0]; +my $user = $ARGV[1]; +my $password = $ARGV[2]; +my $folder = $ARGV[3]; + +my $imap = Mail::IMAPClient->new(); +$imap->Debug(0); +$imap->Server($host); +$imap->connect() or die; +$imap->User($user); +$imap->Password($password); +$imap->login() or die; +$imap->Uid(1); +$imap->Peek(1); +$imap->Clear(1); + +#print map {"$_\n"} $imap->folders(); + +$imap->select($folder) or die; +my @msgs = $imap->messages or die "Could not messages: $@\n"; +print "@msgs\n"; +print memory_consumption_ratio(), "\n"; + +my $size_max = 0; +foreach my $msg (@msgs) { + my $size = $imap->size($msg); + $size_max = ($size_max > $size) ? $size_max : $size; + print "message size of $msg = $size bytes\n"; + my $string_raw = $imap->message_string_raw($msg); + print "ms raw: ", memory_consumption_ratio($size_max), "\n"; + + #$imap->append_string('INBOX.Trash', $string_raw); + my $uid_raw = $imap->append_string_raw('INBOX.Trash', $string_raw); + print "ap raw $uid_raw: ", memory_consumption_ratio($size_max), "\n"; + my $string = $imap->message_string($msg); + print "ms nor: ", memory_consumption_ratio($size_max), "\n"; + print "NOT EQUAL\n" if ($string_raw ne $string); + #print substr($string_raw, 0, 80), "]\n"; + #print substr($string_raw, -80, 80), "]\n"; + my $uid_nor = $imap->append_string('INBOX.Trash', $string_raw); + print "ap nor $uid_nor: ", memory_consumption_ratio($size_max), "\n"; + $imap->select('INBOX.Trash') or die; + $string_raw = $imap->message_string_raw($uid_raw); + print "msraw $uid_raw D:", substr($string_raw, 0, 80), "]\n"; + print "msraw $uid_raw F:", substr($string_raw, -80, 80), "]\n"; + $string = $imap->message_string_raw($uid_nor); + print "msraw $uid_nor D:", substr($string, 0, 80), "]\n"; + print "msraw $uid_nor F:", substr($string, -80, 80), "]\n"; + print "NOT EQUAL app\n" if ($string_raw ne $string); + print "eq: ", memory_consumption_ratio($size_max), "\n"; +} +$imap->close(); + + +sub memory_consumption_of_pid { + + my @PID = (@_) ? @_ : ($PROCESS_ID); + my $val; + + my @ps = qx{ ps o vsz @PID }; + shift @ps; + chomp @ps; + my @val = map { $_ * 1024 } @ps; + return(@val); +} + +sub memory_consumption_ratio { + + my ($base) = @_; + $base ||= 1; + my ($consu) = memory_consumption_of_pid(); + return($consu / $base); +} + +package Mail::IMAPClient; +use Errno qw(EAGAIN EPIPE ECONNRESET); + +sub message_string_raw { + + my $self = shift; + my ($msg) = @_; + my $sock = $self->{Socket}; + my $io_sel= IO::Select->new($sock); + my $count = $self->Count($self->Count+1); + + print "$count UID FETCH $msg BODY.PEEK[]\r\n"; + print $sock "$count UID FETCH $msg BODY.PEEK[]\r\n"; + my $buf; + my $line; + CORE::select( undef, undef, undef, 0.025 ); + my $expected_size; + + local $/ = "\r\n"; + $line = <$sock>; + print "msr <> [$line]"; + + if ( $line =~ m/.*{(\d+)\}\r\n/o ) { + $expected_size = $1; + print "\nEXPECT $expected_size\n"; + } + + #local $/; + while ($buf .= <$sock> and (length $buf <= $expected_size)){ + } + CORE::select( undef, undef, undef, 0.025 ); + $line = <$sock>; + print "[$line][$count OK FETCH]\n"; + if ( $line =~ m/$count OK FETCH/o ) { + print "GOOD\n"; + return(substr($buf, 0, $expected_size)) + }else{ + print "BAD\n"; + return(undef); + } +} + + +sub append_string_raw { + my $self = shift; + + my $folder = $self->Massage(shift); + my ( $text, $flags, $date ) = @_; + defined $text or $text = ''; + + my $sock = $self->{Socket}; + my $io_sel = IO::Select->new($sock); + + my($count, $line); + + 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/\r\n/og; + + my $command = + "APPEND $folder " + . ( $flags ? "$flags " : "" ) + . ( $date ? "$date " : "" ) . "{" + . length($text) + . "}\r\n"; + + local $/ = "\r\n"; + + #print $command; + + $count = $self->Count($self->Count+1); + my $string = "$count ". $command . $text . "\r\n"; + $io_sel->can_write(); + $self->_send_bytes_2(\$string); + $io_sel->can_read(); + $line = <$sock>; + #print "APP 1 [$line]\n"; + + $io_sel->can_read(); + $line = <$sock>; + print "APP 2 [$line]\n"; + + my $ret; + # OK [APPENDUID ] APPEND completed + if ($line =~ m{^$count\s+OK\s+\[APPENDUID\s+\d+\s+(\d+)\]}) { + $ret = $1; + }else{ + $ret = undef; + } + return($ret); +} + +sub _send_bytes_2 { + my ( $self, $byteref ) = @_; + my ( $total ) = ( 0 ); + + local $SIG{PIPE} = 'IGNORE'; # handle SIGPIPE as normal error + + while ( $total < length $$byteref ) { + my $written = + syswrite( $self->Socket, $$byteref, length($$byteref) - $total, + $total ); + + if ( defined $written ) { + $total += $written; + next; + } + + next if ( $! == EAGAIN ) ; + + return undef; # no luck + } + $self->_debug("Sent $total bytes"); + return $total; +} diff --git a/learn/mi2 b/learn/mi2 new file mode 100755 index 0000000..ba00318 --- /dev/null +++ b/learn/mi2 @@ -0,0 +1,4 @@ +#!/bin/sh + +perl -I../Mail-IMAPClient-2.2.9 "$@" + diff --git a/learn/mi3 b/learn/mi3 new file mode 100755 index 0000000..1636ebe --- /dev/null +++ b/learn/mi3 @@ -0,0 +1,4 @@ +#!/bin/sh + +perl -I../Mail-IMAPClient-3.25/lib "$@" + diff --git a/logo_imapsync.png b/logo_imapsync.png new file mode 100644 index 0000000..4c196fd Binary files /dev/null and b/logo_imapsync.png differ diff --git a/logo_imapsync_2.svg b/logo_imapsync_2.svg new file mode 100644 index 0000000..506cfe6 --- /dev/null +++ b/logo_imapsync_2.svg @@ -0,0 +1,149 @@ + + + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + + + + + + + diff --git a/logo_imapsync_s.png b/logo_imapsync_s.png new file mode 100644 index 0000000..2526144 Binary files /dev/null and b/logo_imapsync_s.png differ diff --git a/memo b/memo index 177e9b2..d2116da 100644 --- a/memo +++ b/memo @@ -1,5 +1,6 @@ #!/bin/sh +# $Id: memo,v 1.23 2010/10/24 23:49:28 gilles Exp gilles $ software_version() { @@ -7,6 +8,24 @@ software_version() { } +statistics_lfo() { +#grep prj/imapsync/VERSION /usr/local/apache/logs/access_log | sort -n | cut -d ' ' -f 1,12,13|uniq -c | sort -n # list ip + +cat <] + [--user1 ] [--passfile1 ] + [--host2 server2] [--port2 ] + [--user2 ] [--passfile2 ] + [--ssl1] [--ssl2] + [--tls1] [--tls2] + [--authmech1 ] [--authmech2 ] + [--noauthmd5] + [--folder --folder ...] + [--folderrec --folderrec ...] + [--include ] [--exclude ] + [--prefix2 ] [--prefix1 ] + [--regextrans2 --regextrans2 ...] + [--sep1 ] + [--sep2 ] + [--justfolders] [--justfoldersizes] [--justconnect] [--justbanner] + [--syncinternaldates] + [--idatefromheader] + [--buffersize ] + [--syncacls] + [--regexmess ] [--regexmess ] + [--maxsize ] + [--minsize ] + [--maxage ] + [--minage ] + [--skipheader ] + [--useheader ] [--useheader ] + [--skipsize] [--allowsizemismatch] + [--delete] [--delete2] + [--expunge] [--expunge1] [--expunge2] [--uidexpunge2] + [--subscribed] [--subscribe] [--subscribe_all] + [--nofoldersizes] + [--dry] + [--debug] [--debugimap][--debugimap1][--debugimap2] + [--timeout ] [--fast] + [--split1] [--split2] + [--reconnectretry1 ] [--reconnectretry2 ] + [--pidfile ] + [--tmpdir ] + [--version] [--help] + +=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 --expunge1 options. + +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. + + +=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, gratis and open source 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 a message to: + + +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 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(tm) and you haven't read the 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 4 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. + - dkimap4 2.39 + - Imail 7.04 (maybe). + +Success stories reported with the following 36 imap servers +(software names are in alphabetic order): + + - 1und1 H mimap1 84498 [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] + - Domino (Notes) 4.61[host1], 6.5, 5.0.6, 5.0.7, 7.0.2, 6.0.2CF1, 7.0.1[host1], 8.0.1[host1] + - 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. + - 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] + - Netscape Mail Server 3.6 (Wintel !) + - Netscape Messaging Server 4.15 Patch 7 + - OpenMail IMAP server B.07.00.k0 (Samsung Contact ?) + - OpenWave + - 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. + - 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 + - Sun Messaging Server 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 + +Please rate imapsync at http://freshmeat.net/projects/imapsync/ +or better give the author a book, he likes books: +http://www.amazon.com/gp/registry/wishlist/1C9UNDIH3P7R7/ +(or its paypal account gilles.lamiral@laposte.net) + +=head1 HUGE MIGRATION + +Pay special attention to options +--subscribed +--subscribe +--delete +--delete2 +--expunge +--expunge1 +--expunge2 +--uidexpunge2 +--maxage +--minage +--maxsize +--useheader +--fast + +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.350 2010/09/06 01:05:09 gilles Exp gilles $ + +=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 POSIX qw(uname); +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 Test::More 'no_plan'; + +eval { require 'usr/include/sysexits.ph' }; + +# global variables + +my( + $rcs, $pidfile, + $debug, $debugimap, $debugimap1, $debugimap2, $nb_errors, + $host1, $host2, $port1, $port2, + $user1, $user2, $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, + $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, + $authuser1, $authuser2, + $authmech1, $authmech2, + $split1, $split2, + $reconnectretry1, $reconnectretry2, + $tests, $test_builder, $tests_debug, + $allow3xx, $justlogin, + $tmpdir, + $releasecheck, +); + +# main program + +# global variables initialisation + +$rcs = '$Id: imapsync,v 1.350 2010/09/06 01:05:09 gilles Exp gilles $ '; + +$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; + +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(); + +$releasecheck = defined($releasecheck) ? $releasecheck : 1; +my $warn_release = ($releasecheck) ? check_last_release() : ''; + +# default values + +$tmpdir ||= File::Spec->tmpdir(); +$pidfile ||= $tmpdir . '/imapsync.pid'; + +# allow Mail::IMAPClient 3.0.xx by default +$allow3xx = defined($allow3xx) ? $allow3xx : 1; + +print banner_imapsync(@argv_copy); + +print "Temp directory is $tmpdir\n"; + +is_valid_directory($tmpdir); +write_pidfile($pidfile) if ($pidfile); + +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.0.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); + +# By default, don't take size to compare +$skipsize = (defined $skipsize) ? $skipsize : 1; + +sub connect_imap { + my($host, $port, $debugimap, $ssl, $tls) = @_; + my $imap = Mail::IMAPClient->new(); + $imap->Server($host); + $imap->Port($port); + $imap->Debug($debugimap); + $imap->Ssl($ssl) if ($ssl); + $imap->Tls($tls) if ($tls); + #$imap->connect() + myconnect($imap) + or die_clean("Can not open imap connection on [$host]: $@\n"); +} + + +if ($justconnect) { + justconnect(); + exit_clean(0); +} + +$user1 || missing_option("--user1"); +$user2 || missing_option("--user2"); + +$syncinternaldates = defined($syncinternaldates) ? $syncinternaldates : 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 not($authmd5)) { + $authmech1 ||= 'LOGIN'; + $authmech2 ||= 'LOGIN'; +} +else{ + $authmech1 ||= $authuser1 ? 'PLAIN' : 'CRAM-MD5'; + $authmech2 ||= $authuser2 ? 'PLAIN' : 'CRAM-MD5'; +} + +$authmech1 = uc($authmech1); +$authmech2 = uc($authmech2); + +$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 = ("ALL") unless (@useheader); + +print "Host1: imap server [$host1] port [$port1] user [$user1]\n"; +print "Host2: imap server [$host2] port [$port2] user [$user2]\n"; + + +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; +} + + +$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, $password1, + $debugimap1, $timeout, $fastio1, $ssl1, $tls1, + $authmech1, $authuser1, $reconnectretry1); + +$debugimap2 and print "Host2 connection\n"; +$imap2 = login_imap($host2, $port2, $user2, $password2, + $debugimap2, $timeout, $fastio2, $ssl2, $tls2, + $authmech2, $authuser2, $reconnectretry2); + +# history + +$debug and print "Host1 Buffer I/O: ", $imap1->Buffer(), "\n"; +$debug and print "Host2 Buffer I/O: ", $imap2->Buffer(), "\n"; + + +sub login_imap { + my($host, $port, $user, $password, + $debugimap, $timeout, $fastio, + $ssl, $tls, $authmech, $authuser, $reconnectretry) = @_; + my ($imap); + + $imap = Mail::IMAPClient->new(); + + $imap->Ssl($ssl) if ($ssl); + $imap->Tls($tls) if ($tls); + $imap->Clear(5); + $imap->Server($host); + $imap->Port($port); + $imap->Fast_io($fastio); + $imap->Buffer($buffersize || 4096); + $imap->Uid(1); + $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"; + } + } + + $imap->Authmechanism($authmech) unless ($authmech eq 'LOGIN'); + $imap->Authcallback(\&plainauth) if $authmech eq "PLAIN"; + + + $imap->User($user); + $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"); + } + 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; + } + +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, %requested_folder, +@h2_folders, @h2_folders_list, %h2_folders_list, %subscribed_folder, %h2_folders); + +sub tests_folder_routines { + ok( !give_requested_folders() ,"no requested folders" ); + 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') ); + ok( init_requested_folders() , 'empty requested folders'); + ok( !give_requested_folders() , 'no requested folders' ); +} + +sub give_requested_folders { + return(keys(%requested_folder)); +} + +sub init_requested_folders { + + %requested_folder = (); + return(1); + +} + +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) ); +} + + +# Make a hash of subscribed folders in source server. +map { $subscribed_folder{$_} = 1 } $imap1->subscribed(); + + + + +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)) { + my @all_source_folders = sort $imap1->folders(); + add_to_requested_folders(@all_source_folders); + } +} + + +# consider (optional) includes and excludes +if (scalar(@include)) { + my @all_source_folders = sort $imap1->folders(); + foreach my $include (@include) { + my @included_folders = grep /$include/, @all_source_folders; + 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 = @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([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') ; +} + + +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"); + +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", + "Give the prefix namespace with the $prefix_opt option\n"; + 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; + warn + "NAMESPACE request failed for ", + $imap->Server(), ": ", $imap->LastError, "\n"; + exit_clean(1); + } + else{ + warn + "No NAMESPACE capability in imap server ", + $imap->Server(),"\n", + "Give the separator character with the $sep_opt option\n"; + exit_clean(1); + } +} + + +print "Host1 separator and prefix: [$h1_sep][$h1_prefix]\n"; +print "Host2 separator and prefix: [$h2_sep][$h2_prefix]\n"; + + +sub foldersizes { + + my ($side, $imap, $folders_r) = @_; + my $tot = 0; + my $tmess = 0; + my @folders = @{$folders_r}; + 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); + @$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; + } + + printf(" Size: %9s", $stot); + printf(" Messages: %5s\n", $smess); + $tot += $stot; + $tmess += $smess; + } + print "Total size: $tot\n"; + print "Total messages: $tmess\n"; + print "Time: ", timenext(), " s\n"; +} + + +foreach my $h1_fold (@h1_folders) { + my $h2_fold; + $h2_fold = imap2_folder_name($h1_fold); + $h2_folders{$h2_fold}++; +} + +@h2_folders = sort keys(%h2_folders); + +if ($foldersizes) { + foldersizes("Host1", $imap1, \@h1_folders); + foldersizes("Host2", $imap2, \@h2_folders); +} + + +sub timenext { + my ($timenow, $timerel); + # $timebefore is global, beurk ! + $timenow = time; + $timerel = $timenow - $timebefore; + $timebefore = $timenow; + return($timerel); +} + +exit_clean(0) if ($justfoldersizes); + +# needed for setting flags +my $imap2hasuidplus = $imap2->has_capability("UIDPLUS"); + + +@h2_folders_list = sort @{$imap2->folders()}; +foreach my $folder (@h2_folders_list) { + $h2_folders_list{$folder}++; +} + +print + "++++ Listing folders\n", + "Host1 folders list:\n", map("[$_]\n",@h1_folders),"\n", + "Host2 folders list:\n", map("[$_]\n",@h2_folders_list),"\n"; + +print + "Host1 subscribed folders list: ", + map("[$_] ", sort keys(%subscribed_folder)), "\n" + if ($subscribed); + +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 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); +} + + +# folder loop +print "++++ Looping on each folder\n"; + +FOLDER: foreach my $h1_fold (@h1_folders) { + + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + + my $h2_fold = imap2_folder_name($h1_fold); + + printf("%-35s -> %-35s\n", "[$h1_fold]", "[$h2_fold]"); + unless ($imap1->select($h1_fold)) { + warn + "Host1 folder $h1_fold: Could not select: ", + $imap1->LastError, "\n"; + $nb_errors++; + next FOLDER; + } + + if ( ! exists($h2_folders_list{$h2_fold})) { + print "Host2 folder $h2_fold does not exist\n"; + print "Creating folder [$h2_fold]\n"; + unless ($dry){ + unless ($imap2->create($h2_fold)){ + warn "Couldn't create [$h2_fold]: ", + $imap2->LastError,"\n"; + $nb_errors++; + next FOLDER; + } + } + else{ + next FOLDER; + } + } + + acls_sync($h1_fold, $h2_fold); + + unless ($imap2->select($h2_fold)) { + warn + "Host2 folder $h2_fold: Could not select: ", + $imap2->LastError, "\n"; + $nb_errors++; + 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); + + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + + 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 %h1_hash = (); + my %h2_hash = (); + + $debug and print "Host1 folder [$h1_fold] parsing headers\n"; + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + + my ($h1_heads_ref, $h1_fir_ref) = ({}, {}); + $h1_heads_ref = $imap1->parse_headers([@h1_msgs], @useheader) if (@h1_msgs); + $debug and print "Time headers: ", timenext(), " s\n"; + last FOLDER if $imap1->IsUnconnected(); + + @$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; + } + last FOLDER if $imap1->IsUnconnected(); + + + my @h1_msgs_duplicate; + foreach my $m (@h1_msgs) { + 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], @useheader) if (@h2_msgs); + $debug and print "Time headers: ", timenext(), " s\n"; + last FOLDER if $imap2->IsUnconnected(); + + @$h2_fir_ref{@h2_msgs} = (undef); # 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"; + last FOLDER if $imap2->IsUnconnected(); + + my @h2_msgs_duplicate; + foreach my $m (@h2_msgs) { + my $rc = parse_header_msg($imap2, $m, $h2_heads_ref, $h2_fir_ref, "T", \%h2_hash); + if (! defined($rc)) { + my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; + 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 + my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; + $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; + } + } + + 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 + $debug and print "msg $h1_fold/$h1_msg copying to $h2_fold\n"; + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + my $string; + $string = $imap1->message_string($h1_msg); + unless (defined($string)) { + warn + "- msg $h1_fold/$h1_msg could not fetch [$m_id $h1_size]: ", + $imap1->LastError, "\n"; + $nb_errors++; + $total_bytes_error += $h1_size; + next MESS; + } + + #my $message_file = "tmp_imapsync_$$"; + #$imap1->select($h1_fold); + #unlink($message_file); + #$imap1->message_to_file($message_file, $h1_msg) or do { + # warn "Could not put message #$h1_msg to file $message_file", + # $imap1->LastError; + # $nb_errors++; + # $total_bytes_error += $h1_size; + # next MESS; + #}; + #$string = file_to_string($message_file); + #print "AAA1[$string]ZZZ\n"; + #unlink($message_file); + if (@regexmess) { + $string = regexmess($string); + + #string_to_file($string, $message_file); + } + + + + 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); + } + + $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"; + } + + my $h1_flags = $h1_hash{$m_id}{'F'} || ""; + # 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"; + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + $h1_date = undef if ($h1_date eq ""); + unless ($dry) { + + if ($OSNAME eq "MSWin32") { + $new_id = $imap2->append_string($h2_fold, $string, $h1_flags, $h1_date); + } + else { + # just back to append_string since append_file 3.05 does not work. + #$new_id = $imap2->append_file($h2_fold, $message_file, "", $h1_flags, $d); + # append_string 3.05 does not work too some times with $d unset. + $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; + next MESS; + } + else{ + # good + # $new_id is an id if the IMAP server has the + # UIDPLUS capability else just a ref + print "msg $h1_fold/$h1_msg copied to $h2_fold/$new_id\n"; + $total_bytes_transferred += $h1_size; + $nb_msg_transferred += 1; + if($delete) { + print "msg $h1_fold/$h1_msg deleted on host1\n"; + unless($dry) { + $imap1->delete_message($h1_msg); + $h1_nb_msg_deleted += 1; + last FOLDER if $imap1->IsUnconnected(); + $imap1->expunge() if ($expunge); + last FOLDER if $imap1->IsUnconnected(); + } + } + } + } + else{ + $nb_msg_skipped_dry_mode += 1; + } + #unlink($message_file); + next MESS; + } + else{ + #my $h2_size = $h2_hash{$m_id}{'s'}; + my $h2_msg = $h2_hash{$m_id}{'m'}; + #my $h2_idate = $h2_hash{$m_id}{'D'}; + $debug and print "msg $h1_fold/$h1_msg equals $h2_fold/$h2_msg\n"; + $total_bytes_skipped += $h1_size; + $nb_msg_skipped += 1; + } + + $fast and next MESS; + #$debug and print "MESSAGE $m_id\n"; + my $h2_size = $h2_hash{$m_id}{'s'}; + my $h2_msg = $h2_hash{$m_id}{'m'}; + + # used cached flag values for efficiency + my $h1_flags = $h1_hash{$m_id}{'F'} || ""; + my $h2_flags = $h2_hash{$m_id}{'F'} || ""; + + # 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 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++; + } + last FOLDER if $imap2->IsUnconnected(); + + $debug and do { + my @h2_flags = @{ $imap2->flags($h2_msg) || [] }; + last FOLDER if $imap2->IsUnconnected(); + + print "host1 flags: $h1_flags\n", + "host2 flags: @h2_flags\n"; + + print "Looking dates\n"; + #my $h1_idate = $imap1->internaldate($h1_msg); + #my $h2_idate = $imap2->internaldate($h2_msg); + my $h1_idate = $h1_hash{$m_id}{'D'}; + my $h2_idate = $h2_hash{$m_id}{'D'}; + print + "host1 internal date: $h1_idate\n", + "host2 internal date: $h2_idate\n"; + + #unless ($h1_idate eq $h2_idate) { + # print "!!! Dates differs !!!\n"; + #} + }; + unless ($skipsize or ($h1_size == $h2_size)) { + # Bad size + print + "- msg $h1_fold/$h1_msg size diff $h1_size != $h2_size $h2_fold/$h2_msg\n"; + $nb_errors++; + } + else { + # Good + $debug and print + "msg $h1_fold/$h1_msg sizes ok $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); + } + } + } + } + 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"; +} + +print "++++ End looping on each folder\n"; + + +# FOLDER loop is exited any time a connection is lost be sure to log it! +# Example: +# lost_connection($imap1,"host1 [$host1]"); +# +# can be tested with a "killall /usr/bin/imapd" (or equivalent) in command line. +# +sub _filter { + my $str = shift or return ""; + my $sz = 64; + my $len = length($str); + if ( ! $debug and $len > $sz*2 ) { + my $beg = substr($str, 0, $sz); + my $end = substr($str, -$sz, $sz); + $str = $beg . "..." . $end; + } + $str =~ s/\012?\015$//; + return "(len=$len) " . $str; +} + +sub lost_connection { + my($imap, $error_message) = @_; + if ( $imap->IsUnconnected() ) { + $nb_errors++; + my $lcomm = $imap->LastIMAPCommand || ""; + my $einfo = $imap->LastError || @{$imap->History}[-1] || ""; + + # if string is long try reduce to a more reasonable size + $lcomm = _filter($lcomm); + $einfo = _filter($einfo); + warn("error: last command: $lcomm\n") if ($debug && $lcomm); + warn("error: lost connection $error_message", $einfo, "\n"); + return(1); + }else{ + return(0); + } +} + +$imap1->logout(); +$imap2->logout(); + +my $host1_reconnect_count = $imap1->Reconnect_counter() || 0; +my $host2_reconnect_count = $imap2->Reconnect_counter() || 0; + +$timeend = time(); + +$timediff = $timeend - $timestart; + +stats(); + +exit_clean(1) if($nb_errors); + +exit_clean(0); + +# END of main program + +# subroutines + +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)) + { + 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 banner_imapsync { + + my @argv_copy = @_; + my $banner_imapsync = join("", + '$RCSfile: imapsync,v $ ', + '$Revision: 1.350 $ ', + '$Date: 2010/09/06 01:05:09 $ ', + "\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 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 exit_clean { + my $status = shift; + + 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_msgs { + my ($imap) = @_; + my (@msgs,@max,@min,@union,@inter); + + unless (defined($maxage) or defined($minage)) { + @msgs = $imap->search("ALL"); + 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 stats { + 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"; + print "Detected $nb_errors errors\n\n"; + + print $warn_release, "\n"; + print thank_author(); +} + +sub thank_author { + + 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, + "password1=s" => \$password1, + "password2=s" => \$password2, + "passfile1=s" => \$passfile1, + "passfile2=s" => \$passfile2, + "authmd5!" => \$authmd5, + "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, + "syncinternaldates!" => \$syncinternaldates, + "idatefromheader!" => \$idatefromheader, + "syncacls!" => \$syncacls, + "maxsize=i" => \$maxsize, + "minsize=i" => \$minsize, + "maxage=i" => \$maxage, + "minage=i" => \$minage, + "buffersize=i" => \$buffersize, + "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, + "authmech1=s" => \$authmech1, + "authmech2=s" => \$authmech2, + "authuser1=s" => \$authuser1, + "authuser2=s" => \$authuser2, + "split1=i" => \$split1, + "split2=i" => \$split2, + "reconnectretry1=i" => \$reconnectretry1, + "reconnectretry2=i" => \$reconnectretry2, + "tests" => \$tests, + "tests_debug" => \$tests_debug, + "allow3xx!" => \$allow3xx, + "justlogin!" => \$justlogin, + "tmpdir=s" => \$tmpdir, + "pidfile=s" => \$pidfile, + "releasecheck!" => \$releasecheck, + ); + + $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 ?) + # and uppercase header keywords + # (dbmail and dovecot) + $val =~ s/^\s*(.+)$/$1/; + + #my $H = uc($h); + my $H = "$h: $val"; + # show stuff in debug mode + $debug and print "${s}H $H:", $val, "\n"; + + if ($skipheader and $H =~ m/$skipheader/i) { + $debug and print "Skipping header $H\n"; + next; + } + #$headstr .= "$H:". $val; + $headstr .= "$H"; + } + } + #return unless ($headstr); + unless ($headstr){ + # taking everything is too heavy, + # should take only 1 Ko + #print "no header so taking everything\n"; + #$headstr = $imap->message_string($m_uid); + + print "no header so we ignore this message\n"; + return undef; + } + 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 check_last_release { + + my $public_release = not_long('imapsync_version_lfo'); + return('') if ($public_release eq 'unknown'); + + 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.350 2010/09/06 01:05:09 gilles Exp gilles $ '; + $rcs =~ m/,v (\d+\.\d+)/; + my $VERSION = ($1) ? $1: "UNKNOWN"; + return($VERSION); +} + + +sub imapsync_version_lfo { + + my $local_version = imapsync_version(); + my $agent_info = "$OSNAME system, perl $PERL_VERSION, Mail::IMAPClient $Mail::IMAPClient::VERSION"; + my $sock = new IO::Socket::INET ( + PeerAddr => 'linux-france.org', + 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 { + + my ($func) = @_; + my $val; + eval { + local $SIG{ALRM} = sub { die "alarm\n" }; + alarm 3; + #print $func, "\n"; + { + no strict "refs"; + $val = &$func(); + } + alarm 0; + }; + if ($@) { + # timed out + return('unknown') unless $@ eq "alarm\n"; # 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 = check_last_release(); + print < : "from" imap server. Mandatory. +--port1 : port to connect on host1. Default is 143. +--user1 : user to login on host1. Mandatory. +--authuser1 : user to auth with on host1 (admin user). + Avoid using --authmech1 SOMETHING with --authuser1. +--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. +--authuser2 : user to auth with on host2 (admin user). +--password2 : password for the user2. Dangerous, use --passfile2 +--passfile2 : password file for the user2. Contains the password. +--noauthmd5 : don't use MD5 authentification. +--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 imap, "delete" tags messages as deleted, they + are not really deleted. See expunge. +--delete2 : delete messages on host2 that are not on + host1 server. +--expunge : expunge messages on host1. + expunge really deletes messages marked deleted. + expunge is made at the beginning, on host1 only. + Newly transferred messages are expunged if + option --expunge is given. + No expunge is done on destination account + (see --expunge2) but it may change in future releases. +--expunge1 : expunge messages on host1. +--expunge2 : expunge messages on host2. +--uidexpunge2 : uidexpunge messages on the destination imap server + that are not on the source server, 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. +--buffersize : sets the size of a block of I/O. +--maxsize : skip messages larger than bytes +--minsize : skip messages smaller 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. +--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 (just does not sync flags of messages + already transfered). +--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. +--fastio1 : use fastio with host1. +--fastio2 : use fastio with 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 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_debug { + + SKIP: { + skip "No test in normal run" if (not $tests_debug); + tests_good_date(); + } +} + +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(); + } +} + +# 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::append_file = sub { + + my $self = shift; + my $folder = $self->Massage(shift); + my $file = shift; + my $control = shift || undef; + my $count = $self->Count($self->Count+1); + my $flags = shift || undef; + my $date = shift || undef; + + if (defined($flags)) { + $flags =~ s/^\s+//g; + $flags =~ s/\s+$//g; + } + + if (defined($date)) { + $date =~ s/^\s+//g; + $date =~ s/\s+$//g; + } + + $flags = "($flags)" if $flags and $flags !~ /^\(.*\)$/ ; + $date = qq/"$date"/ if $date and $date !~ /^"/ ; + + + unless ( -f $file ) { + $self->LastError("File $file not found.\n"); + return undef; + } + + my $fh = IO::File->new($file) ; + + unless ($fh) { + $self->LastError("Unable to open $file: $!\n"); + $@ = "Unable to open $file: $!" ; + carp "unable to open $file: $!"; + return undef; + } + + my $bare_nl_count = scalar grep { /^\x0a$|[^\x0d]\x0a$/} <$fh>; + + seek($fh,0,0); + + my $clear = $self->Clear; + + $self->Clear($clear) + if $self->Count >= $clear and $clear > 0; + + my $length = ( -s $file ) + $bare_nl_count; + + my $string = "$count APPEND $folder " . + ( $flags ? "$flags " : "" ) . + ( $date ? "$date " : "" ) . + "{" . $length . "}\x0d\x0a" ; + + $self->_record($count,[ $self->_next_index($count), "INPUT", "$string" ] ); + + my $feedback = $self->_send_line("$string"); + + unless ($feedback) { + $self->LastError("Error sending '$string' to IMAP: $!\n"); + $fh->close; + return undef; + } + + my ($code, $output) = ("",""); + + until ( $code ) { + $output = $self->_read_line or $fh->close, return undef; + foreach my $o (@$output) { + $self->_record($count,$o); # $o is already an array ref + ($code) = $o->[DATA] =~ /(^\+|^\d+\sNO|^\d+\sBAD)/i; + if ($o->[DATA] =~ /^\*\s+BYE/) { + carp $o->[DATA]; + $self->State(Unconnected); + $fh->close; + return undef ; + } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) { + carp $o->[DATA]; + $fh->close; + return undef; + } + } + } + + { # Narrow scope + # Slurp up headers: later we'll make this more efficient I guess + local $/ = "\x0d\x0a\x0d\x0a"; + my $text = <$fh>; + $text =~ s/\x0d?\x0a/\x0d\x0a/g; + $self->_record($count,[ $self->_next_index($count), "INPUT", "{From file $file}" ] ) ; + $feedback = $self->_send_line($text); + + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + $fh->close; + return undef; + } + _debug($self, "control points to $$control\n") if ref($control) and $self->Debug; + $/ = ref($control) ? "\x0a" : $control ? $control : "\x0a"; + while (defined($text = <$fh>)) { + $text =~ s/\x0d?\x0a/\x0d\x0a/g; + $self->_record( $count, + [ $self->_next_index($count), "INPUT", "{from $file}\x0d\x0a" ] + ); + $feedback = $self->_send_line($text,1); + + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + $fh->close; + return undef; + } + } + $feedback = $self->_send_line("\x0d\x0a"); + + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + $fh->close; + return undef; + } + } + + # Now for the crucial test: Did the append work or not? + ($code, $output) = ("",""); + + my $uid = undef; + until ( $code ) { + $output = $self->_read_line or return undef; + foreach my $o (@$output) { + $self->_record($count,$o); # $o is already an array ref + $self->_debug("append_file: Deciding if " . $o->[DATA] . " has the code.\n") + if $self->Debug; + ($code) = $o->[DATA] =~ /^\d+\s(NO|BAD|OK)/i; + # try to grab new msg's uid from o/p + $o->[DATA] =~ m#UID\s+\d+\s+(\d+)\]# and $uid = $1; + if ($o->[DATA] =~ /^\*\s+BYE/) { + carp $o->[DATA]; + $self->State(Unconnected); + $fh->close; + return undef ; + } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) { + carp $o->[DATA]; + $fh->close; + return undef; + } + } + } + $fh->close; + + if ($code !~ /^OK/i) { + return undef; + } + + + return defined($uid) ? $uid : $self; +}; + + + + +*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' : '' ) ; + + $self->fetch($msg,$cmd) or return undef; + + my $string = ""; + + foreach my $result (@{$self->{"History"}{$self->Transaction}}) { + $string .= $result->[DATA] + if defined($result) and $self->_is_literal($result) ; + } + + # 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 ); + + # 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 ) ); + } + + 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" ; + + $self->_record($count,[ 0, "INPUT", "$string\x0d\x0a"] ); + + 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 ; + } + } + } + + # $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 "" + + ) { + 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; + + # $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) +} + +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) { + $debug and print "Calling starttls\n"; + + my $banner = starttls($self); + $debug and print "End starttls: $banner\n"; + } + + $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"; + my $banner = $self->Banner(); + $debug and print $banner; + unless ($banner =~ /^\* OK \[CAPABILITY.*STARTTLS.*\]/) { + die_clean( "No STARTTLS capability: $banner" ); + } + print $socket, "\n"; + print $socket "z00 STARTTLS\015\012"; + my $txt = $socket->getline(); + $debug and print "Read: $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"; + } + $banner; +} + +# 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; + 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; +} diff --git a/test.bat b/test.bat index c39cce2..9751900 100755 --- a/test.bat +++ b/test.bat @@ -1,17 +1,10 @@ -REM $Id: test.bat,v 1.6 2010/08/15 11:10:49 gilles Exp gilles $ +REM $Id: test.bat,v 1.7 2010/10/08 01:43:35 gilles Exp gilles $ cd C:\msys\1.0\home\Admin\imapsync perl -mMail::IMAPClient -mDigest::MD5 -mTerm::ReadKey -mIO::Socket::SSL -mDate::Manip -mFile::Spec -mDigest::HMAC_MD5 -e '' -set TZ="GMT" -REM perl ./imapsync --host1 l --user1 toto --passfile1 secret.toto --host2 l --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 -REM perl ./imapsync --host1 l --user1 tata --passfile1 secret.tata --host2 l --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 --folder INBOX +perl ./imapsync +perl ./imapsync --host1 l --user1 toto --passfile1 secret.toto --host2 l --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 +perl ./imapsync --host1 l --user1 tata --passfile1 secret.tata --host2 l --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 --folder INBOX -REM -M Date::Manip 6.xx buggy? -pp -o imapsync.exe -M Term::ReadKey -M IO::Socket::SSL -M Digest::HMAC_MD5 imapsync - -echo Checking imapsync.exe -.\imapsync.exe --host1 l --user1 toto --passfile1 secret.toto --host2 l --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 -.\imapsync.exe --host1 l --user1 tata --passfile1 secret.tata --host2 l --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 --folder INBOX -echo Done Checking imapsync.exe diff --git a/test_exe.bat b/test_exe.bat index 99adbae..c302ed4 100755 --- a/test_exe.bat +++ b/test_exe.bat @@ -3,6 +3,7 @@ cd C:\msys\1.0\home\Admin\imapsync perl -mMail::IMAPClient -mDigest::MD5 -mTerm::ReadKey -mIO::Socket::SSL -mFile::Spec -mDigest::HMAC_MD5 -e '' -.\imapsync.exe --host1 l --user1 toto --passfile1 secret.toto --host2 l --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 -.\imapsync.exe --host1 l --user1 tata --passfile1 secret.tata --host2 l --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 --folder INBOX +.\imapsync.exe +.\imapsync.exe --host1 p --user1 toto --passfile1 secret.toto --host2 p --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 +.\imapsync.exe --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 --folder INBOX diff --git a/test_exe_2.bat b/test_exe_2.bat new file mode 100644 index 0000000..c2df1e6 --- /dev/null +++ b/test_exe_2.bat @@ -0,0 +1,2 @@ +imapsync \ --host1 p --user1 toto --passfile1 secret.toto \ --host2 p --user2 titi --passfile2 secret.titi +imapsync \ --host1 p --user1 tata --passfile1 secret.tata \ --host2 p --user2 titi --passfile2 secret.titi diff --git a/tests.sh b/tests.sh index 5925037..1402eb2 100644 --- a/tests.sh +++ b/tests.sh @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: tests.sh,v 1.116 2010/09/06 01:06:52 gilles Exp gilles $ +# $Id: tests.sh,v 1.127 2010/10/25 17:59:09 gilles Exp gilles $ # Example 1: # CMD_PERL='perl -I./Mail-IMAPClient-3.25/lib' sh -x tests.sh @@ -8,8 +8,11 @@ # Example 2: # To select which Mail-IMAPClient within arguments: # sh -x tests.sh 2 locallocal 3 locallocal -# run locallocal() with Mail-IMAPClient-2.2.9 then +# This runs locallocal() with Mail-IMAPClient-2.2.9 then # again with Mail-IMAPClient-3.xx +# 2 means "use Mail-IMAPClient-2.2.9" +# 3 means "use Mail-IMAPClient-3.xx" + HOST1=${HOST1:-'localhost'} echo HOST1=$HOST1 @@ -86,10 +89,14 @@ no_args() { # mailbox tata titi on most ll_*() tests -# mailbox tete@est.belle # used on big size tests -# big_transfert() -# big_transfert_sizes_only() -# dprof() +# mailbox tete@est.belle used on big size tests: +# big_transfert() +# big_transfert_sizes_only() +# dprof() + +# mailbox big1 big2 used on bigmail tests +# ll_bigmail() +# ll_memory_consumption sendtestmessage() { email=${1:-"tata"} @@ -122,6 +129,10 @@ option_tests() { $CMD_PERL ./imapsync --tests } +option_tests_debug() { + $CMD_PERL ./imapsync --tests_debug +} + option_bad_delete2() { ! $CMD_PERL ./imapsync --delete 2 --blabla } @@ -145,8 +156,7 @@ first_sync() { --passfile1 ../../var/pass/secret.toto \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --noauthmd5 \ - --allow3xx + --noauthmd5 } @@ -162,11 +172,10 @@ locallocal() { --host1 $HOST1 --user1 tata \ --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ - --passfile2 ../../var/pass/secret.titi \ - --allow3xx + --passfile2 ../../var/pass/secret.titi } -ll_pidfile() { +pidfile() { $CMD_PERL ./imapsync \ --justbanner \ @@ -174,6 +183,17 @@ ll_pidfile() { ! test -f /var/tmp/imapsync.pid } +justbanner() { + $CMD_PERL ./imapsync \ + --justbanner +} + +nomodules_version() { + $CMD_PERL ./imapsync \ + --justbanner \ + --nomodules_version +} + ll_ask_password() { @@ -204,8 +224,7 @@ ll_timeout_ssl() { --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --folder INBOX --timeout 5 --ssl1 --ssl2 \ - --allow3xx + --folder INBOX --timeout 5 --ssl1 --ssl2 } @@ -217,8 +236,7 @@ ll_folder() { --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --folder INBOX.yop --folder INBOX.Trash \ - --allow3xx + --folder INBOX.yop --folder INBOX.Trash } ll_oneemail() { @@ -246,8 +264,7 @@ ll_folderrec() { --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --folderrec INBOX.yop \ - --allow3xx + --folderrec INBOX.yop } @@ -258,8 +275,7 @@ ll_buffersize() { --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --buffersize 8 \ - --allow3xx + --buffersize 8 } @@ -269,19 +285,31 @@ ll_justfolders() { --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --justfolders \ - --allow3xx + --justfolders --nofoldersizes echo "rm -rf /home/vmail/titi/.new_folder/" } + +ll_delete2folders() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --justfolders --nofoldersizes \ + --delete2folders +} + + + + ll_bug_folder_name_with_blank() { $CMD_PERL ./imapsync \ --host1 $HOST1 --user1 tata \ --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --justfolders \ - --allow3xx + --justfolders echo "rm -rf /home/vmail/titi/.bugs/" } @@ -294,8 +322,7 @@ ll_prefix12() { --passfile2 ../../var/pass/secret.titi \ --folder INBOX.qqq \ --prefix1 INBOX.\ - --prefix2 INBOX. \ - --allow3xx + --prefix2 INBOX. } @@ -342,8 +369,7 @@ ll_idatefromheader() { --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ --folder INBOX.oneemail \ - --idatefromheader --debug --dry \ - --allow3xx + --idatefromheader --debug --dry } @@ -354,8 +380,7 @@ ll_folder_rev() { --passfile1 ../../var/pass/secret.titi \ --host2 $HOST2 --user2 tata \ --passfile2 ../../var/pass/secret.tata \ - --folder INBOX.yop \ - --allow3xx + --folder INBOX.yop } ll_subscribed() @@ -365,8 +390,7 @@ ll_subscribed() --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --subscribed \ - --allow3xx + --subscribed } @@ -377,8 +401,7 @@ ll_subscribe() --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --subscribed --subscribe \ - --allow3xx + --subscribed --subscribe } ll_justconnect() @@ -386,8 +409,7 @@ ll_justconnect() $CMD_PERL ./imapsync \ --host2 $HOST2 \ --host1 $HOST1 \ - --justconnect \ - --allow3xx + --justconnect } ll_justfoldersizes() @@ -432,8 +454,7 @@ ll_authmd5() --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --justlogin --authmd5 \ - --allow3xx + --justlogin --authmd5 } ll_noauthmd5() @@ -443,11 +464,12 @@ ll_noauthmd5() --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --justfoldersizes --noauthmd5 \ - --allow3xx + --justlogin --noauthmd5 } + + ll_maxage() { can_send && sendtestmessage @@ -499,8 +521,7 @@ ll_maxsize() --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --maxsize 10 \ - --allow3xx + --maxsize 10 } ll_skipsize() @@ -517,8 +538,7 @@ ll_skipsize() --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --skipsize --folder INBOX.yop.yap \ - --allow3xx + --skipsize --folder INBOX.yop.yap } ll_skipheader() @@ -535,7 +555,7 @@ ll_skipheader() --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ --skipheader '^X-.*|^Date' --folder INBOX.yop.yap \ - --allow3xx --debug + --debug } @@ -553,8 +573,7 @@ ll_include() --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --include '^INBOX.yop' \ - --allow3xx + --include '^INBOX.yop' } ll_exclude() @@ -570,8 +589,7 @@ ll_exclude() --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --exclude '^INBOX.yop' \ - --allow3xx + --exclude '^INBOX.yop' } @@ -637,8 +655,7 @@ ll_sep2() --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ --folder INBOX.yop.yap \ - --sep2 '\\' --dry \ - --allow3xx + --sep2 '\\' --dry } ll_bad_login() @@ -647,8 +664,7 @@ ll_bad_login() --host1 $HOST1 --user1 toto \ --passfile1 ../../var/pass/secret.toto \ --host2 $HOST2 --user2 notiti \ - --passfile2 ../../var/pass/secret.titi \ - --allow3xx + --passfile2 ../../var/pass/secret.titi } @@ -658,8 +674,7 @@ ll_bad_host() --host1 badhost --user1 toto \ --passfile1 ../../var/pass/secret.toto \ --host2 badhost --user2 titi \ - --passfile2 ../../var/pass/secret.titi \ - --allow3xx + --passfile2 ../../var/pass/secret.titi } @@ -670,8 +685,7 @@ ll_bad_host_ssl() --passfile1 ../../var/pass/secret.toto \ --host2 badhost --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --ssl1 --ssl2 \ - --allow3xx + --ssl1 --ssl2 } @@ -684,9 +698,8 @@ ll_useheader() --passfile2 ../../var/pass/secret.titi \ --folder INBOX.yop.yap \ --useheader 'Message-ID' \ - --dry --debug \ - --allow3xx - echo 'rm /home/vmail/tata/.yop.yap/cur/*' + --dry --debug + echo 'rm /home/vmail/titi/.yop.yap/cur/*' } @@ -703,8 +716,7 @@ ll_regexmess() --folder INBOX.yop.yap \ --regexmess 's/\157/O/g' \ --regexmess 's/p/Z/g' \ - --debug \ - --allow3xx + --debug if can_send; then file=`ls -t /home/vmail/titi/.yop.yap/cur/* | tail -1` @@ -723,8 +735,7 @@ ll_regexmess_scwchu() --folder INBOX.scwchu \ --regexmess 's{\A(.*?(?! ^$))^Date:(.*?)$}{$1Date:$2\nReceived: From; $2}gxms' \ --skipsize --skipheader 'Received: From;' \ - --debug \ - --allow3xx + --debug echo 'rm /home/vmail/titi/.scwchu/cur/*' } @@ -802,8 +813,8 @@ ll_regex_flag_keep_only() ll_tls_justconnect() { $CMD_PERL ./imapsync \ - --host1 l \ - --host2 l \ + --host1 $HOST1 \ + --host2 $HOST2 \ --tls1 --tls2 \ --justconnect --debug } @@ -869,8 +880,7 @@ ll_ssl() { --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --ssl1 --ssl2 \ - --allow3xx + --ssl1 --ssl2 } ll_authmech_PLAIN() { @@ -880,8 +890,7 @@ ll_authmech_PLAIN() { --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ --justfoldersizes --nofoldersizes \ - --authmech1 PLAIN --authmech2 PLAIN \ - --allow3xx + --authmech1 PLAIN --authmech2 PLAIN } @@ -893,13 +902,10 @@ ll_authuser() { --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ --justfoldersizes --nofoldersizes \ - --authuser2 titi \ - --allow3xx + --authuser2 titi } - - ll_authmech_LOGIN() { $CMD_PERL ./imapsync \ @@ -908,8 +914,7 @@ ll_authmech_LOGIN() { --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ --justfoldersizes --nofoldersizes \ - --authmech1 LOGIN --authmech2 LOGIN \ - --allow3xx + --authmech1 LOGIN --authmech2 LOGIN } ll_authmech_CRAMMD5() { @@ -919,8 +924,7 @@ ll_authmech_CRAMMD5() { --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ --justfoldersizes --nofoldersizes \ - --authmech1 CRAM-MD5 --authmech2 CRAM-MD5 \ - --allow3xx + --authmech1 CRAM-MD5 --authmech2 CRAM-MD5 } ll_delete2() { @@ -933,7 +937,7 @@ ll_delete2() { --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ --folder INBOX \ - --delete2 --expunge2 + --delete2 --expunge2 } ll_delete() { @@ -952,12 +956,23 @@ ll_delete() { ll_bigmail() { $CMD_PERL ./imapsync \ - --host1 $HOST1 --user1 tata \ - --passfile1 ../../var/pass/secret.tata \ - --host2 $HOST2 --user2 titi \ - --passfile2 ../../var/pass/secret.titi \ + --host1 $HOST1 --user1 big1 \ + --passfile1 ../../var/pass/secret.big1 \ + --host2 $HOST2 --user2 big2 \ + --passfile2 ../../var/pass/secret.big2 \ --folder INBOX.bigmail - echo 'sudo rm -v /home/vmail/titi/.bigmail/cur/*' + echo 'sudo rm -v /home/vmail/big2/.bigmail/cur/*' +} + +ll_memory_consumption() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 big1 \ + --passfile1 ../../var/pass/secret.big1 \ + --host2 $HOST2 --user2 big2 \ + --passfile2 ../../var/pass/secret.big2 \ + --folder INBOX.bigmail2 \ + --nofoldersizes + echo 'sudo rm -v /home/vmail/big2/.bigmail2/cur/*' } @@ -995,27 +1010,22 @@ msw2() { gmail() { $CMD_PERL ./imapsync \ - --allow3xx \ --host1 imap.gmail.com \ --ssl1 \ + --authmech1 LOGIN \ --user1 gilles.lamiral@gmail.com \ --passfile1 ../../var/pass/secret.gilles_gmail \ --host2 $HOST2 \ - --ssl2 \ --user2 tata \ --passfile2 ../../var/pass/secret.tata \ - --useheader 'Message-Id' --skipsize \ - --regextrans2 's/\[Gmail\]/Gmail/' \ - --authmech1 LOGIN \ - --allowsizemismatch - #--dry # --debug --debugimap # --authmech1 LOGIN - + --useheader 'Message-Id' \ + --useheader="X-Gmail-Received" \ + --regextrans2 's/\[Gmail\]/Gmail/' } gmail_gmail() { $CMD_PERL ./imapsync \ - --allow3xx \ --host1 imap.gmail.com \ --ssl1 \ --user1 gilles.lamiral@gmail.com \ @@ -1029,13 +1039,11 @@ gmail_gmail() { --folder INBOX \ --authmech1 LOGIN --authmech2 LOGIN \ --allowsizemismatch - #--dry # --debug --debugimap # --authmech1 LOGIN } gmail_gmail2() { $CMD_PERL ./imapsync \ - --allow3xx \ --host1 imap.gmail.com \ --ssl1 \ --user1 gilles.lamiral@gmail.com \ @@ -1084,8 +1092,7 @@ archiveopteryx_1() { --passfile1 ../../var/pass/secret.aox_je \ --host2 lupus.aox.org --user2 je \ --passfile2 ../../var/pass/secret.aox_je \ - --folder INBOX --regextrans2 's/INBOX/copy/' \ - --allow3xx + --folder INBOX --regextrans2 's/INBOX/copy/' } ll_justlogin() { @@ -1096,7 +1103,7 @@ ll_justlogin() { --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --allow3xx --justlogin --noauthmd5 + --justlogin --noauthmd5 } ll_justlogin_backslash_char() { @@ -1107,7 +1114,7 @@ ll_justlogin_backslash_char() { --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 tptp@est.belle \ --passfile2 ../../var/pass/secret.tptp \ - --allow3xx --justlogin --noauthmd5 + --justlogin --noauthmd5 } @@ -1210,172 +1217,6 @@ dprof_bigmail() - -essnet_justconnect() -{ -./imapsync \ - --host1 mail2.softwareuno.com \ - --user1 gilles@mail2.softwareuno.com \ - --passfile1 ../../var/pass/secret.prw \ - --host2 mail.softwareuno.com \ - --user2 gilles@softwareuno.com \ - --passfile2 ../../var/pass/secret.prw \ - --dry --noauthmd5 --sep1 / --foldersizes --justconnect -} - -essnet_mail2_mail() -{ -./imapsync \ - --host1 mail2.softwareuno.com \ - --user1 gilles@mail2.softwareuno.com \ - --passfile1 ../../var/pass/secret.prw \ - --host2 mail.softwareuno.com \ - --user2 gilles@softwareuno.com \ - --passfile2 ../../var/pass/secret.prw \ - --noauthmd5 --sep1 / --foldersizes \ - --prefix2 "INBOX/" --regextrans2 's¤INBOX/INBOX¤INBOX¤' -} - -essnet_mail2_mail_t123() -{ - -for user1 in test1 test2 test3; do - ./imapsync \ - --host1 mail2.softwareuno.com \ - --user1 ${user1}@mail2.softwareuno.com \ - --passfile1 ../../var/pass/secret.prw \ - --host2 mail.softwareuno.com \ - --user2 gilles@softwareuno.com \ - --passfile2 ../../var/pass/secret.prw \ - --noauthmd5 --sep1 / --foldersizes \ - --prefix2 "INBOX/" --regextrans2 's¤INBOX/INBOX¤INBOX¤' \ - --debug \ - || true -done -} - - -essnet_plume2() -{ -./imapsync \ - --host1 mail2.softwareuno.com \ - --user1 gilles@mail2.softwareuno.com \ - --passfile1 ../../var/pass/secret.prw \ - --host2 plume --user2 tata \ - --passfile2 ../../var/pass/secret.tata \ - --noauthmd5 --sep1 / --foldersizes \ - --prefix2 INBOX. --regextrans2 's¤INBOX.INBOX¤INBOX¤' -} - -dynamicquest_1() -{ - -perl -I bugs/lib ./imapsync \ - --host1 69.38.48.81 \ - --user1 testuser1@dq.com \ - --passfile1 ../../var/pass/secret.dynamicquest \ - --host2 69.38.48.81 \ - --user2 testuser2@dq.com \ - --passfile2 ../../var/pass/secret.dynamicquest \ - --noauthmd5 --sep1 "/" --sep2 "/" \ - --justconnect --dry -} - -dynamicquest_2() -{ - -perl -I bugs/lib ./imapsync \ - --host1 mail.dynamicquest.com \ - --user1 gomez \ - --passfile1 ../../var/pass/secret.dynamicquestgomez \ - --host2 69.38.48.81 \ - --user2 testuser2@dq.com \ - --passfile2 ../../var/pass/secret.dynamicquest \ - --noauthmd5 \ - --justconnect --dry -} - -dynamicquest_3() -{ - -perl -I bugs/lib ./imapsync \ - --host1 loul \ - --user1 tata \ - --passfile1 ../../var/pass/secret.tata \ - --host2 69.38.48.81 \ - --user2 testuser2@dq.com \ - --passfile2 ../../var/pass/secret.dynamicquest \ - --noauthmd5 --sep2 "/" --debug --debugimap - -} - -mailenable() { - ./imapsync \ - --user1 imapsync@damashekconsulting.com \ - --host1 imap.damashekconsulting.com \ - --passfile1 ../../var/pass/secret.damashek \ - --sep1 "." --prefix1 "" \ - --host2 $HOST2 --user2 toto \ - --passfile2 ../../var/pass/secret.toto \ - --noauthmd5 -} - -ariasolutions() { - ./imapsync \ - --host1 209.17.174.20 \ - --user1 chrisw@canadapack.com \ - --passfile1 ../../var/pass/secret.ariasolutions \ - --host2 209.17.174.20 \ - --user2 chrisw@canadapack.com \ - --passfile2 ../../var/pass/secret.ariasolutions \ - --dry --noauthmd5 --justfoldersizes - - ./imapsync \ - --host1 209.17.174.20 \ - --user1 test@domain.local \ - --passfile1 ../../var/pass/secret.ariasolutions \ - --host2 209.17.174.20 \ - --user2 test@domain.local \ - --passfile2 ../../var/pass/secret.ariasolutions \ - --dry --noauthmd5 --ssl1 - -# hang after auth failure - ./imapsync \ - --host1 209.17.174.20 \ - --user1 test@domain.local \ - --passfile1 ../../var/pass/secret.ariasolutions \ - --host2 209.17.174.20 \ - --user2 test@domain.local \ - --passfile2 ../../var/pass/secret.ariasolutions \ - --dry --debug --debugimap - -} - - -ariasolutions2() { - ./imapsync \ - --host1 209.17.174.12 \ - --user1 chrisw@basebuilding.net \ - --passfile1 ../../var/pass/secret.ariasolutions2 \ - --host2 209.17.174.20 \ - --user2 chrisw@basebuilding.net\ - --passfile2 ../../var/pass/secret.ariasolutions2 \ - --noauthmd5 --syncinternaldates - # --dry --debug --debugimap - - -} - -genomics() { - -# Blocked, timeout ignored -./imapsync \ - --host1 mail.genomics.org.cn --user1 lamiral --passfile1 ../../var/pass/secret.genomics \ - --host2 szmail.genomics.cn --user2 lamiral --passfile2 ../../var/pass/secret.genomics \ - --sep1 . --prefix1 'INBOX.' --folder INBOX --useheader 'Message-Id' --expunge --skipsize \ - --timeout 7 --debug --debugimap - -} ########################## ########################## @@ -1385,12 +1226,18 @@ mandatory_tests=' no_args option_version option_tests +option_tests_debug option_bad_delete2 passwords_masked first_sync_dry first_sync locallocal -ll_pidfile +pidfile +justbanner +nomodules_version +gmail +gmail_gmail +gmail_gmail2 ll_ask_password ll_bug_folder_name_with_blank ll_timeout @@ -1439,18 +1286,21 @@ ll_authuser ll_delete2 ll_delete ll_folderrec -ll_bigmail -gmail -gmail_gmail -gmail_gmail2 -archiveopteryx_1 allow3xx noallow3xx -ll_newmessage' +ll_memory_consumption +ll_newmessage +ll_delete2folders +' other_tests=' +archiveopteryx_1 msw -ll_justlogin_backslash_char' +msw2 +ll_bigmail +ll_justlogin_backslash_char +option_tests_debug +' l() { echo "$mandatory_tests" "$other_tests"