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

Written on

-

See ChangeLog to know what's new in details.

+

See ChangeLog to know what's new in details since 2001.

-

New features since previous releases 1.404:

+

New features or bugfixes since previous release 1.411:

    -
  • Updated imapsync.exe to last Mail-IMAPClient 3.28 (thanks to Phil Pearl Lobbes)
    • -
  • Option --useuid now works also with --delete2 option.
    • +
  • Better default behavior: Option --delete2 implies --expunge2 now (unless --noexpunge2 is given.)
    • +
  • Better default behavior: Correct flags case to be RFC compliant on host2 if host1 is not (\SEEN -> \Seen)
    • +
  • Better debug: Added --debugcontent option to avoid debugging content (can be big) with --debug option.
    • +
  • Better debug: Added --debugflags to permit flag debugging only.
    • +
  • Bugfix: The APPEND error then the FETCH 0 byte error is fixed
    • +
  • Bugfix: Options --maxsize --minsize now work with --useuid
    • +
  • Bugfix: Flag sync of already transfered messages now take care of --maxsize --minsize options
    • +
  • Bugfix: Added 0 length message tracking when fetching host1 (to avoid frequently "APPEND {0}" recent issues).
    • +
  • Bugfix: Avoid now Inbox <-> INBOX problem ("already exists").
    • +
  • Bugfix: --proxyauth2 was setting proxyauth1 instead of proxyauth2
- + + +

Some numbers

+
    +
  • Number of imapsync users per month: between 2 and 3 thousands users
    • +
  • Number of imapsync transfers per month: between 3 and 8 millions transfers
    • +
  • Pourcentage of MSWin32 users : 10%
    • +
  • Biggest user usage: 5 millions of transfers in a month (one every 2 seconds)
    • +
+

Who is the author?

Gilles LAMIRAL
@@ -126,7 +144,7 @@ The Perl imapsync source code will run anywhere a Perl interpreter can

You will receive a download link just after the payment.
30 days money-back guarantee!

-

Standalone imapsync.exe for win32

+

Buy standalone imapsync.exe for win32

Struggle free from source code and Perl installation by
buying the latest win32 standalone imapsync.exe for 30 EUR

@@ -162,12 +180,12 @@ thanks to Strawberry Perl 5.12 and Par::Packer module.
The build system for imapsync.exe is XP Pro SP2 on a Intel Celeron 400 MHz 256 Mo RAM.

--> -

Support for imapsync

+

Buy professional support for imapsync

-

For 90 EUR buy imapsync support by the developper who wrote and maintains imapsync. +

For 60 EUR buy imapsync support by the developper who wrote and maintains imapsync.

-90 EUR is equal to around 125 USD, no problem to pay in USD (or any currency) with paypal: +60 EUR is equal to around 80 USD, no problem to pay in USD (or any currency) with paypal:

@@ -183,7 +201,6 @@ The build system for imapsync.exe is XP Pro SP2 on a Intel Celeron 400 MHz 256 M

-

Then you will be able to expose your issues by email or phone and to converse until your issues are solved.

@@ -333,7 +350,7 @@ will be to code it or fix it.
v2.3.7, (http://asg.web.cmu.edu/cyrus/) -
  • David Tobit V8 (proprietary Message system).
    • +
  • David Tobit V8.
  • 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]
    • @@ -344,16 +361,16 @@ will be to code it or fix it.
  • Eudora WorldMail v2
  • Gimap (Gmail imap) [host1] [host2]
  • GMX IMAP4 StreamProxy.
    • -
  • Goddy IMAP (since Goddy runs Courier)
    • +
  • Godaddy IMAP (since Godaddy runs Courier)
  • Groupwise IMAP (Novell) 6.x and 7.0. Buggy so see the FAQ.
  • hMailServer 5.3.3 [host2], 4.4.1 [host1], HMAILSERVER 5.3.2-B1769 on windows 2003 [hsot2]
  • iPlanet Messaging server 4.15, 5.1, 5.2
  • IMail 7.15 (Ipswitch/Win2003), 8.12, 11.03 [host1]
  • MailEnable 4.23 [host1] [host2]
    • -
  • MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform)
    • +
  • MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform), 12 [host2]
  • 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), + 6.5.7638.1 [host2], 6.5 [host1], Exchange 2007 SP1 (with Update Rollup 2), Exchange2007-EP-SP2, Exchange 2010 RTM (Release to Manufacturing) [host2]
  • Mirapoint server
    • @@ -404,7 +421,7 @@ alt="Viewable With Any Browser" /> This document last modified on -($Id: index.shtml,v 1.63 2011/04/19 23:51:09 gilles Exp gilles $) +($Id: index.shtml,v 1.66 2011/05/09 00:45:40 gilles Exp gilles $)

    diff --git a/lsm.imapsync b/lsm.imapsync deleted file mode 100644 index a007b99..0000000 --- a/lsm.imapsync +++ /dev/null @@ -1,16 +0,0 @@ -Begin4 -Title: imapsync -Version: 1.209 -Entered-date: 2007-01-09 -Description: IMAP synchronisation, sync, copy or migration tool. - Synchronise mailboxes between two imap servers. Good at IMAP migration. - More than 32 different IMAP server softwares supported with success. -Keywords: IMAP synchronisation mail -Author: lamiral@linux-france.org (Gilles LAMIRAL) -Maintained-by: lamiral@linux-france.org (Gilles LAMIRAL) -Primary-site: http://www.linux-france.org/prj/imapsync/dist/ -Alternate-site: -Original-site: http://www.linux-france.org/prj/imapsync/dist/ -Platforms: UNIX Windows -Copying-policy: GPL -End diff --git a/memo b/memo index d261ed7..2f1ddcb 100644 --- a/memo +++ b/memo @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: memo,v 1.30 2011/03/23 19:14:37 gilles Exp gilles $ +# $Id: memo,v 1.31 2011/05/07 02:30:54 gilles Exp gilles $ software_version() { @@ -24,7 +24,45 @@ tail -f /usr/local/apache/logs/access_log|cat -n|grep prj/imapsync/VERSION|cat - EOFF } +statistics_VERSION() { +TMPDIR=. +export TMPDIR + +echo statistics_VERSION_getstats +statistics_VERSION_getstats() { + for f in /home/lf/backuplog/linux-france.org.??-??-2011.bz2; do + b=`basename "$f" .bz2` + echo "$b" + test -f ${b}.imapsync_VERSION && continue + echo NOT DONE ${b}.imapsync_VERSION + bzip2 -dc "$f" | grep -h /prj/imapsync/VERSION > ${b}.imapsync_VERSION + done +} + +echo statistics_VERSION_monthly_ip +statistics_VERSION_monthly_ip() { + month=$1 + cut -d ' ' -f 1,12,13,18,19 linux-france.org.??-${month}-2011.imapsync_VERSION |sort -n |uniq -c|sort -n > stats_imapsync_2011_${month}.ip +} + +echo statistics_VERSION_monthly_ip_wc +statistics_VERSION_monthly_ip_wc() { + month=$1 + test -f stats_imapsync_2011_${month}.ip || statistics_VERSION_monthly_ip $month + wc -l stats_imapsync_2011_${month}.ip +} + +echo statistics_VERSION_monthly_runs +statistics_VERSION_monthly_runs() { + month=$1 + test -f stats_imapsync_2011_${month}.runs || wc -l linux-france.org.??-${month}-2011.imapsync_VERSION > stats_imapsync_2011_${month}.runs + cat stats_imapsync_2011_${month}.runs +} + + + +} niouzes_compil() { ( diff --git a/paypal.shtml b/paypal.shtml index 0285d86..810de45 100644 --- a/paypal.shtml +++ b/paypal.shtml @@ -36,7 +36,7 @@ border:0px;

    imapsync donation

    Help the author to maintain imapsync:
    -(1 EUR ~ 1.3 USD on 01/2011) +(1 EUR ~ 1.5 USD on 05/2011)

    @@ -65,7 +65,7 @@ border:0px; This document last modified on -($Id: paypal.shtml,v 1.4 2011/01/18 02:54:01 gilles Exp gilles $) +($Id: paypal.shtml,v 1.5 2011/05/07 02:23:32 gilles Exp gilles $)

    diff --git a/paypal_reply/8859_utf8 b/paypal_reply/8859_utf8 deleted file mode 100755 index 02f5630..0000000 --- a/paypal_reply/8859_utf8 +++ /dev/null @@ -1,13 +0,0 @@ -#!/usr/bin/perl -w - -# $Id: 8859_utf8,v 1.1 2010/10/01 13:00:09 gilles Exp gilles $ - -use Unicode::MapUTF8 qw(to_utf8 from_utf8 utf8_supported_charset); - -die unless (utf8_supported_charset('ISO-8859-1')); - -while (<>) { - print to_utf8({ -string => $_, -charset => 'ISO-8859-1' }); -} - - diff --git a/paypal_reply/TODO b/paypal_reply/TODO deleted file mode 100644 index 63227b7..0000000 --- a/paypal_reply/TODO +++ /dev/null @@ -1,6 +0,0 @@ - - -Rewrite all with less scripts -use Email::Simple module - - diff --git a/paypal_reply/memo b/paypal_reply/memo deleted file mode 100644 index 9bba168..0000000 --- a/paypal_reply/memo +++ /dev/null @@ -1,147 +0,0 @@ -#!/bin/sh - -# $Id: memo,v 1.3 2011/03/28 02:14:47 gilles Exp gilles $ - -echo paypal_bilan_tests_refact_2 -paypal_bilan_tests_refact_2() { -# DID output no diff between paypal_bilan_1.22 and 1.23 -( -set -x -for f in /g/paypal/paypal_201?_??_complet.csv; do - fb=`basename "$f"` - f1=/g/var/paypal_bilan/tests/${fb}_1.22.out1 - f2=/g/var/paypal_bilan/tests/${fb}_1.22.out2 - rm "$f2" - /g/public_html/imapsync/paypal_reply/paypal_bilan_1.22 \ - --bnc --debug --debug_csv "$f" \ - > "$f1" - - /g/public_html/imapsync/paypal_reply/paypal_bilan \ - --bnc --debug --debug_csv "$f" \ - > "$f2" - - echo diff "$f1" "$f2" - diff "$f1" "$f2" -done - -for f in /g/paypal/paypal_201?_??_complet.csv; do - fb=`basename "$f"` - f1=/g/var/paypal_bilan/tests/${fb}_tva.out1 - f2=/g/var/paypal_bilan/tests/${fb}_tva.out2 - rm "$f2" - /g/public_html/imapsync/paypal_reply/paypal_bilan_1.22 \ - "$f" \ - > "$f1" - - /g/public_html/imapsync/paypal_reply/paypal_bilan \ - "$f" \ - > "$f2" - - echo diff "$f1" "$f2" - diff "$f1" "$f2" -done - - - -) -} - - - -#echo paypal_bilan_tests_refact_1 -paypal_bilan_tests_refact_1() { -# DID output no diff between paypal_bilan_1.11 and 1.13 -( -#set -x -for f in /g/paypal/paypal_201?_??.csv; do - fb=`basename "$f"` - f1=/g/var/paypal_bilan/tests/$fb.out1 - f2=/g/var/paypal_bilan/tests/$fb.out2 - rm "$f2" - /g/public_html/imapsync/paypal_reply/paypal_bilan_1.11 \ - --bnc --debug "$f" \ - > "$f1" - - /g/public_html/imapsync/paypal_reply/paypal_bilan \ - --bnc --debug "$f" \ - > "$f2" - - echo diff "$f1" "$f2" - diff "$f1" "$f2" -done - -for f in /g/paypal/paypal_201?_??.csv; do - fb=`basename "$f"` - f1=/g/var/paypal_bilan/tests/$fb.out1 - f2=/g/var/paypal_bilan/tests/$fb.out2_usd_eur - rm "$f2" - /g/public_html/imapsync/paypal_reply/paypal_bilan_1.11 \ - --bnc --debug "$f" \ - > "$f1" - - /g/public_html/imapsync/paypal_reply/paypal_bilan \ - --bnc --debug --usdeur 1.2981 "$f" \ - > "$f2" - - echo diff "$f1" "$f2" - diff "$f1" "$f2" -done - -for f in /g/paypal/paypal_201?_??.csv; do - fb=`basename "$f" .csv` - - #echo $fb - - f1i=/g/paypal/$fb.csv - f2i=/g/paypal/${fb}_complet.csv - - f1o=/g/var/paypal_bilan/tests/t03_$fb.out1 - f2o=/g/var/paypal_bilan/tests/t03_$fb.out2 - - #echo $f1i - #echo $f2i - #echo $f1o - #echo $f2o - - rm -f "$f1o" "$f2o" - /g/public_html/imapsync/paypal_reply/paypal_bilan \ - --bnc --debug "$f1i" \ - > "$f1o" - - /g/public_html/imapsync/paypal_reply/paypal_bilan \ - --bnc --debug "$f2i" \ - > "$f2o" - - echo diff "$f1o" "$f2o" - diff "$f1o" "$f2o" -done -) -} - -#echo paypal_bilan_tests_dev -paypal_bilan_tests_dev() { - -/g/public_html/imapsync/paypal_reply/paypal_bilan \ - /g/paypal/paypal_201?_??_complet.csv --invoices '1 50 200' - -# Strange characters -/g/public_html/imapsync/paypal_reply/paypal_bilan \ - /g/paypal/paypal_201?_??_complet.csv --invoices '389 234 96' - -# France -/g/public_html/imapsync/paypal_reply/paypal_bilan \ - /g/paypal/paypal_201?_??_complet.csv --invoices '9 392' - -# individual -/g/public_html/imapsync/paypal_reply/paypal_bilan \ - /g/paypal/paypal_201?_??_complet.csv --invoices '313 415' - -# /g/public_html/imapsync/paypal_reply/paypal_bilan /g/paypal/paypal_2011_03_complet.csv -# pb with latex -# Ok 10 # character -# 65 clientAdrB Keyboard character used is undefined YOSHITO YONEI -# Ok 84 Missing $ inserted. clientEmail victor_su@yahoo.com -# 92 Dr. Westernacher & Partner GmbH - -# /g/public_html/imapsync/paypal_reply/paypal_bilan --first_in 147 --invoices '242' /g/paypal/paypal_2010_1?_complet.csv -} diff --git a/paypal_reply/paypal_bilan b/paypal_reply/paypal_bilan deleted file mode 100755 index e679737..0000000 --- a/paypal_reply/paypal_bilan +++ /dev/null @@ -1,773 +0,0 @@ -#!/usr/bin/perl - -# $Id: paypal_bilan,v 1.23 2011/04/19 14:59:43 gilles Exp gilles $ - -use strict; -use warnings; -use Getopt::Long; -use Text::CSV_XS ; -use IO::Handle ; -use Data::Dumper ; -use Unicode::MapUTF8 qw(to_utf8 from_utf8 utf8_supported_charset); - -die unless (utf8_supported_charset('ISO-8859-1')); - -my $total_usd_received = 0 ; -my $total_usd_invoice = 0 ; -my $total_HT_EUR_exo = 0 ; -my $total_HT_EUR_ass = 0 ; -my $total_TVA_EUR = 0 ; - -my $total_eur_received = 0 ; -my $total_eur_invoice = 0 ; -my $nb_invoice = 0 ; -my $nb_invoice_refund = 0 ; - -my $debug ; -my $debug_csv ; -my $debug_dev ; -my $first_invoice = 1 ; -my $print_details = '' ; -my $bnc = ''; -my $usdeur = 1.2981 ; -my $invoices ; -my %invoice_refund ; -my $write_invoices = 0; - -my $dir_invoices = '/g/var/paypal_invoices' ; - -my $option_ret = GetOptions ( - 'debug' => \$debug, - 'debug_csv' => \$debug_csv, - 'debug_dev' => \$debug_dev, - 'first_invoice=i' => \$first_invoice, - 'print_details|details' => \$print_details, - 'bnc' => \$bnc, - 'usdeur=f' => \$usdeur, - 'invoices=s' => \$invoices, - 'write_invoices!' => \$write_invoices, -); - -my @files = @ARGV ; -my %action_of_invoice ; - -my @invoices = split( /\s+/, $invoices ) if $invoices ; - -#print "@invoices\n" ; - -foreach my $file ( @files ) { - - my @actions = parse_file( $file ) ; - - foreach my $action (@actions) { - my %action = %$action ; - #print $action->{ Nom }, "\n" ; - my( $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, - $Devise, $Montant, $Numero_davis_de_reception, $Solde, - $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe ) - = @action{ ( 'Date', 'Heure', 'Fuseau horaire', 'Nom', 'Type', 'Etat', - 'Devise', 'Montant', "Numéro d'avis de réception", 'Solde', - 'Pays', 'Nom Option 1', 'Valeur Option 1', 'Hors taxe') } ; - #print "$Nom\n" ; - my $invoice = 'NONE' ; - $Montant = $action->{ Net } if not defined $Montant; - compute_line($action, $invoice, $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, - $Devise, $Montant, $Numero_davis_de_reception, $Solde, - $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe ) ; - - # index by invoice number - $action_of_invoice{ $action->{ 'invoice' } } = $action ; - } - delete $action_of_invoice{ 'NONE' } ; -} - -@invoices = ( $first_invoice .. $first_invoice + $nb_invoice -1 ) if ( ! @invoices ) ; - -foreach my $invoice ( @invoices ) { - build_invoice( $invoice ) ; -} - - - -print "USD banque $total_usd_received\n" ; -print "USD invoice $total_usd_invoice\n" ; -my $total_eur_from_usd ; -$total_eur_from_usd = int( ( $total_usd_invoice / $usdeur ) + 0.5 ) ; # au 30 nov 2010 http://fr.finance.yahoo.com/devises/convertisseur/#from=EUR;to=USD;amt=1 -print "EUR from USD $total_eur_from_usd\n" ; -#$total_eur = int( ( $total_eur_invoice / 1.3 ) + 0.5 ) ; -#print "EUR $total_eur_from_usd\n" ; -print "EUR banque $total_eur_received\n" ; -print "EUR invoice $total_eur_invoice\n" ; - -my $total_eur = $total_eur_from_usd + $total_eur_invoice ; - -$total_HT_EUR_exo = sprintf('%2.f', $total_HT_EUR_exo) ; -$total_HT_EUR_ass = sprintf('%2.f', $total_HT_EUR_ass) ; -$total_TVA_EUR = sprintf('%2.f', $total_TVA_EUR) ; - -$total_eur = sprintf('%2.f', $total_eur) ; - -print "EUR total $total_eur\n" ; -print "EUR total HT exo $total_HT_EUR_exo\n" ; -print "EUR total HT assuj $total_HT_EUR_ass\n" ; -print "EUR total TVA $total_TVA_EUR\n" ; -print "Nb invoice $nb_invoice\n" ; -print "Nb invoice refund $nb_invoice_refund\n" ; - -print "$total_eur != $total_HT_EUR_exo + $total_HT_EUR_ass + $total_TVA_EUR\n" -if ( $total_eur != $total_HT_EUR_exo + $total_HT_EUR_ass + $total_TVA_EUR ) ; - -sub parse_one_line_io { - my $csv = shift ; - my $io = shift ; - - my $line = $csv->getline($io) ; - - return if ( $csv->eof( ) ) ; - if ( not defined( $line ) ) { - my($cde, $str, $pos) = $csv->error_diag () ; - print "[$cde] [$str] [$pos]\n" ; - - } - return( $line ) ; -} - -sub hash_and_count_dupplicate { - my @columns = @_ ; - my %columns ; - - #@columns_def{ @columns_def } = ( ) ; - foreach my $col ( @columns ) { - $columns{ $col } += 1 ; - } - $debug_csv and print "Nb columns: ", scalar( keys %columns ), " ", scalar( @columns ), "\n" ; - # debug how many time a title is defined - foreach my $col (1 .. scalar( @columns )) { - $debug_csv and print "$col | ", - deci_to_AA( $col ) , " | ", - $columns{ $columns[ $col - 1 ] }, " | ", - $columns[ $col - 1 ], "\n" ; - } - - # exit in case two columns have the same name - die "Erreur : doublons dans les titres\n" if ( scalar( keys %columns ) != scalar( @columns ) ) ; - - return( %columns ) ; -} - -sub deci_to_AA { - my $deci = shift ; - my $AA = ''; - - while ( $deci > 0 ) { - my $quot = int( ( $deci - 1 ) / 26 ) ; - my $rest = $deci - 1 - ( 26 * $quot ) ; - my $char = chr ( ord('A') + $rest ) ; - $AA = $char . $AA ; - $deci = $quot ; - } - #print "col=$AA\n" ; - return( $AA ) ; -} - -sub remove_first_blank { - my $string = shift ; - - $string =~ s/^ +// ; - return( $string ) ; - -} - -sub parse_file { - my $file = shift ; - - open my $io, "<", $file or die "$file: $!" ; - - my $csv = Text::CSV_XS->new( { - sep_char => ',', - binary => 1, - keep_meta_info => 1, - eol => $/, - } ) ; - - my $line_1 = parse_one_line_io( $csv, $io ) ; - die if ( not defined $line_1 ) ; # first line must have no problem - - my @columns_def_orig = @$line_1 ; - my @columns_def = map { remove_first_blank( $_ ) } @columns_def_orig ; - $debug_csv and print "columns_def = ", map( { "[$_]" } @columns_def ), "\n"; - - my %columns_def = hash_and_count_dupplicate( @columns_def ) ; - my $nb_columns_def = scalar @columns_def ; - - my $line_counter = 2 ; - my @actions ; - while ( 1 ) { - $debug_csv and print "ligne $line_counter ", $csv->eof( ), "\n" ; - my $line = parse_one_line_io( $csv, $io ) ; - last if ( $csv->eof( ) ) ; - if ( not defined $line ) { - print "Erreur ligne $line_counter : ", $csv->error_diag, "\n\n"; - ++$line_counter ; - next ; - } - my @columns = @$line ; - - if ( $nb_columns_def != scalar @columns ) { - print "Erreur ligne $line_counter : nombre de colonnes = ", scalar @columns, " != $nb_columns_def\n" ; - ++$line_counter ; - next ; - } - my %columns ; - @columns{ @columns_def } = @columns ; - $columns{ 'file_csv' } = $file ; - $columns{ 'line_number' } = $line_counter ; - $csv->combine( @columns ) ; - my $line_csv = $csv->string(); - $columns{ 'line_csv' } = $line_csv ; - $debug_csv and print map( { "[$_] = [" . $columns{$_} . "]\n" } - @columns_def, 'line_number', 'line_csv', 'file_csv' ), - "\n"; - ++$line_counter ; - push( @actions, \%columns ) ; - } - close( $io ); - return( reverse @actions ) ; -} - -sub compute_line { - my( $action, $invoice, $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, - $Devise, $Montant, $Numero_davis_de_reception, $Solde, - $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe_paypal ) = @_ ; - - $debug and print( "[$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n", - "[$Pays] [$Nom_Option_1] [$Valeur_Option_1]\n" ) ; - #$debug_dev and print "$Hors_taxe_paypal\n" ; - - $Montant =~ s/[^0-9-,.]//g ; - $Montant =~ s/,/./g ; - #$debug and print "MM[$Montant]\n" ; - $Hors_taxe_paypal =~ s/,/./g ; - - my $MontantEUR; - my( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) ; - if ( $bnc ) { - $MontantEUR = $Montant ; - $MontantEUR = sprintf( "%.4f", $Montant/$usdeur ) if ($Devise eq 'USD') ; - print( "\n", "=" x 60, "\n" ) ; - print( "[$Date] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [EUR $MontantEUR]\n", - "[$Pays] [$Nom_Option_1] [$Valeur_Option_1]\n" ) ; - } - - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'USD' eq $Devise - and ( 'Terminé' eq $Etat or 'Compensé' eq $Etat ) - ) { - $Montant =~tr/,/./; - #print "$Montant\n" ; - my $Montant2_usd; - $Montant2_usd = $Hors_taxe_paypal ; - $total_usd_received += $Montant ; - $total_usd_invoice += $Montant2_usd ; - ( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) = tva_line( $Devise, $Montant2_usd, $Pays, $Nom_Option_1, $Valeur_Option_1 ) ; - $total_HT_EUR_exo += $montant_HT_EUR_exo ; - $total_HT_EUR_ass += $montant_HT_EUR_ass ; - $total_TVA_EUR += $montant_TVA_EUR ; - $invoice = $first_invoice + $nb_invoice ; - $nb_invoice++ ; - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; - - } - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and ( 'Terminé' eq $Etat or 'Compensé' eq $Etat ) - ) { - $Montant =~tr/,/./; - #print "$Montant\n" ; - my $Montant2_eur; - $Montant2_eur = $Hors_taxe_paypal ; - $total_eur_received += $Montant ; - $total_eur_invoice += $Montant2_eur ; - ( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) = tva_line( $Devise, $Montant2_eur, $Pays, $Nom_Option_1, $Valeur_Option_1 ) ; - $total_HT_EUR_exo += $montant_HT_EUR_exo ; - $total_HT_EUR_ass += $montant_HT_EUR_ass ; - $total_TVA_EUR += $montant_TVA_EUR ; - $invoice = $first_invoice + $nb_invoice ; - $nb_invoice++ ; - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; - } - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and 'Remboursé' eq $Etat - ) { - $invoice = $first_invoice + $nb_invoice ; - $nb_invoice++ ; - $nb_invoice_refund++; - $invoice_refund{ $invoice }++ ; - - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; - } - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and 'Non compensé' eq $Etat - ) { - $invoice = $first_invoice + $nb_invoice ; - $nb_invoice++ ; - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; - } - - $action->{ 'invoice' } = $invoice ; - if ( $bnc ) { - my $FR_flag = '' ; - $FR_flag = ' FR' if $Pays eq 'France' ; - my $IND_flag = '' ; - $IND_flag = ' IND' if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) ; - print "FE $invoice$FR_flag$IND_flag\n" ; - print "Facture $invoice imapsync$FR_flag $Nom\n" ; - printf( "%.2f [EUR %.2f]\n", $Montant, $MontantEUR ) ; - } -} - -sub build_invoice { - my $invoice = shift ; - - return if ! $invoice ; - - my $action = $action_of_invoice{ $invoice } ; - my $refund = '' ; - $refund = 'REFUND ' if $invoice_refund{ $invoice } ; - my %action = %$action if $action ; - #print Data::Dumper->Dump( [$action] ) ; - - my( $Date, $Heure, $Nom, $Type, $Etat, $Devise, $Hors_taxe, $Commission, $Net, - $De_l_adresse_email, $A_l_adresse_email, $N_de_transaction, $Titre_de_l_objet, - $TVA, $Nom_Option_1, $Valeur_Option_1, $N_de_transaction_de_reference, - $Adresse_1, $Adresse_2_district_quartier, $Ville, - $Etat_Province, $Code_postal, $Pays, $line_number, $line_csv, $file_csv ) - = @action{ ( 'Date', 'Heure', 'Nom', 'Type', 'Etat', 'Devise', 'Hors taxe', 'Commission', 'Net', - "De l'adresse email", "A l'adresse email", 'N° de transaction', "Titre de l'objet", - 'TVA', 'Nom Option 1', 'Valeur Option 1', 'Nº de transaction de référence', - 'Adresse 1', 'Adresse 2/district/quartier', 'Ville', - 'Etat/Province/Région/Comté/Territoire/Préfecture/République', 'Code postal', 'Pays', 'line_number', 'line_csv', 'file_csv' ) } ; - - #print "$Hors_taxe $Devise\n" ; - my $Hors_taxe_num = $Hors_taxe ; - $Hors_taxe_num =~ s{,}{.} ; - if ($Hors_taxe_num > 100) { - print "invoice $invoice $Hors_taxe_num > 100\n" ; - #return() ; - } - - my ( $email_message_header, $email_message_body ) - = build_email_message( $Date, $Nom, $De_l_adresse_email, $invoice ) ; - if ( $write_invoices ) { - write_email_message( $dir_invoices, $invoice, - $email_message_header, $email_message_body, - $De_l_adresse_email) ; - write_csv_info( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) ; - } - - - - #print "==== $invoice $refund=================================================" ; - #print $email_message ; - - my( - $clientAdrA, - $clientAdrB, - $clientAdrC, - $clientAdrD, - $clientAdrE, - $clientAdrF, - ) - = build_adress( - $Nom, - $Adresse_1, - $Adresse_2_district_quartier, - $Ville, - $Code_postal, - $Etat_Province, - $Pays, - ) ; - - foreach my $str ( - $De_l_adresse_email, - $Nom, - $clientAdrA, - $clientAdrB, - $clientAdrC, - $clientAdrD, - $clientAdrE, - $clientAdrF, - ) { - $str =~ s{#}{\\#}g ; - $str =~ s{_}{\\_}g ; - $str =~ s{&}{\\&}g ; - } - - my ( $clientTypeEN, $clientTypeFR ) = client_type( $Nom_Option_1, $Valeur_Option_1 ) ; - - my ( - $priceHT, - $tvaFR, - $tvaEN, - $priceTVA, - $priceTTC, - $messageTVAFR, - $messageTVAEN, - $priceTTCusd - ) - = tva_stuff( $clientTypeEN, $Pays, $Hors_taxe, $Devise ) ; - - my ( $urlSrc, $urlExe ) = download_urls( $Date ) ; - my $tex_variables = qq{ -%% Begin input from $0 -\\providecommand{\\invoiceNumber}{$invoice} -\\providecommand{\\clientName}{$Nom} -\\providecommand{\\clientEmail}{$De_l_adresse_email} -\\providecommand{\\clientTypeEN}{$clientTypeEN} -\\providecommand{\\clientTypeFR}{$clientTypeFR} -\\providecommand{\\clientAdrA}{$clientAdrA} -\\providecommand{\\clientAdrB}{$clientAdrB} -\\providecommand{\\clientAdrC}{$clientAdrC} -\\providecommand{\\clientAdrD}{$clientAdrD} -\\providecommand{\\clientAdrE}{$clientAdrE} -\\providecommand{\\clientAdrF}{$clientAdrF} -\\providecommand{\\invoiceDate}{$Date} -\\providecommand{\\invoiceHour}{$Heure} -\\providecommand{\\priceHT}{$priceHT} -\\providecommand{\\tvaFR}{$tvaFR} -\\providecommand{\\tvaEN}{$tvaEN} -\\providecommand{\\priceTVA}{$priceTVA} -\\providecommand{\\priceTTC}{$priceTTC} -\\providecommand{\\priceTTCusd}{$priceTTCusd} -\\providecommand{\\messageTVAFR}{$messageTVAFR} -\\providecommand{\\messageTVAEN}{$messageTVAEN} -\\providecommand{\\urlSrc}{\\url{$urlSrc}} -\\providecommand{\\urlExe}{\\url{$urlExe}} -%% End input from $0 -} ; - - - #print $tex_variables ; - - write_tex_variables_file( $dir_invoices, - $invoice, $Date, $tex_variables ) if $write_invoices ; - -} - -sub build_email_message { - - my ( $date, $name, $email, $invoice ) = @_ ; - - my $message_header = qq{X-imapsync: invoice $invoice -From: Gilles LAMIRAL -Bcc: gilles\@lamiral.info -Subject: [imapsync invoice] $invoice ($date) -Disposition-Notification-To: Gilles LAMIRAL -} ; - - -my $message_body = qq{ -Hello $name, - -First I'm sorry for the delay to prepare and send you this message. - -Attached is the invoice of imapsync software you bought ($date). -The invoice file is named facture_imapsync-${invoice}.pdf -This invoice is in PDF format, ready to be print. - -If you need this invoice on paper, just ask me then -I will send it to you by postal mail. - -In order to respect the law, this numeric invoice PDF -file is signed with my private gpg key. - -The resulting gpg signature is in the file named -facture_imapsync-${invoice}.pdf.asc -also attached in this email message. - -You can verify I (Gilles LAMIRAL) really generated -this invoice with the following command line - - gpg --verify facture_imapsync-${invoice}.pdf.asc facture_imapsync-${invoice}.pdf - -or any other gpg graphical tool. - -I thank you again for buying and using imapsync. - -Any feedback is welcome. - --- -Au revoir, 09 51 84 42 42 -Gilles Lamiral. France, Baulon (35580) 06 20 79 76 06 -} ; - -my $message_body_blabla = qq{ -Here is the fingerprint of my public key -pub 1024D/FDA2B3DC 2002-05-08 - Key fingerprint = 7906 F53D 0D62 0C67 304A 4CF0 6928 869B FDA2 B3DC -uid Gilles LAMIRAL -sub 1024g/A2C4CB42 2002-05-08 - -Of course the verification doesn't prove anything until -all the following conditions are met: -- you met me, -- I agree that the fingerprint above is really mine -- I prove I'm Gilles LAMIRAL with an official paper. - -Normally we won't have to verify anything unless -I disagree with this invoice and the payment -you made for imapsync. -} ; - -return( $message_header, $message_body ) ; - -} - -sub write_csv_info { - - my( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) = @_ ; - - open( CSVINFO, "> $dir_invoices/$invoice/csv_info.txt") or die ; - print CSVINFO join( "\n", $file_csv, $line_number, $line_csv ) ; - close( CSVINFO ) ; - -} - -sub write_email_message { - my ( $dir_invoices, $invoice, $message_header, $message_body, $email_address ) = @_ ; - - my $message_body_utf8 = to_utf8({ -string => $message_body, -charset => 'ISO-8859-1' }); - - mkdir( "$dir_invoices/$invoice" ) or die if ! -d "$dir_invoices/$invoice" ; - - open( HEADER, "> $dir_invoices/$invoice/facture_message_header.txt") or die ; - print HEADER $message_header ; - close( HEADER ) ; - - open( BODY, "> $dir_invoices/$invoice/facture_message_body.txt") or die ; - print BODY $message_body_utf8 ; - close( BODY ) ; - - open( ADDRESS, "> $dir_invoices/$invoice/email_address.txt") or die ; - print ADDRESS "$email_address\n" ; - close( ADDRESS ) ; -} - - -sub write_tex_variables_file { - my ( $dir_invoices, $invoice, $date_jjSmmSaaaa, $tex_variables ) = @_ ; - - my $tex_variables_utf8 = to_utf8({ -string => $tex_variables, -charset => 'ISO-8859-1' }); - mkdir( "$dir_invoices/$invoice" ) or die if ! -d "$dir_invoices/$invoice" ; - open( FILE, "> $dir_invoices/$invoice/imapsync_var.tex") or die ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - -} - -sub download_urls { - my $date_jjSmmSaaaa = shift ; - - my $date_aaaa_mm_jj = date_aaaa_mm_jj( $date_jjSmmSaaaa ) ; - # print "$date_aaaa_mm_jj $date_jjSmmSaaaa\n" ; - my ( $urlSrc, $urlExe ) ; - - if ('2011_03_24' le $date_aaaa_mm_jj) { - $urlSrc = 'http://www.linux-france.org/prj/imapsync/paypal_return.shtml' ; - $urlExe = '' ; - return( $urlSrc, $urlExe ) ; - } - if ('2011_02_21' le $date_aaaa_mm_jj) { - $urlSrc = 'http://www.linux-france.org/depot/2011_02_21/OUMbo7/' ; - $urlExe = 'http://www.linux-france.org/depot/2011_02_21/rHSVNs/' ; - return( $urlSrc, $urlExe ) ; - } - if ('2011_01_18' le $date_aaaa_mm_jj) { - $urlSrc = 'http://www.linux-france.org/depot/2011_01_18/zPRRNt/' ; - $urlExe = 'http://www.linux-france.org/depot/2011_01_18/FO1QzG/' ; - return( $urlSrc, $urlExe ) ; - } - if ('2011_01_18' le $date_aaaa_mm_jj) { - $urlSrc = 'http://www.linux-france.org/depot/2010_11_28/SiNdlZ/' ; - $urlExe = 'http://www.linux-france.org/depot/2010_11_28/R3ZAyr/' ; - return( $urlSrc, $urlExe ) ; - } - $urlSrc = 'http://www.linux-france.org/depot/2010_11_08/X2PWMe/' ; - $urlExe = 'http://www.linux-france.org/depot/2010_11_08/ZZ7zSc/' ; - return( $urlSrc, $urlExe ) ; -} - -sub date_aaaa_mm_jj { - my $date_jjSmmSaaaa = shift ; - - if ( $date_jjSmmSaaaa =~ m{(\d\d)/(\d\d)/(\d\d\d\d)} ) { - my( $jj, $mm, $aaaa ) = ( $1, $2, $3 ) ; - return( join( '_', $aaaa, $mm, $jj ) ) ; - }else{ - return( '9999_12_31' ) ; - } -} - - -sub tva_line { - my( $Devise, $Montant2, $Pays, $Nom_Option_1, $Valeur_Option_1 ) = @_ ; - my( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) ; - - $Montant2 = $Montant2/$usdeur if 'USD' eq $Devise ; - - if ( - ( 'imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) - or - ( 'France' eq $Pays ) - ) { - $montant_HT_EUR_exo = 0 ; - $montant_HT_EUR_ass = $Montant2 / 1.196 ; - $montant_TVA_EUR = $Montant2 / 1.196 * 0.196 ; - $debug_dev and print "$Montant2 $Pays $Valeur_Option_1\n" ; - }else{ - $montant_HT_EUR_exo = $Montant2 ; - $montant_HT_EUR_ass = 0 ; - $montant_TVA_EUR = 0 ; - } - return( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) ; -} - - - -sub tva_stuff { - my( $clientTypeEN, $Pays, $Hors_taxe, $Devise ) = @_ ; - - my $priceTTCusd = '' ; - $Hors_taxe =~ s{,}{.} ; - - if ( $Devise eq 'USD' ) { - $priceTTCusd = "(USD $Hors_taxe)" ; - $Hors_taxe = ( $Hors_taxe/$usdeur ) ; - } - - my ( - $priceHT, - $tvaFR, - $tvaEN, - $priceTVA, - $priceTTC, - $messageTVAFR, - $messageTVAEN, - ) ; - - if ( ( 'individual' eq $clientTypeEN) - or - ( 'France' eq $Pays ) - ) { - $priceHT = sprintf('%2.2f', $Hors_taxe/1.196) ; - $tvaFR = '19,60\%'; - $tvaEN = ''; - $priceTVA = sprintf('%2.2f', $Hors_taxe/1.196*0.196) ; - $priceTTC = sprintf('%2.2f', $Hors_taxe) ; - $messageTVAFR = ''; - $messageTVAEN = ''; - }else{ - $priceHT = sprintf('%2.2f', $Hors_taxe) ; - $tvaFR = 'néant'; - $tvaEN = '(none)'; - $priceTVA = 0 ; - $priceTTC = $priceHT; - $messageTVAFR = 'Exonération de TVA, article 259 B-1 du Code Général des Impôts'; - $messageTVAEN = '(VAT tax-exempt, article 259 B-1 French General Tax Code)'; - } - foreach my $price ( $priceHT, $priceTVA, $priceTTC, $priceTTCusd ) { - #print "[$price]\n" ; - $price =~ s{\.}{, } ; - } - return( - $priceHT, - $tvaFR, - $tvaEN, - $priceTVA, - $priceTTC, - $messageTVAFR, - $messageTVAEN, - $priceTTCusd - ) ; -} - -sub client_type { - my ( $Nom_Option_1, $Valeur_Option_1 ) = @_ ; - - my ( $clientTypeEN, $clientTypeFR ) = ( 'professional', 'professionnel' ) ; - - if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) { - $clientTypeEN = 'individual' ; - $clientTypeFR = 'individuel' ; - }elsif ('imapsync usage' eq $Nom_Option_1 and 'professional' eq $Valeur_Option_1 ) { - $clientTypeEN = 'professional' ; - $clientTypeFR = 'professionnel' ; - } - - return( $clientTypeEN, $clientTypeFR ) ; -} - -sub build_adress { - my( - $Nom, - $Adresse_1, - $Adresse_2_district_quartier, - $Ville, - $Code_postal, - $Etat_Province, - $Pays, - ) = @_ ; - - my $addr = " -=========================================================== -Nom $Nom -Adresse_1 $Adresse_1 -Adresse_2_district_quartier $Adresse_2_district_quartier -Ville Code_postal $Ville $Code_postal -Etat_Province $Etat_Province -Pays $Pays -" ; - #print $addr ; - - my @address ; - $Nom = '' if ( $Nom =~ m/^\s+$/ ) ; - push( @address, $Nom ) if $Nom ; - push( @address, $Adresse_1 ) if $Adresse_1 ; - push( @address, $Adresse_2_district_quartier ) if $Adresse_2_district_quartier ; - push( @address, "$Ville $Code_postal" ) if ( $Ville or $Code_postal ); - push( @address, $Etat_Province ) if $Etat_Province ; - push( @address, $Pays, ) if $Pays ; - - - my $clientAdrA = shift( @address ) || '' ; - my $clientAdrB = shift( @address ) || '' ; - my $clientAdrC = shift( @address ) || '' ; - my $clientAdrD = shift( @address ) || '' ; - my $clientAdrE = shift( @address ) || '' ; - my $clientAdrF = shift( @address ) || '' ; - -$addr = " -[$clientAdrA] -[$clientAdrB] -[$clientAdrC] -[$clientAdrD] -[$clientAdrE] -[$clientAdrF] -"; - #print $addr ; - - return( - $clientAdrA, - $clientAdrB, - $clientAdrC, - $clientAdrD, - $clientAdrE, - $clientAdrF, - ) ; -} diff --git a/paypal_reply/paypal_bilan_1.22 b/paypal_reply/paypal_bilan_1.22 deleted file mode 100755 index b0a9070..0000000 --- a/paypal_reply/paypal_bilan_1.22 +++ /dev/null @@ -1,756 +0,0 @@ -#!/usr/bin/perl - -# $Id: paypal_bilan,v 1.22 2011/04/19 12:52:27 gilles Exp gilles $ - -use strict; -use warnings; -use Getopt::Long; -use Text::CSV_XS ; -use IO::Handle ; -use Data::Dumper ; -use Unicode::MapUTF8 qw(to_utf8 from_utf8 utf8_supported_charset); - -die unless (utf8_supported_charset('ISO-8859-1')); - -my $total_usd_received = 0 ; -my $total_usd_invoice = 0 ; - -my $total_eur_received = 0 ; -my $total_eur_invoice = 0 ; -my $nb_invoice = 0 ; -my $nb_invoice_refund = 0 ; - -my $debug ; -my $debug_csv ; -my $debug_dev ; -my $first_invoice = 1 ; -my $print_details = '' ; -my $bnc = ''; -my $usdeur = 1.2981 ; -my $invoices ; -my %invoice_refund ; -my $write_invoices = 0; - -my $dir_invoices = '/g/var/paypal_invoices' ; - -my $option_ret = GetOptions ( - 'debug' => \$debug, - 'debug_csv' => \$debug_csv, - 'debug_dev' => \$debug_dev, - 'first_invoice=i' => \$first_invoice, - 'print_details|details' => \$print_details, - 'bnc' => \$bnc, - 'usdeur=f' => \$usdeur, - 'invoices=s' => \$invoices, - 'write_invoices!' => \$write_invoices, -); - -my @files = @ARGV ; -my %action_of_invoice ; - -my @invoices = split( /\s+/, $invoices ) if $invoices ; - -#print "@invoices\n" ; - -foreach my $file ( @files ) { - - my @actions = parse_file( $file ) ; - - foreach my $action (@actions) { - my %action = %$action ; - #print $action->{ Nom }, "\n" ; - my( $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, - $Devise, $Montant, $Numero_davis_de_reception, $Solde, - $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe ) - = @action{ ( 'Date', 'Heure', 'Fuseau horaire', 'Nom', 'Type', 'Etat', - 'Devise', 'Montant', "Numéro d'avis de réception", 'Solde', - 'Pays', 'Nom Option 1', 'Valeur Option 1', 'Hors taxe') } ; - #print "$Nom\n" ; - my $invoice = 'NONE' ; - $Montant = $action->{ Net } if not defined $Montant; - compute_line($action, $invoice, $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, - $Devise, $Montant, $Numero_davis_de_reception, $Solde, - $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe ) ; - - # index by invoice number - $action_of_invoice{ $action->{ 'invoice' } } = $action ; - } - delete $action_of_invoice{ 'NONE' } ; -} - -@invoices = ( $first_invoice .. $first_invoice + $nb_invoice -1 ) if ( ! @invoices ) ; - -foreach my $invoice ( @invoices ) { - build_invoice( $invoice ) ; -} - - - -print "USD banque $total_usd_received\n" ; -print "USD invoice $total_usd_invoice\n" ; -my $total_eur_from_usd ; -$total_eur_from_usd = int( ( $total_usd_invoice / $usdeur ) + 0.5 ) ; # au 30 nov 2010 http://fr.finance.yahoo.com/devises/convertisseur/#from=EUR;to=USD;amt=1 -print "EUR from USD $total_eur_from_usd\n" ; -#$total_eur = int( ( $total_eur_invoice / 1.3 ) + 0.5 ) ; -#print "EUR $total_eur_from_usd\n" ; -print "EUR banque $total_eur_received\n" ; -print "EUR invoice $total_eur_invoice\n" ; - -my $total_eur = $total_eur_from_usd + $total_eur_invoice ; -print "EUR total $total_eur\n" ; -print "Nb invoice $nb_invoice\n" ; -print "Nb invoice refund $nb_invoice_refund\n" ; - - -sub parse_one_line_io { - my $csv = shift ; - my $io = shift ; - - my $line = $csv->getline($io) ; - - return if ( $csv->eof( ) ) ; - if ( not defined( $line ) ) { - my($cde, $str, $pos) = $csv->error_diag () ; - print "[$cde] [$str] [$pos]\n" ; - - } - return( $line ) ; -} - -sub hash_and_count_dupplicate { - my @columns = @_ ; - my %columns ; - - #@columns_def{ @columns_def } = ( ) ; - foreach my $col ( @columns ) { - $columns{ $col } += 1 ; - } - $debug_csv and print "Nb columns: ", scalar( keys %columns ), " ", scalar( @columns ), "\n" ; - # debug how many time a title is defined - foreach my $col (1 .. scalar( @columns )) { - $debug_csv and print "$col | ", - deci_to_AA( $col ) , " | ", - $columns{ $columns[ $col - 1 ] }, " | ", - $columns[ $col - 1 ], "\n" ; - } - - # exit in case two columns have the same name - die "Erreur : doublons dans les titres\n" if ( scalar( keys %columns ) != scalar( @columns ) ) ; - - return( %columns ) ; -} - -sub deci_to_AA { - my $deci = shift ; - my $AA = ''; - - while ( $deci > 0 ) { - my $quot = int( ( $deci - 1 ) / 26 ) ; - my $rest = $deci - 1 - ( 26 * $quot ) ; - my $char = chr ( ord('A') + $rest ) ; - $AA = $char . $AA ; - $deci = $quot ; - } - #print "col=$AA\n" ; - return( $AA ) ; -} - -sub remove_first_blank { - my $string = shift ; - - $string =~ s/^ +// ; - return( $string ) ; - -} - -sub parse_file { - my $file = shift ; - - open my $io, "<", $file or die "$file: $!" ; - - my $csv = Text::CSV_XS->new( { - sep_char => ',', - binary => 1, - keep_meta_info => 1, - eol => $/, - } ) ; - - my $line_1 = parse_one_line_io( $csv, $io ) ; - die if ( not defined $line_1 ) ; # first line must have no problem - - my @columns_def_orig = @$line_1 ; - my @columns_def = map { remove_first_blank( $_ ) } @columns_def_orig ; - $debug_csv and print "columns_def = ", map( { "[$_]" } @columns_def ), "\n"; - - my %columns_def = hash_and_count_dupplicate( @columns_def ) ; - my $nb_columns_def = scalar @columns_def ; - - my $line_counter = 2 ; - my @actions ; - while ( 1 ) { - $debug_csv and print "ligne $line_counter ", $csv->eof( ), "\n" ; - my $line = parse_one_line_io( $csv, $io ) ; - last if ( $csv->eof( ) ) ; - if ( not defined $line ) { - print "Erreur ligne $line_counter : ", $csv->error_diag, "\n\n"; - ++$line_counter ; - next ; - } - my @columns = @$line ; - - if ( $nb_columns_def != scalar @columns ) { - print "Erreur ligne $line_counter : nombre de colonnes = ", scalar @columns, " != $nb_columns_def\n" ; - ++$line_counter ; - next ; - } - my %columns ; - @columns{ @columns_def } = @columns ; - $columns{ 'file_csv' } = $file ; - $columns{ 'line_number' } = $line_counter ; - $csv->combine( @columns ) ; - my $line_csv = $csv->string(); - $columns{ 'line_csv' } = $line_csv ; - $debug_csv and print map( { "[$_] = [" . $columns{$_} . "]\n" } - @columns_def, 'line_number', 'line_csv', 'file_csv' ), - "\n"; - ++$line_counter ; - push( @actions, \%columns ) ; - } - close( $io ); - return( reverse @actions ) ; -} - -sub compute_line { - my( $action, $invoice, $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, - $Devise, $Montant, $Numero_davis_de_reception, $Solde, - $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe_paypal ) = @_ ; - - $debug and print( "[$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n", - "[$Pays] [$Nom_Option_1] [$Valeur_Option_1]\n" ) ; - #$debug_dev and print "$Hors_taxe_paypal\n" ; - - $Montant =~ s/[^0-9-,.]//g ; - $Montant =~ s/,/./g ; - #$debug and print "MM[$Montant]\n" ; - $Hors_taxe_paypal =~ s/,/./g ; - - my $MontantEUR; - if ( $bnc ) { - $MontantEUR = $Montant ; - $MontantEUR = sprintf( "%.4f", $Montant/$usdeur ) if ($Devise eq 'USD') ; - print( "\n", "=" x 60, "\n" ) ; - print( "[$Date] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [EUR $MontantEUR]\n", - "[$Pays] [$Nom_Option_1] [$Valeur_Option_1]\n" ) ; - } - - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'USD' eq $Devise - and 'Terminé' eq $Etat - ) { - $Montant =~tr/,/./; - #print "$Montant\n" ; - my $Montant2_usd; - $Montant2_usd = $Hors_taxe_paypal ; - $total_usd_received += $Montant ; - $total_usd_invoice += $Montant2_usd ; - $invoice = $first_invoice + $nb_invoice ; - $nb_invoice++ ; - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; - - } - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'USD' eq $Devise - and 'Compensé' eq $Etat - ) { - $Montant =~tr/,/./; - #print "$Montant\n" ; - my $Montant2_usd; - $Montant2_usd = $Hors_taxe_paypal ; - $total_usd_received += $Montant ; - $total_usd_invoice += $Montant2_usd ; - $invoice = $first_invoice + $nb_invoice ; - $nb_invoice++ ; - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; - } - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and 'Terminé' eq $Etat - ) { - $Montant =~tr/,/./; - #print "$Montant\n" ; - my $Montant2_eur; - $Montant2_eur = $Hors_taxe_paypal ; - $total_eur_received += $Montant ; - $total_eur_invoice += $Montant2_eur ; - $invoice = $first_invoice + $nb_invoice ; - $nb_invoice++ ; - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; - } - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and 'Remboursé' eq $Etat - ) { - $invoice = $first_invoice + $nb_invoice ; - $nb_invoice++ ; - $nb_invoice_refund++; - $invoice_refund{ $invoice }++ ; - - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; - } - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and 'Compensé' eq $Etat - ) { - $Montant =~tr/,/./; - #print "$Montant\n" ; - my $Montant2_eur; - $Montant2_eur = 21.99 if ( 20.88 == $Montant or 20.99 == $Montant ) ; - $Montant2_eur = 30 if ( 28.58 == $Montant or 28.73 == $Montant ) ; - $Montant2_eur = 110 if ( 105.46 == $Montant ) ; - #print "$Montant $Montant2_eur\n" ; - $total_eur_received += $Montant ; - $total_eur_invoice += $Montant2_eur ; - $invoice = $first_invoice + $nb_invoice ; - $nb_invoice++ ; - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; - } - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and 'Non compensé' eq $Etat - ) { - $invoice = $first_invoice + $nb_invoice ; - $nb_invoice++ ; - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; - } - - $action->{ 'invoice' } = $invoice ; - if ( $bnc ) { - my $FR_flag = '' ; - $FR_flag = ' FR' if $Pays eq 'France' ; - my $IND_flag = '' ; - $IND_flag = ' IND' if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) ; - print "FE $invoice$FR_flag$IND_flag\n" ; - print "Facture $invoice imapsync$FR_flag $Nom\n" ; - printf( "%.2f [EUR %.2f]\n", $Montant, $MontantEUR ) ; - } -} - -sub build_invoice { - my $invoice = shift ; - - return if ! $invoice ; - - my $action = $action_of_invoice{ $invoice } ; - my $refund = '' ; - $refund = 'REFUND ' if $invoice_refund{ $invoice } ; - my %action = %$action if $action ; - #print Data::Dumper->Dump( [$action] ) ; - - my( $Date, $Heure, $Nom, $Type, $Etat, $Devise, $Hors_taxe, $Commission, $Net, - $De_l_adresse_email, $A_l_adresse_email, $N_de_transaction, $Titre_de_l_objet, - $TVA, $Nom_Option_1, $Valeur_Option_1, $N_de_transaction_de_reference, - $Adresse_1, $Adresse_2_district_quartier, $Ville, - $Etat_Province, $Code_postal, $Pays, $line_number, $line_csv, $file_csv ) - = @action{ ( 'Date', 'Heure', 'Nom', 'Type', 'Etat', 'Devise', 'Hors taxe', 'Commission', 'Net', - "De l'adresse email", "A l'adresse email", 'N° de transaction', "Titre de l'objet", - 'TVA', 'Nom Option 1', 'Valeur Option 1', 'Nº de transaction de référence', - 'Adresse 1', 'Adresse 2/district/quartier', 'Ville', - 'Etat/Province/Région/Comté/Territoire/Préfecture/République', 'Code postal', 'Pays', 'line_number', 'line_csv', 'file_csv' ) } ; - - #print "$Hors_taxe $Devise\n" ; - my $Hors_taxe_num = $Hors_taxe ; - $Hors_taxe_num =~ s{,}{.} ; - if ($Hors_taxe_num > 100) { - print "invoice $invoice $Hors_taxe_num > 100\n" ; - #return() ; - } - - my ( $email_message_header, $email_message_body ) - = build_email_message( $Date, $Nom, $De_l_adresse_email, $invoice ) ; - if ( $write_invoices ) { - write_email_message( $dir_invoices, $invoice, - $email_message_header, $email_message_body, - $De_l_adresse_email) ; - write_csv_info( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) ; - } - - - - #print "==== $invoice $refund=================================================" ; - #print $email_message ; - - my( - $clientAdrA, - $clientAdrB, - $clientAdrC, - $clientAdrD, - $clientAdrE, - $clientAdrF, - ) - = build_adress( - $Nom, - $Adresse_1, - $Adresse_2_district_quartier, - $Ville, - $Code_postal, - $Etat_Province, - $Pays, - ) ; - - foreach my $str ( - $De_l_adresse_email, - $Nom, - $clientAdrA, - $clientAdrB, - $clientAdrC, - $clientAdrD, - $clientAdrE, - $clientAdrF, - ) { - $str =~ s{#}{\\#}g ; - $str =~ s{_}{\\_}g ; - $str =~ s{&}{\\&}g ; - } - - my ( $clientTypeEN, $clientTypeFR ) = client_type( $Nom_Option_1, $Valeur_Option_1 ) ; - - my ( - $priceHT, - $tvaFR, - $tvaEN, - $priceTVA, - $priceTTC, - $messageTVAFR, - $messageTVAEN, - $priceTTCusd - ) - = tva_stuff( $clientTypeEN, $Pays, $Hors_taxe, $Devise ) ; - - my ( $urlSrc, $urlExe ) = download_urls( $Date ) ; - my $tex_variables = qq{ -%% Begin input from $0 -\\providecommand{\\invoiceNumber}{$invoice} -\\providecommand{\\clientName}{$Nom} -\\providecommand{\\clientEmail}{$De_l_adresse_email} -\\providecommand{\\clientTypeEN}{$clientTypeEN} -\\providecommand{\\clientTypeFR}{$clientTypeFR} -\\providecommand{\\clientAdrA}{$clientAdrA} -\\providecommand{\\clientAdrB}{$clientAdrB} -\\providecommand{\\clientAdrC}{$clientAdrC} -\\providecommand{\\clientAdrD}{$clientAdrD} -\\providecommand{\\clientAdrE}{$clientAdrE} -\\providecommand{\\clientAdrF}{$clientAdrF} -\\providecommand{\\invoiceDate}{$Date} -\\providecommand{\\invoiceHour}{$Heure} -\\providecommand{\\priceHT}{$priceHT} -\\providecommand{\\tvaFR}{$tvaFR} -\\providecommand{\\tvaEN}{$tvaEN} -\\providecommand{\\priceTVA}{$priceTVA} -\\providecommand{\\priceTTC}{$priceTTC} -\\providecommand{\\priceTTCusd}{$priceTTCusd} -\\providecommand{\\messageTVAFR}{$messageTVAFR} -\\providecommand{\\messageTVAEN}{$messageTVAEN} -\\providecommand{\\urlSrc}{\\url{$urlSrc}} -\\providecommand{\\urlExe}{\\url{$urlExe}} -%% End input from $0 -} ; - - - #print $tex_variables ; - - write_tex_variables_file( $dir_invoices, - $invoice, $Date, $tex_variables ) if $write_invoices ; - -} - -sub build_email_message { - - my ( $date, $name, $email, $invoice ) = @_ ; - - my $message_header = qq{X-imapsync: invoice $invoice -From: Gilles LAMIRAL -Bcc: gilles\@lamiral.info -Subject: [imapsync invoice] $invoice ($date) -Disposition-Notification-To: Gilles LAMIRAL -} ; - - -my $message_body = qq{ -Hello $name, - -First I'm sorry for the delay to prepare and send you this message. - -Attached is the invoice of imapsync software you bought ($date). -The invoice file is named facture_imapsync-${invoice}.pdf -This invoice is in PDF format, ready to be print. - -If you need this invoice on paper, just ask me then -I will send it to you by postal mail. - -In order to respect the law, this numeric invoice PDF -file is signed with my private gpg key. - -The resulting gpg signature is in the file named -facture_imapsync-${invoice}.pdf.asc -also attached in this email message. - -You can verify I (Gilles LAMIRAL) really generated -this invoice with the following command line - - gpg --verify facture_imapsync-${invoice}.pdf.asc facture_imapsync-${invoice}.pdf - -or any other gpg graphical tool. - -I thank you again for buying and using imapsync. - -Any feedback is welcome. - --- -Au revoir, 09 51 84 42 42 -Gilles Lamiral. France, Baulon (35580) 06 20 79 76 06 -} ; - -my $message_body_blabla = qq{ -Here is the fingerprint of my public key -pub 1024D/FDA2B3DC 2002-05-08 - Key fingerprint = 7906 F53D 0D62 0C67 304A 4CF0 6928 869B FDA2 B3DC -uid Gilles LAMIRAL -sub 1024g/A2C4CB42 2002-05-08 - -Of course the verification doesn't prove anything until -all the following conditions are met: -- you met me, -- I agree that the fingerprint above is really mine -- I prove I'm Gilles LAMIRAL with an official paper. - -Normally we won't have to verify anything unless -I disagree with this invoice and the payment -you made for imapsync. -} ; - -return( $message_header, $message_body ) ; - -} - -sub write_csv_info { - - my( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) = @_ ; - - open( CSVINFO, "> $dir_invoices/$invoice/csv_info.txt") or die ; - print CSVINFO join( "\n", $file_csv, $line_number, $line_csv ) ; - close( CSVINFO ) ; - -} - -sub write_email_message { - my ( $dir_invoices, $invoice, $message_header, $message_body, $email_address ) = @_ ; - - my $message_body_utf8 = to_utf8({ -string => $message_body, -charset => 'ISO-8859-1' }); - - mkdir( "$dir_invoices/$invoice" ) or die if ! -d "$dir_invoices/$invoice" ; - - open( HEADER, "> $dir_invoices/$invoice/facture_message_header.txt") or die ; - print HEADER $message_header ; - close( HEADER ) ; - - open( BODY, "> $dir_invoices/$invoice/facture_message_body.txt") or die ; - print BODY $message_body_utf8 ; - close( BODY ) ; - - open( ADDRESS, "> $dir_invoices/$invoice/email_address.txt") or die ; - print ADDRESS "$email_address\n" ; - close( ADDRESS ) ; -} - - -sub write_tex_variables_file { - my ( $dir_invoices, $invoice, $date_jjSmmSaaaa, $tex_variables ) = @_ ; - - my $tex_variables_utf8 = to_utf8({ -string => $tex_variables, -charset => 'ISO-8859-1' }); - mkdir( "$dir_invoices/$invoice" ) or die if ! -d "$dir_invoices/$invoice" ; - open( FILE, "> $dir_invoices/$invoice/imapsync_var.tex") or die ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - -} - -sub download_urls { - my $date_jjSmmSaaaa = shift ; - - my $date_aaaa_mm_jj = date_aaaa_mm_jj( $date_jjSmmSaaaa ) ; - # print "$date_aaaa_mm_jj $date_jjSmmSaaaa\n" ; - my ( $urlSrc, $urlExe ) ; - - if ('2011_03_24' le $date_aaaa_mm_jj) { - $urlSrc = 'http://www.linux-france.org/prj/imapsync/paypal_return.shtml' ; - $urlExe = '' ; - return( $urlSrc, $urlExe ) ; - } - if ('2011_02_21' le $date_aaaa_mm_jj) { - $urlSrc = 'http://www.linux-france.org/depot/2011_02_21/OUMbo7/' ; - $urlExe = 'http://www.linux-france.org/depot/2011_02_21/rHSVNs/' ; - return( $urlSrc, $urlExe ) ; - } - if ('2011_01_18' le $date_aaaa_mm_jj) { - $urlSrc = 'http://www.linux-france.org/depot/2011_01_18/zPRRNt/' ; - $urlExe = 'http://www.linux-france.org/depot/2011_01_18/FO1QzG/' ; - return( $urlSrc, $urlExe ) ; - } - if ('2011_01_18' le $date_aaaa_mm_jj) { - $urlSrc = 'http://www.linux-france.org/depot/2010_11_28/SiNdlZ/' ; - $urlExe = 'http://www.linux-france.org/depot/2010_11_28/R3ZAyr/' ; - return( $urlSrc, $urlExe ) ; - } - $urlSrc = 'http://www.linux-france.org/depot/2010_11_08/X2PWMe/' ; - $urlExe = 'http://www.linux-france.org/depot/2010_11_08/ZZ7zSc/' ; - return( $urlSrc, $urlExe ) ; -} - -sub date_aaaa_mm_jj { - my $date_jjSmmSaaaa = shift ; - - if ( $date_jjSmmSaaaa =~ m{(\d\d)/(\d\d)/(\d\d\d\d)} ) { - my( $jj, $mm, $aaaa ) = ( $1, $2, $3 ) ; - return( join( '_', $aaaa, $mm, $jj ) ) ; - }else{ - return( '9999_12_31' ) ; - } -} - -sub tva_stuff { - my( $clientTypeEN, $Pays, $Hors_taxe, $Devise ) = @_ ; - - my $priceTTCusd = '' ; - $Hors_taxe =~ s{,}{.} ; - - if ( $Devise eq 'USD' ) { - $priceTTCusd = "(USD $Hors_taxe)" ; - $Hors_taxe = ( $Hors_taxe/$usdeur ) ; - } - - my ( - $priceHT, - $tvaFR, - $tvaEN, - $priceTVA, - $priceTTC, - $messageTVAFR, - $messageTVAEN, - ) ; - - if ( ( 'individual' eq $clientTypeEN) - or - ( 'France' eq $Pays ) - ) { - $priceHT = sprintf('%2.2f', $Hors_taxe/1.196) ; - $tvaFR = '19,60\%'; - $tvaEN = ''; - $priceTVA = sprintf('%2.2f', $Hors_taxe/1.196*0.196) ; - $priceTTC = sprintf('%2.2f', $Hors_taxe) ; - $messageTVAFR = ''; - $messageTVAEN = ''; - }else{ - $priceHT = sprintf('%2.2f', $Hors_taxe) ; - $tvaFR = 'néant'; - $tvaEN = '(none)'; - $priceTVA = 0 ; - $priceTTC = $priceHT; - $messageTVAFR = 'Exonération de TVA, article 259 B-1 du Code Général des Impôts'; - $messageTVAEN = '(VAT tax-exempt, article 259 B-1 French General Tax Code)'; - } - foreach my $price ( $priceHT, $priceTVA, $priceTTC, $priceTTCusd ) { - #print "[$price]\n" ; - $price =~ s{\.}{, } ; - } - return( - $priceHT, - $tvaFR, - $tvaEN, - $priceTVA, - $priceTTC, - $messageTVAFR, - $messageTVAEN, - $priceTTCusd - ) ; -} - -sub client_type { - my ( $Nom_Option_1, $Valeur_Option_1 ) = @_ ; - - my ( $clientTypeEN, $clientTypeFR ) = ( 'professional', 'professionnel' ) ; - - if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) { - $clientTypeEN = 'individual' ; - $clientTypeFR = 'individuel' ; - }elsif ('imapsync usage' eq $Nom_Option_1 and 'professional' eq $Valeur_Option_1 ) { - $clientTypeEN = 'professional' ; - $clientTypeFR = 'professionnel' ; - } - - return( $clientTypeEN, $clientTypeFR ) ; -} - -sub build_adress { - my( - $Nom, - $Adresse_1, - $Adresse_2_district_quartier, - $Ville, - $Code_postal, - $Etat_Province, - $Pays, - ) = @_ ; - - my $addr = " -=========================================================== -Nom $Nom -Adresse_1 $Adresse_1 -Adresse_2_district_quartier $Adresse_2_district_quartier -Ville Code_postal $Ville $Code_postal -Etat_Province $Etat_Province -Pays $Pays -" ; - #print $addr ; - - my @address ; - $Nom = '' if ( $Nom =~ m/^\s+$/ ) ; - push( @address, $Nom ) if $Nom ; - push( @address, $Adresse_1 ) if $Adresse_1 ; - push( @address, $Adresse_2_district_quartier ) if $Adresse_2_district_quartier ; - push( @address, "$Ville $Code_postal" ) if ( $Ville or $Code_postal ); - push( @address, $Etat_Province ) if $Etat_Province ; - push( @address, $Pays, ) if $Pays ; - - - my $clientAdrA = shift( @address ) || '' ; - my $clientAdrB = shift( @address ) || '' ; - my $clientAdrC = shift( @address ) || '' ; - my $clientAdrD = shift( @address ) || '' ; - my $clientAdrE = shift( @address ) || '' ; - my $clientAdrF = shift( @address ) || '' ; - -$addr = " -[$clientAdrA] -[$clientAdrB] -[$clientAdrC] -[$clientAdrD] -[$clientAdrE] -[$clientAdrF] -"; - #print $addr ; - - return( - $clientAdrA, - $clientAdrB, - $clientAdrC, - $clientAdrD, - $clientAdrE, - $clientAdrF, - ) ; -} diff --git a/paypal_reply/paypal_build_invoices b/paypal_reply/paypal_build_invoices deleted file mode 100644 index 98faf5c..0000000 --- a/paypal_reply/paypal_build_invoices +++ /dev/null @@ -1,83 +0,0 @@ -#!/bin/sh - -# usage: sh paypal_build_invoices/g/var/paypal_invoices/??? - -cp /home/gilles/public_html/AGIL/factures/000/facture_imapsync-000.tex /g/var/paypal_invoices/ - -set -x -/g/public_html/imapsync/paypal_reply/paypal_bilan --write_invoices --first_in 147 /g/paypal/paypal_2010_11_complet.csv -/g/public_html/imapsync/paypal_reply/paypal_bilan --write_invoices --first_in 214 /g/paypal/paypal_2010_12_complet.csv -/g/public_html/imapsync/paypal_reply/paypal_bilan --write_invoices --first_in 294 /g/paypal/paypal_2011_01_complet.csv -/g/public_html/imapsync/paypal_reply/paypal_bilan --write_invoices --first_in 382 /g/paypal/paypal_2011_02_complet.csv -/g/public_html/imapsync/paypal_reply/paypal_bilan --write_invoices --first_in 473 /g/paypal/paypal_2011_03_complet.csv -set +x - -# USD de 147 à 340 -# EUR de 341 à ... - -# 20110413 Found problems with 189 199 249 258 263 359 537 -# 20110412 Found problems with 189 199 242 249 258 263 359 382 537 -# cen cen JAP cen cen cen cen TCH JAP -# cen -# 155 TVA 1,89 -# 171 TVA 4,42 -# 220 TVA 3,16 -# 225 TVA 3,16 -# 236 TVA 4,42 -# 298 TVA 3,16 -# 307 TVA 4,42 -# 312 TVA 4,42 -# 324 TVA 4,42 -# 351 TVA 4,92 -# 395 TVA 4,92 -# 408 TVA 4,92 -# 419 TVA 4,92 -# 432 TVA 4,92 -# 435 TVA 4,92 -# 452 TVA 4,92 -# 460 TVA 4,92 -# 461 TVA 4,92 -# 463 TVA 4,92 -# 464 TVA 4,92 -# 475 TVA 4,92 -# 487 TVA 4,92 -# 489 TVA 4,92 -# 502 TVA 4,92 -# 504 TVA 4,92 -# 511 TVA 4,92 -# 522 TVA 4,92 -# 523 TVA 4,92 -# 533 TVA 4,92 -# 537 TVA 4,92 -# 540 TVA 4,92 -# 543 TVA 4,92 -# 549 TVA 4,92 -# 551 TVA 4,92 -# 552 TVA 4,92 -# 556 TVA 4,92 -# 563 TVA 4,92 - -for d in "$@"; do - echo "==== $d ====" - cd $d - bd=`basename $d` - ln -f ../facture_imapsync-000.tex facture_imapsync-$bd.tex; - if ! pdflatex facture_imapsync-$bd.tex < /dev/null > /dev/null; then - echo "PB $bd" - if test -f facture_imapsync-${bd}_good.tex \ - && pdflatex facture_imapsync-${bd}_good.tex < /dev/null > /dev/null - then - ln -f facture_imapsync-${bd}_good.pdf facture_imapsync-$bd.pdf - echo "PB $bd solved with manual facture_imapsync-${bd}_good.tex" - PB_LIST_MANUAL="$PB_LIST_MANUAL $bd" - else - PB_LIST="$PB_LIST $bd" - rm -f facture_imapsync-$bd.pdf - continue - fi - fi - gpg --use-agent --armor --detach-sign --yes facture_imapsync-$bd.pdf -done - -echo "Found problems with $PB_LIST" -echo "Manual invoices for $PB_LIST_MANUAL" diff --git a/paypal_reply/paypal_build_reply b/paypal_reply/paypal_build_reply deleted file mode 100755 index f112439..0000000 --- a/paypal_reply/paypal_build_reply +++ /dev/null @@ -1,160 +0,0 @@ -#!/usr/bin/perl - -# $Id: paypal_build_reply,v 1.12 2011/03/23 18:31:52 gilles Exp gilles $ - -use warnings; -use strict; -use Getopt::Long; - -my ($msg_id_file, $msg_id); -my ($amount, $name, $email); -my ( - $paypal_line, $paypal_info, - $buyer, $description, - $url_source, $url_exe, $url, $release, -); - -my $help ; -my $debug ; - -my $numopt = scalar(@ARGV); -my $opt_ret = GetOptions( - "help" => \$help, - "debug!" => \$debug, -); - -usage() and exit if ($help or ! $numopt) ; - -$msg_id_file = $ARGV[1]; -$msg_id = firstline($msg_id_file); - -$debug and print "Hi!\n" ; - -while(<>) { - next if ( ! /^(.*Num.+ro de transaction.*)$/ ); - $paypal_line = $1; - $paypal_info = "===== Paypal id =====\n$paypal_line\n"; - $debug and print "$paypal_info" ; - last; -} -while(<>) { - if ( /^Vous avez re.*paiement d'un montant de (.*) de la part de (.*) \((.*)\)/) { - ($amount, $name, $email) = ($1, $2, $3); - last; - } - if ( /^Vous avez re.*paiement d'un montant de (.*) de la part de (.*)/) { - ($amount, $name, $email) = ($1, "", $2); - last; - } -} -$url_source = firstline('/g/var/paypal_reply/url_source'); -$url_exe = firstline('/g/var/paypal_reply/url_exe'); -$release = firstline('/g/var/paypal_reply/url_release'); - -#print "[$amount] [$name] [$email] [$paypal_line]\n"; - - -while(<>) { - if ( /^Acheteur/ ) { - $buyer .= "===== Acheteur =====\n"; - last; - } - if ( /^Informations sur l'acheteur/ ) { - $buyer .= "===== Acheteur =====\n"; - chomp( $name = <> ); - $buyer .= "$name\n" ; - last; - } -} - -while(<>) { - $buyer .= $_ if ( ! /^-----------------------------------/ ); - last if ( /^-----------------------------------/ ); -} - - -while(<>) { - next if ( ! /^Description :(.*)/ ); - $description = "===== Details =====\n"; - $description .= $_; - last; -} - -while(<>) { - $debug and print "LINE:$_" ; - $description .= $_; - last if ( /^Paiement envoy/ ); - last if ( /^N.*d'avis de r.*ception/ ); -} - - -my $address = 'gilles.lamiral@laposte.net'; -my $address2 = 'gilles@lamiral.info'; -my $rcstag = '$Id: paypal_build_reply,v 1.12 2011/03/23 18:31:52 gilles Exp gilles $'; - -my $message = < -To: <$email> -Bcc: Gilles LAMIRAL <$address>, <$address2> -Subject: [imapsync download] imapsync release $release [$email] - -Hello $name, - -You will find the latest imapsync source code release $release at the following link: -$url_source - -You will find the latest imapsync.exe binary release $release at the following link: -$url_exe - -You will receive an invoice soon. - -Next imapsync releases will be available for one year without extra payment. -Just keep this message and ask for the new links. -(I will build an automatic subscription tool later) - -I thank you for buying and using imapsync, -I wish you successful transfers! - -$paypal_info -$buyer -$description -==== Vendeur ==== -Gilles LAMIRAL -4 La Billais -35580 Baulon -FRANCE - -Tel: +33 951 84 42 42 -Mob: +33 620 79 76 06 -Fax: +33 956 84 42 42 - -email: $address - --- -Au revoir, 09 51 84 42 42 -Gilles Lamiral. France, Baulon (35580) 06 20 79 76 06 -EOM -; - -=pod -=cut - - -print $message; -#print "[$amount] [$name] [$email] [$paypal_line]\n"; - - -sub firstline { - # extract the first line of a file (without \n) - - my($file) = @_; - my $line = ""; - - open FILE, $file or die("error [$file]: $! "); - chomp($line = ); - close FILE; - $line = ($line) ? $line: "error !EMPTY! [$file]"; - return $line; -} diff --git a/paypal_reply/paypal_functions b/paypal_reply/paypal_functions deleted file mode 100755 index fd2c6ec..0000000 --- a/paypal_reply/paypal_functions +++ /dev/null @@ -1,227 +0,0 @@ -#!/bin/sh - -# $Id: paypal_functions,v 1.15 2011/03/23 19:10:56 gilles Exp gilles $ - -paypal_prerequisites() { - perl -mMIME::Lite -e '' || echo 'sudo aptitude install libmime-lite-perl' - perl -mMIME::Parser -e '' || echo 'sudo aptitude install libmime-tools-perl' - perl -mUnicode::MapUTF8 -e '' || echo 'sudo aptitude install libunicode-maputf8-perl' -} - -paypal_init_laposte() { - user=gilles.lamiral - passfile=/g/var/pass/secret.gilles_laposte - host=imap.laposte.net - tmpdir=/g/var/paypal_reply - folder=INBOX -} - -paypal_init_petite() { - user=gilles@est.belle - passfile=/g/var/pass/secret.gilles_mbox - host=p - tmpdir=/g/var/paypal_reply - folder='INBOX.03_imapsync.imapsync_paypal' -} - -paypal_init_petite_INBOX() { - user=gilles@est.belle - passfile=/g/var/pass/secret.gilles_mbox - host=p - tmpdir=/g/var/paypal_reply - folder='INBOX' -} - - -paypal_init_petite_dev() { - user=gilles@est.belle - passfile=/g/var/pass/secret.gilles_mbox - host=p - tmpdir=/g/var/paypal_reply_dev - folder='INBOX.03_imapsync.imapsync_paypal_dev' -} - - -get_mail() { - # creation des répertoires - mkdir -p $tmpdir/msg_in/ - mkdir -p $tmpdir/msg_id/ - ( - cd $tmpdir/msg_in/ - # recuperation des messages de la boite sans destruction des messages - # transférés - paypal_imapget --host $host --user $user --passfile $passfile \ - --folder $folder - ) -} - -get_mail_PP1470() { - # creation des répertoires - mkdir -p $tmpdir/msg_in/ - mkdir -p $tmpdir/msg_id/ - ( - cd $tmpdir/msg_in/ - # recuperation des messages de la boite sans destruction des messages - # transférés - paypal_imapget --host $host --user $user --passfile $passfile \ - --folder $folder --search TEXT --search PP1470 - ) -} - - -extract_mail() { - mkdir -p $tmpdir/msg_out/ - test -z "`ls $tmpdir/msg_in/`" && echo no mail && return - ( - cd $tmpdir/msg_out/ - test -z "`ls .`" || rm -rf *_d - paypal_mimeexplode ../msg_in/* - ) - #ls -d $tmpdir/msg_out/ -} - - -convert_utf8() { - mkdir -p $tmpdir/msg_out_utf8/ - test -z "`ls $tmpdir/msg_out/`" && echo no mail && return - for f in $tmpdir/msg_out/*_d/*.txt; do - b=`basename "$f"` - d=`dirname "$f"` - bd=`basename "$d"` - d_utf8="$tmpdir/msg_out_utf8/$bd" - f_utf8="$d_utf8/$b" - test -d "$d_utf8" && continue - mkdir "$d_utf8" - if file "$f" | grep -i UTF-8 > /dev/null - then - echo copying "$f" to "$f_utf8" - cp "$f" "$f_utf8" - else - echo converting "$f" to "$f_utf8" - 8859_utf8 "$f" > "$f_utf8" - fi - done -} - - -troncate_last_2_chars() { - length=`expr length "$1"` - length_2=`expr $length - 2` - expr substr "$1" 1 $length_2 - -} - -build_reply() { - mkdir -p $tmpdir/msg_reply/ - for f in $tmpdir/msg_out_utf8/*/*.txt; do - #echo "$f" - d=`dirname "$f"` - bd=`basename "$d"` - file_id=`troncate_last_2_chars $bd` - d_reply="$tmpdir/msg_reply/$file_id" - test -f "$d_reply/$file_id.txt" && continue - mkdir -p "$d_reply" - echo building "$d_reply/$file_id.txt" - paypal_build_reply "$f" "$tmpdir/msg_id/$file_id" > "$d_reply/$file_id.txt" - done -} - -build_reply_arg() { - for f in "$@"; do - #echo "$f" - d=`dirname "$f"` - bd=`basename "$d"` - file_id=`troncate_last_2_chars $bd` - d_reply="$tmpdir/msg_reply/$file_id" - echo building "$d_reply/$file_id.txt" - echo paypal_build_reply "$f" "$tmpdir/msg_id/$file_id" - paypal_build_reply "$f" "$tmpdir/msg_id/$file_id" - done -} - - -send_reply() { - mkdir -p $tmpdir/msg_sent/ - for f in $tmpdir/msg_reply/*/*.txt; do - b=`basename "$f"` - d=`dirname "$f"` - bd=`basename "$d"` - d_sent="$tmpdir/msg_sent/$bd" - test -f "$d_sent/$b" && continue - mkdir -p "$d_sent" - test X"--send" = X"$1" && paypal_send --send "$f" && touch "$d_sent/$b" - #test X"--send" = X"$1" && touch "$d_sent/$b" - test X"" = X"$1" && paypal_send "$f" - done - mailq -} - -paypal_all() { - paypal_prerequisites - echo "Will get messages in $tmpdir/msg_in/" - get_mail - get_mail_PP1470 - echo "Done get messages in $tmpdir/msg_in/" - echo "Will extract_mail in $tmpdir/msg_out/" - extract_mail - echo "Done extract_mail in $tmpdir/msg_out/" - echo "Will converting to utf8 in $tmpdir/msg_out_utf8/" - convert_utf8 - echo "Done converting to utf8 in $tmpdir/msg_out_utf8/" - echo "Will build_reply in $tmpdir/msg_reply/" - build_reply - echo "Done build_reply in $tmpdir/msg_reply/" - echo "Will send_reply $@" - send_reply "$@" - echo "Done send_reply $@" -} - -#echo 'paypal_reply_petite' -paypal_reply_petite() { - echo "Doing paypal_reply_petite" - echo paypal_init_petite - paypal_init_petite - paypal_all "$@" - echo paypal_init_petite_INBOX - paypal_init_petite_INBOX - paypal_all "$@" - echo "Done paypal_reply_petite" -} - -#echo 'paypal_reply_laposte' -paypal_reply_laposte() { - echo "Doing paypal_reply_laposte" - echo paypal_init_laposte - paypal_init_laposte - paypal_all "$@" - echo "Done paypal_reply_laposte" -} - -paypal_all_dev() { - paypal_prerequisites - echo "Will get messages in $tmpdir/msg_in/" - get_mail_PP1470 - echo "Done get messages in $tmpdir/msg_in/" - echo "Will extract_mail in $tmpdir/msg_out/" - extract_mail - echo "Done extract_mail in $tmpdir/msg_out/" - echo "Will converting to utf8 in $tmpdir/msg_out_utf8/" - convert_utf8 - echo "Done converting to utf8 in $tmpdir/msg_out_utf8/" - echo "Will build_reply in $tmpdir/msg_reply/" - build_reply - echo "Done build_reply in $tmpdir/msg_reply/" - echo "Will send_reply $@" - send_reply "$@" - echo "Done send_reply $@" -} - - -paypal_reply_petite_dev() { - echo "Doing paypal_reply_petite_dev" - echo paypal_init_petite_dev - paypal_init_petite_dev - paypal_all_dev "$@" - echo "Done paypal_reply_petite_dev" -} - diff --git a/paypal_reply/paypal_imapget b/paypal_reply/paypal_imapget deleted file mode 100755 index ac56213..0000000 --- a/paypal_reply/paypal_imapget +++ /dev/null @@ -1,134 +0,0 @@ -#!/usr/bin/perl -w - -# $Id: paypal_imapget,v 1.7 2011/03/23 17:05:24 gilles Exp gilles $ - -use Getopt::Long; -use Mail::IMAPClient; -use FileHandle; - - -my $host; -my $port = 143; -my $debugimap = 0; -my $debug = 0; -my $user; -my $password; -my $passfile; -my $folder = 'INBOX'; -my @search ; -my $help; - -my $numopt = scalar(@ARGV); -my $opt_ret = GetOptions( - "host=s" => \$host, - "user=s" => \$user, - "password=s" => \$password, - "passfile=s" => \$passfile, - "folder=s" => \$folder, - "search=s" => \@search, - "help" => \$help, - "delete!" => \$delete, - "expunge!" => \$expunge, - "debugimap!" => \$debugimap, - "debug!" => \$debug, -); -usage() and exit if ($help or ! $numopt) ; - -$password = (defined($passfile)) ? firstline ($passfile) : $password; - -my $imap = Mail::IMAPClient->new(); - -$imap->Server($host); -$imap->Port($port); -$imap->Uid(1); -$imap->Peek(1); -$imap->Debug($debugimap); -$imap->connect() - or die "Can not open imap connection on [$host] with user [$user] : $@\n"; -$imap->User($user); -$imap->Password($password); -$imap->login() or die "Error login : [$host] with user [$user] : $@"; - -$imap->select($folder) or die "Error select folder [$folder] host [$host] user [$user] : $@"; - -#my @uids = $imap->search('HEADER', 'SUBJECT',"=?windows-1252?Q?Avis_de_r=E9ception_d=27un_paiement?="); -#my @uids = $imap->search('HEADER', 'Sender','sendmail@paypal.com'); -#my @uids = $imap->search('TEXT', 'PP341'); -print "@search\n" ; -@search = ('TEXT', 'PP341') if not @search ; -my @uids = $imap->search('HEADER', 'Sender','sendmail@paypal.com', @search ); -print "Search: [@uids]\n"; - -foreach $msg (@uids) { - my $msg_id = $imap->get_header( $msg, "Message-Id" ); - $debug and print "$msg_id\n"; - my $msg_code = format_msg_id($msg_id); - my $file = "$msg_code"; - if (-f $msg_code and -f "../msg_id/$msg_code") { - $debug and print "Already have $msg_code $msg\n"; - next; - } - print "writing message $msg to $file\n"; - unlink($file); - if ($imap->message_to_file($file, $msg)) { - $imap->delete_message($msg) if $delete; - $imap->expunge() if $expunge; - }else{ - print "Error writing $file: $@\n"; - } - write_to_file("../msg_id/$msg_code", $msg_id); -} - -$imap->logout(); - - -sub usage { - print < : imap server. Mandatory. ---user : user to login. Mandatory. ---password : password for the user1. Mandatory. ---delete : mark messages well dumped as deleted ---expunge : expunge folder. - -Example: -$0 \\ - --host imap.troc.org --user foo --password secret -EOF -} - -sub firstline { - # extract the first line of a file (without \n) - - my($file) = @_; - my $line = ""; - - open FILE, $file or die("error [$file]: $! "); - chomp($line = ); - close FILE; - $line = ($line) ? $line: "error !EMPTY! [$file]"; - return $line; -} - -sub format_msg_id { - my $msg_id = shift; - - $msg_id =~ tr/a-zA-Z0-9/_/cs; - $debug and print "$msg_id\n"; - return($msg_id); -} - -sub write_to_file { - my $file = shift; - my $string = shift; - - $fh = FileHandle->new("> $file"); - if (defined $fh) { - print $fh $string; - $fh->close; - } -} diff --git a/paypal_reply/paypal_mimeexplode b/paypal_reply/paypal_mimeexplode deleted file mode 100755 index afba608..0000000 --- a/paypal_reply/paypal_mimeexplode +++ /dev/null @@ -1,187 +0,0 @@ -#!/usr/bin/perl -w - -# $Id: paypal_mimeexplode,v 1.1 2010/11/23 01:26:24 gilles Exp gilles $ - -=head1 NAME - -mimeexplode - explode one or more MIME messages - -=head1 SYNOPSIS - - mimeexplode ... - - someprocess | mimeexplode - - -=head1 DESCRIPTION - -Takes one or more files from the command line that contain MIME -messages, and explodes their contents out into subdirectories -of the current working directory. The subdirectories are -just called C, C, C, etc. Existing directories are -skipped over. - -The message information is output to the stdout, like this: - - Message: msg3 (inputfile1.msg) - Part: msg3/filename-1.dat (text/plain) - Part: msg3/filename-2.dat (text/plain) - Message: msg5 (input-file2.msg) - Part: msg5/dir.gif (image/gif) - Part: msg5/face.jpg (image/jpeg) - Message: msg6 (infile3) - Part: msg6/filename-1.dat (text/plain) - -This was written as an example of the MIME:: modules in the -MIME-parser package I wrote. It may prove useful as a quick-and-dirty -way of splitting a MIME message if you need to decode something, and -you don't have a MIME mail reader on hand. - -=head1 COMMAND LINE OPTIONS - -None yet. - -=head1 AUTHOR - -Eryq C, in a big hurry... - -=cut - -BEGIN { unshift @INC, ".." } # to test MIME:: stuff before installing it! - -require 5.001; -use strict; -use Getopt::Long; -use vars qw($Msgno); - -use MIME::Parser; -use Getopt::Std; -use File::Basename; - - -my $numopt = scalar(@ARGV); -my $help; -my $debug; - -my $opt_ret = GetOptions( - "help" => \$help, - "debug!" => \$debug, -); -usage() and exit if ($help or ! $numopt) ; - - -sub usage { - print <parts; - - if (@parts) { # multipart... - map { dump_entity($_) } @parts; - } - else { # single part... - $debug and print " Part: ", $ent->bodyhandle->path, - " (", scalar($ent->head->mime_type), ")\n"; - } -} - -#------------------------------------------------------------ -# main -#------------------------------------------------------------ -sub main { - my $file; - my $entity; - - # Sanity: - (-w ".") or die "cwd not writable, you naughty boy..."; - - # Go through messages: - @ARGV or unshift @ARGV, "-"; - while (defined($file = shift @ARGV)) { - - my $msgdir = make_msg_dir($file); - next if not $msgdir; - $debug and print "Message: $msgdir ($file)\n"; - - # Create a new parser object: - my $parser = new MIME::Parser; - ### $parser->parse_nested_messages('REPLACE'); - - # Optional: set up parameters that will affect how it extracts - # documents from the input stream: - $parser->output_dir($msgdir); - - # Parse an input stream: - open FILE, $file or die "couldn't open $file"; - $entity = $parser->read(\*FILE) or - print STDERR "Couldn't parse MIME in $file; continuing...\n"; - close FILE; - - # Congratulations: you now have a (possibly multipart) MIME entity! - dump_entity($entity) if $entity; - ### $entity->dump_skeleton if $entity; - } - 1; -} - -exit (&main ? 0 : -1); -#------------------------------------------------------------ -1; - - - - - - diff --git a/paypal_reply/paypal_run_dev b/paypal_reply/paypal_run_dev deleted file mode 100755 index 1303460..0000000 --- a/paypal_reply/paypal_run_dev +++ /dev/null @@ -1,30 +0,0 @@ -#!/bin/sh - -# $Id: paypal_run_dev,v 1.4 2011/03/23 19:08:30 gilles Exp gilles $ - -set -e -#set -x - - -# Add path to commands at home -PATH=$PATH:/g/public_html/imapsync/paypal_reply -PERL5LIB=/g/public_html/imapsync/Mail-IMAPClient-3.28/lib -export PERL5LIB - -test -f /g/public_html/imapsync/paypal_reply/paypal_functions \ -&& . /g/public_html/imapsync/paypal_reply/paypal_functions - - -DATE_1=`date` - -echo "==== paypal_reply_test ====" -paypal_reply_petite_dev "$@" -echo - - - -DATE_2=`date` - -echo "Debut : $DATE_1" -echo "Fin : $DATE_2" -echo "Yo Bery GOOD !" diff --git a/paypal_reply/paypal_run_laposte b/paypal_reply/paypal_run_laposte deleted file mode 100755 index 1831206..0000000 --- a/paypal_reply/paypal_run_laposte +++ /dev/null @@ -1,30 +0,0 @@ -#!/bin/sh - -# $Id: paypal_run_laposte,v 1.3 2011/03/23 17:02:39 gilles Exp $ - -set -e -#set -x - - -# Add path to commands at home -PATH=$PATH:/g/public_html/imapsync/paypal_reply -PERL5LIB=/g/public_html/imapsync/Mail-IMAPClient-3.28/lib -export PERL5LIB - -test -f /g/public_html/imapsync/paypal_reply/paypal_functions \ -&& . /g/public_html/imapsync/paypal_reply/paypal_functions - - -DATE_1=`date` - -echo "==== paypal_reply_laposte ====" -paypal_reply_laposte "$@" -echo - - - -DATE_2=`date` - -echo "Debut : $DATE_1" -echo "Fin : $DATE_2" -echo "Yo Bery GOOD !" diff --git a/paypal_reply/paypal_run_petite b/paypal_reply/paypal_run_petite deleted file mode 100755 index 5ed89d0..0000000 --- a/paypal_reply/paypal_run_petite +++ /dev/null @@ -1,30 +0,0 @@ -#!/bin/sh - -# $Id: paypal_run_petite,v 1.5 2011/03/23 17:02:39 gilles Exp $ - -set -e -#set -x - - -# Add path to commands at home -PATH=$PATH:/g/public_html/imapsync/paypal_reply -PERL5LIB=/g/public_html/imapsync/Mail-IMAPClient-3.28/lib -export PERL5LIB - -test -f /g/public_html/imapsync/paypal_reply/paypal_functions \ -&& . /g/public_html/imapsync/paypal_reply/paypal_functions - - -DATE_1=`date` - -echo "==== paypal_reply_petite ====" -paypal_reply_petite "$@" -echo - - - -DATE_2=`date` - -echo "Debut : $DATE_1" -echo "Fin : $DATE_2" -echo "Yo Bery GOOD !" diff --git a/paypal_reply/paypal_send b/paypal_reply/paypal_send deleted file mode 100755 index 185ca40..0000000 --- a/paypal_reply/paypal_send +++ /dev/null @@ -1,71 +0,0 @@ -#!/usr/bin/perl - -# $Id: paypal_send,v 1.3 2010/12/29 23:50:24 gilles Exp gilles $ - -use strict; -use warnings; -use Getopt::Long; -use MIME::Lite; - -my ( - $help, - $debug, - $send, -); - -my $numopt = scalar(@ARGV); -my $opt_ret = GetOptions( - "help" => \$help, - "debug!" => \$debug, - "send!" => \$send, -); - -usage() and exit if ($help or ! $numopt or ! $opt_ret) ; - -my @reply = <>; -my %header; - -while (my $line = shift @reply) { - #print $line; - chomp($line); - last if ($line =~ /^$/) ; - my($blank, $key, $value) = split /^(.+?:)\s*/, $line; - #print "[$key] [$value]\n"; - $header{$key} = $value; -} - -my $data = join('', @reply); - -#print "[", $data, "]\n"; - -my $message = MIME::Lite->new(); -$message->attr("content-type" => "text/plain"); -$message->attr("content-type.charset" => "UTF-8"); - -$message->build(%header); -$message->build(Data => $data); -$message->print(\*STDOUT); - - -if ($send) { - $message->send; - print "Sent to ", $header{'To:'},"\n"; -} - - - -sub usage { - print < facture_message_to.txt - egrep '^To: ' facture_message_header.txt > /dev/null || echo "To: $email" > facture_message_to.txt - cat facture_message_header.txt facture_message_to.txt facture_message_body.txt > facture_message.txt - more facture_message.txt - - echo '====== END of message ======' - test -f "SENT_TO_$email" && { echo "Already SENT_TO_$email"; } - test -f "SENT_TO_$email" || acroread facture_imapsync-${invoice}.pdf& - echo "Send this invoice ${invoice} to $email?" - read r < /dev/tty - echo SAID "[$r]" - test X"$r" = Xy && { - echo | mutt -H facture_message.txt -a facture_imapsync-${invoice}.pdf facture_imapsync-${invoice}.pdf.asc -- - touch SENT_TO_$email - } -} - -for d in "$@"; do - send_invoice "$d" -done diff --git a/paypal_return.shtml b/paypal_return.shtml index b3b049b..3bae177 100644 --- a/paypal_return.shtml +++ b/paypal_return.shtml @@ -5,7 +5,7 @@ imapsync download - + @@ -46,12 +46,12 @@ You may log into your account at www.paypal.com to view details of this transaction.

    -

    You will find the latest imapsync source code release 1.404 at the following link:
    -    http://www.linux-france.org/depot/2011_02_21/OUMbo7/ +

    You will find the latest imapsync source code release 1.417 at the following link:
    +http://www.linux-france.org/depot/2011_05_07/8qkE2L/

    -

    You will find the latest imapsync.exe binary release 1.404 at the following link:
    -http://www.linux-france.org/depot/2011_02_21/rHSVNs/ +

    You will find the latest imapsync.exe binary release 1.417 at the following link:
    +http://www.linux-france.org/depot/2011_05_07/eQ5bXu/

    You will receive an invoice soon.

    @@ -82,7 +82,7 @@ gilles.lamiral@laposte.net

    This document last modified on
    -($Id: paypal_return.shtml,v 1.2 2011/03/24 01:21:27 gilles Exp gilles $) +($Id: paypal_return.shtml,v 1.5 2011/05/07 02:56:35 gilles Exp gilles $)

    diff --git a/t/01_connect b/t/01_connect deleted file mode 100755 index 25bda46..0000000 --- a/t/01_connect +++ /dev/null @@ -1,15 +0,0 @@ -#!/usr/bin/perl -w - -use Carp; -use Mail::IMAPClient; - -$imap = Mail::IMAPClient->new(Debug => 1); -$imap->Debug(1); -$imap->Server('louloutte.dyndns.org'); -$imap->connect() or croak "Error connecting @!"; -$imap->User('MarkOv@est.belle'); -$imap->Password('emhj91ly'); -$imap->login(); -$imap->logout(); - - diff --git a/t/01_connect.229.dump b/t/01_connect.229.dump deleted file mode 100644 index 503bc92..0000000 --- a/t/01_connect.229.dump +++ /dev/null @@ -1,16 +0,0 @@ -Using Mail::IMAPClient version 2.2.9 and perl version 5.8.8 (5.008008) -Read: * OK [CAPABILITY IMAP4rev1 UIDPLUS CHILDREN NAMESPACE THREAD=ORDEREDSUBJECT THREAD=REFERENCES SORT QUOTA AUTH=PLAIN CRAM-MD5 CRAM-SHA1 IDLE STARTTLS] Courier-IMAP ready. Copyright 1998-2005 Double Precision, Inc. See COPYING for distribution information. - -Connect: Received this from readline: 0/OUTPUT/* OK [CAPABILITY IMAP4rev1 UIDPLUS CHILDREN NAMESPACE THREAD=ORDEREDSUBJECT THREAD=REFERENCES SORT QUOTA AUTH=PLAIN CRAM-MD5 CRAM-SHA1 IDLE STARTTLS] Courier-IMAP ready. Copyright 1998-2005 Double Precision, Inc. See COPYING for distribution information. - -Sending: 1 Login "XXXXXXXX" XXXXXXXX - -Sent 37 bytes -Read: 1 OK LOGIN Ok. - -Sending: 2 LOGOUT - -Sent 10 bytes -Read: * BYE Courier-IMAP server shutting down -2 OK LOGOUT completed - diff --git a/t/02_append_string b/t/02_append_string deleted file mode 100755 index d470fe9..0000000 --- a/t/02_append_string +++ /dev/null @@ -1,35 +0,0 @@ -#!/usr/bin/perl -w - -use Carp; -use Mail::IMAPClient; - -$imap = Mail::IMAPClient->new(); -$imap->Debug(0); -$imap->Server('louloutte.dyndns.org'); -$imap->connect() or croak "Error connecting $@ !"; -$imap->User('MarkOv@est.belle'); -$imap->Password('emhj91ly'); -$imap->login() or croak "Error login $@ !"; - -$imap->Uid(1) or croak "Error Uid $@ !"; - -print "[", $imap->folders, "]\n"; - -$imap->select('Inbox') or croak "Could not select: $@ !"; -my @messages = $imap->messages or croak "Could not get message list: $@ !"; -print "[@messages]\n"; -$message = $messages[1]; -print "[$message]\n"; -my $string = $imap->message_string($message); -print $string; - -#my $uid = $imap->append_string('INBOX.Trash', $string, '\Seen', "30-Oct-2006 01:34:14 +0100") -# or croak "Could not append_string: $@\n"; -my $uid = $imap->append_string('INBOX.Trash', "$string", '\Seen', "") - or croak "Could not append_string: $@\n"; - -print "$uid\n"; - -$imap->logout(); - - diff --git a/t/03_message_to_file b/t/03_message_to_file deleted file mode 100755 index 7be09bf..0000000 --- a/t/03_message_to_file +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/perl -w - -use Carp; -use Mail::IMAPClient; -use strict; - -my $imap1 = Mail::IMAPClient->new(); -$imap1->Debug(0); -$imap1->Server('louloutte.dyndns.org'); -$imap1->connect() or croak "Error connecting $@ !"; -$imap1->User('MarkOv@est.belle'); -$imap1->Password('emhj91ly'); -$imap1->login() or croak "Error login $@ !"; -$imap1->Uid(1) or croak "Error Uid $@ !"; - -my $imap2 = Mail::IMAPClient->new(); -$imap2->Debug(0); -$imap2->Server('louloutte.dyndns.org'); -$imap2->connect() or croak "Error connecting $@ !"; -$imap2->User('MarkOv@est.belle'); -$imap2->User('titi@est.belle'); -$imap2->Password('HUwtEd'); -$imap2->login() or croak "Error login $@ !"; -$imap2->Uid(1) or croak "Error Uid $@ !"; - - - -print "[", $imap1->folders, "]\n"; - -$imap1->select('Inbox') or croak "Could not select: $@ !"; -$imap2->select('Inbox') or croak "Could not select: $@ !"; - -my @msg_id_2 = $imap2->messages; -my $msg_id_2 = $msg_id_2[1]; -my $msg_id_1 = ($imap1->messages)[0]; -print "msg_id_1: $msg_id_1\n"; - -my $string_2 = $imap2->message_string($msg_id_2); -print $string_2; - -my $message_file_1 = "tmp_message_to_file_${$}_1"; -my $message_file_2 = "tmp_message_to_file_${$}_2"; -unlink($message_file_1); -unlink($message_file_2); - -$imap2->message_to_file($message_file_2, $msg_id_2) or croak "Could not message_to_file"; -$imap1->message_to_file($message_file_1, $msg_id_1) or croak "Could not message_to_file"; - - -$imap1->logout(); -$imap2->logout(); - - diff --git a/t/03_message_to_file.dump b/t/03_message_to_file.dump deleted file mode 100644 index b01e3ee..0000000 --- a/t/03_message_to_file.dump +++ /dev/null @@ -1,91 +0,0 @@ -$RCSfile: imapsync,v $ $Revision: 1.244 $ $Date: 2008/02/29 22:43:22 $ -Here is a [linux] system (Linux plume 2.6.20.3 #1 Sun Mar 25 06:07:36 CEST 2007 i686) -with perl 5.8.8 and the module Mail::IMAPClient version used here is 3.05 -Command line used : -./imapsync --host1 localhost --user1 tata@est.belle --passfile1 /var/tmp/secret.tata --host2 localhost --user2 titi@est.belle --passfile2 /var/tmp/secret.titi --folder INBOX.Trash --syncinternaldates -will try to use CRAM-MD5 authentication on host1 -will try to use CRAM-MD5 authentication on host2 -From imap server [localhost] port [143] user [tata@est.belle] -To imap server [localhost] port [143] user [titi@est.belle] -Banner : * OK [CAPABILITY IMAP4rev1 UIDPLUS CHILDREN NAMESPACE THREAD=ORDEREDSUBJECT THREAD=REFERENCES SORT QUOTA AUTH=PLAIN CRAM-MD5 CRAM-SHA1 IDLE STARTTLS] Courier-IMAP ready. Copyright 1998-2005 Double Precision, Inc. See COPYING for distribution information. -Host localhost says it has CAPABILITY for AUTHENTICATE CRAM-MD5 -Success login on [localhost] with user [tata@est.belle] auth [CRAM-MD5] -Banner : * OK [CAPABILITY IMAP4rev1 UIDPLUS CHILDREN NAMESPACE THREAD=ORDEREDSUBJECT THREAD=REFERENCES SORT QUOTA AUTH=PLAIN CRAM-MD5 CRAM-SHA1 IDLE STARTTLS] Courier-IMAP ready. Copyright 1998-2005 Double Precision, Inc. See COPYING for distribution information. -Host localhost says it has CAPABILITY for AUTHENTICATE CRAM-MD5 -Success login on [localhost] with user [titi@est.belle] auth [CRAM-MD5] -From capability : QUOTA STARTTLS NAMESPACE CRAM-SHA1 IDLE AUTH=PLAIN THREAD=ORDEREDSUBJECT SORT UIDPLUS CHILDREN CRAM-MD5 IMAP4REV1 THREAD=REFERENCES -To capability : QUOTA STARTTLS NAMESPACE CRAM-SHA1 IDLE AUTH=PLAIN THREAD=ORDEREDSUBJECT SORT UIDPLUS CHILDREN CRAM-MD5 IMAP4REV1 THREAD=REFERENCES -From state Authenticated -To state Authenticated -From separator and prefix : [.][INBOX.] -To separator and prefix : [.][INBOX.] -++++ Calculating sizes ++++ -From Folder [INBOX.Trash] Size: 1012 Messages: 1 -Total size: 1012 -Total messages: 1 -Time : 1 s -++++ Calculating sizes ++++ -To Folder [INBOX.Trash] Size: 0 Messages: 0 -Total size: 0 -Total messages: 0 -Time : 0 s -++++ Listing folders ++++ -From folders list : [INBOX.Trash] -To folders list : [INBOX.Trash] -++++ Looping on each folder ++++ -From Folder [INBOX.Trash] -To Folder [INBOX.Trash] -++++ From [INBOX.Trash] Parse 1 ++++ -++++ To [INBOX.Trash] Parse 1 ++++ -++++ Verifying [INBOX.Trash] -> [INBOX.Trash] ++++ -+ NO msg #2319 [1c8g+RBA0iMRz+/+c3pqXw:1012] in INBOX.Trash -+ Copying msg #2319:1012 to folder INBOX.Trash -AAAmessage_string[FCC: imap://tata%40est.belle@localhost/INBOX/Sent -X-Identity-Key: id2 -Message-ID: <45454886.2030307@localhost> -Date: Mon, 30 Oct 2006 01:34:14 +0100 -From: TATA -X-Mozilla-Draft-Info: internal/draft; vcard=0; receipt=0; uuencode=0 -User-Agent: Thunderbird 1.5.0.4 (X11/20060722) -MIME-Version: 1.0 -To: Gilles Lamiral -Subject: Re: test:ophaifaibequahdu -References: <20030821153335.86EB6FCA2@louloutte.dyndns.org> -In-Reply-To: <20030821153335.86EB6FCA2@louloutte.dyndns.org> -Content-Type: text/html; charset=ISO-8859-1 -Content-Transfer-Encoding: 7bit - - - - - - - -Gilles Lamiral wrote: -
    - 
    test:ophaifaibequahdu
-
-
    -
    -
    - - - -]ZZZ -AAA1[]ZZZ -flags from : [\Seen]["30-Oct-2006 01:34:14 +0100"] -Time : 0 s -++++ Statistics ++++ -Time : 2 sec -Messages transferred : 0 -Messages skipped : 0 -Total bytes transferred: 0 -Total bytes skipped : 0 -Total bytes error : 1012 -Detected 1 errors -Please, rate imapsync at http://freshmeat.net/projects/imapsync/ -?Happy with this free, open source and gratis GPL software? -Feel free to thank the author by giving him a book: -http://www.amazon.com/gp/registry/wishlist/1C9UNDIH3P7R7/ -(or its paypal account gilles.lamiral@laposte.net) diff --git a/t/04_parse_headers b/t/04_parse_headers deleted file mode 100755 index 0280a65..0000000 --- a/t/04_parse_headers +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/perl -w - -use Carp; -use Mail::IMAPClient; - -$imap = Mail::IMAPClient->new(Debug => 1); -$imap->Debug(1); -$imap->Server('louloutte.dyndns.org'); -$imap->connect() or croak "Error connecting @!"; -$imap->User('MarkOv@est.belle'); -$imap->Password('emhj91ly'); -$imap->login(); - -$imap->select('Inbox'); -my @messages = $imap->messages(); - -my $headers = $imap->parse_headers([@messages]); - -$imap->logout(); - - diff --git a/t/05_parse_headers_ssl b/t/05_parse_headers_ssl deleted file mode 100755 index bf761ed..0000000 --- a/t/05_parse_headers_ssl +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/perl -w - -use Carp; -use Mail::IMAPClient; -use IO::Socket::SSL; - -my $ssl = new IO::Socket::SSL("louloutte.dyndns.org:993"); - -my $imap = Mail::IMAPClient->new(); -$imap->Socket($ssl); - -$imap->Debug(1); -$imap->Server('louloutte.dyndns.org'); -$imap->connect() or croak "Error connecting @!"; -$imap->User('MarkOv@est.belle'); -$imap->Password('emhj91ly'); -$imap->login(); - -$imap->select('Inbox'); -my @messages = $imap->messages(); - -my $headers = $imap->parse_headers([@messages]); - -$imap->logout(); - - diff --git a/t/06_parse_headers_ssl_titi b/t/06_parse_headers_ssl_titi deleted file mode 100755 index 4ec32de..0000000 --- a/t/06_parse_headers_ssl_titi +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/perl -w - -use Carp; -use Mail::IMAPClient; -use IO::Socket::SSL; - -my $ssl = new IO::Socket::SSL("louloutte.dyndns.org:993"); - -my $imap = Mail::IMAPClient->new(); -$imap->Socket($ssl); - -$imap->Debug(1); -$imap->Server('louloutte.dyndns.org'); -$imap->connect() or croak "Error connecting @!"; -$imap->User('titi@est.belle'); -$imap->Password('HUwtEd'); -$imap->login(); - -$imap->select('Inbox'); -my @messages = $imap->messages(); - -my $headers = $imap->parse_headers([@messages]); - -$imap->logout(); - - diff --git a/tests.sh b/tests.sh index 0a17242..67b9528 100644 --- a/tests.sh +++ b/tests.sh @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: tests.sh,v 1.159 2011/04/20 01:18:40 gilles Exp gilles $ +# $Id: tests.sh,v 1.163 2011/05/09 00:10:16 gilles Exp gilles $ # Example 1: # CMD_PERL='perl -I./Mail-IMAPClient-3.25/lib' sh -x tests.sh @@ -257,6 +257,18 @@ ll_folder_create() { --justfolders } +ll_folder_create_INBOX_Inbox() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --folder INBOX --regextrans2 's/INBOX/Inbox/' \ + --justfolders +} + + + ll_oneemail() { $CMD_PERL ./imapsync \ @@ -449,12 +461,9 @@ ll_nosyncinternaldates() { # 2.xx noidate: Sending: 62 APPEND INBOX {428} ll_idatefromheader() { - if can_send; then - #echo3 Here is plume - sendtestmessage - else - : - fi + + can_send && sendtestmessage + $CMD_PERL ./imapsync \ --host1 $HOST1 --user1 tata \ --passfile1 ../../var/pass/secret.tata \ @@ -520,23 +529,58 @@ ll_dev_reconnect() # : <<'EOF' while :; do - killall -u vmail imapd; + killall -v -u vmail imapd; RAND_WAIT=`numrandom .1..5i.1` echo sleeping $RAND_WAIT sleepenh $RAND_WAIT done -EOF +# or +while read y; do + killall -u vmail imapd; +done - $CMD_PERL ./imapsync \ +EOF + can_send && sendtestmessage +# can_send && sendtestmessage + $CMD_PERL ./imapsync \ --host1 $HOST1 --user1 tata \ --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ - --passfile2 ../../var/pass/secret.titi - - #--folder INBOX - #--debug --debugimap + --passfile2 ../../var/pass/secret.titi \ + --folder INBOX --useuid \ + --delete2 --expunge2 } +ll_dev_reconnect_ssl_tls() +{ +# in another terminal: +# +: <<'EOF' +while :; do + killall -v -u vmail imapd; + RAND_WAIT=`numrandom .1..5i.1` + echo sleeping $RAND_WAIT + sleepenh $RAND_WAIT +done +# or +while read y; do + echo ENTER to kill all imapd + killall -v -u vmail imapd; +done + +EOF + can_send && sendtestmessage +# can_send && sendtestmessage + $CMD_PERL ./imapsync \ + --host1 $HOST1 --ssl1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --tls2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --folder INBOX --useuid \ + --delete2 +} + + ll_authmd5() @@ -631,22 +675,29 @@ ll_maxage_9999() ll_maxsize() -{ - - if can_send; then - #echo3 Here is plume - sendtestmessage - else - : - fi - $CMD_PERL ./imapsync \ +{ + can_send && sendtestmessage + $CMD_PERL ./imapsync \ --host1 $HOST1 --user1 tata \ --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --maxsize 10 + --maxsize 10 --nofoldersizes --folder INBOX } +ll_maxsize_useuid() +{ + can_send && sendtestmessage + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --maxsize 10 --nofoldersizes --folder INBOX \ + --useuid +} + + ll_skipsize() { @@ -1159,6 +1210,16 @@ ll_delete() { } +ll_delete_delete2() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 titi \ + --passfile1 ../../var/pass/secret.titi \ + --host2 $HOST2 --user2 tata \ + --passfile2 ../../var/pass/secret.tata \ + --delete --delete2 +} + + ll_bigmail() { $CMD_PERL ./imapsync \ --host1 $HOST1 --user1 big1 \ @@ -1550,6 +1611,16 @@ ll_useuid_nousecache() # specific tests ########################## +Giancarlo_1() { + $CMD_PERL ./imapsync \ + --host1 87.241.29.226 --user1 "Diego@studiobdp.local" \ + --passfile1 ../../var/pass/secret.Giancarlo \ + --host2 $HOST1 --user2 tata \ + --passfile2 ../../var/pass/secret.tata \ + --regextrans2 's/.*/INBOX.Giancarlo/' \ + --nofoldersizes --useuid +} + godaddy_1_justlogin() { $CMD_PERL ./imapsync \ --host1 $HOST1 --user1 tata \ @@ -1566,7 +1637,7 @@ mailenable_1() { --host2 email.avonvalley.wilts.sch.uk --user2 "GLamiral" \ --passfile2 ../../var/pass/secret.avonvalley \ --sep2 / --prefix2 '' --useuid \ - --folder INBOX.Junk --folder INBOX.few_emails \ + --folder INBOX --folder INBOX.Junk --folder INBOX.few_emails \ --delete2 --expunge2 } @@ -1594,6 +1665,34 @@ mailenable_3_reverse() { + + + + +mailenable_21_host1() { + $CMD_PERL ./imapsync \ + --host1 elix-irr.com --user1 "greg.watson" \ + --passfile1 ../../var/pass/secret.greg.watson \ + --host2 $HOST1 --user2 zzz \ + --passfile2 ../../var/pass/secret.zzz \ + --sep1 / --prefix1 '' \ + --delete2 --expunge2 --useuid + +} + +mailenable_22_host2() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 elix-irr.com --user2 "greg.watson" \ + --passfile2 ../../var/pass/secret.greg.watson \ + --sep2 / --prefix2 '' \ + --folder INBOX.Junk --folder INBOX --folder INBOX.few_emails \ + --useuid --debugLIST +} + + + bug_zero_byte() { $CMD_PERL ./imapsync \ --host1 buzon.us.es --user1 rafaeltovar \ @@ -1630,8 +1729,6 @@ exchange_3_delete2() { --folder INBOX.Junk --useuid --delete2 } - - jong_1() { $CMD_PERL ./imapsync \ --host1 mail.y-publicaties.nl --user1 gillesl --passfile1 ../../var/pass/secret.jong \ @@ -1854,7 +1951,7 @@ dprof_bigmail() # Tests list mandatory_tests=' -no_args +no_args option_version option_tests option_tests_debug @@ -1922,6 +2019,7 @@ ll_authmech_PLAIN ll_authmech_LOGIN ll_authmech_CRAMMD5 ll_authuser +ll_delete_delete2 ll_delete2 ll_delete ll_folderrec @@ -1936,6 +2034,8 @@ ll_nousecache ll_delete2foldersonly ll_delete2foldersonly_tmp ll_delete2foldersbutnot +ll_folder_create +ll_folder_create_INBOX_Inbox ll_delete2folders ll_useuid ll_useuid_nousecache diff --git a/tools/wonko_ruby_imapsync b/tools/wonko_ruby_imapsync deleted file mode 100644 index 014f26e..0000000 --- a/tools/wonko_ruby_imapsync +++ /dev/null @@ -1,116 +0,0 @@ -#!/usr/bin/env ruby -require 'net/imap' -# -# http://wonko.com/article/554 -# -# Gilles LAMIRAL: Your Ruby code is nice. Is it GPL? Can I make a reference -# to it in the imapsync distribution? -# -# Wonko : Please consider this code public domain (and unsupported). -# You're more than welcome to refer to it if you'd like. -# -# -# Source server connection info. -SOURCE_HOST = 'mail.example.com' -SOURCE_PORT = 143 -SOURCE_SSL = false -SOURCE_USER = 'username' -SOURCE_PASS = 'password' - -# Destination server connection info. -DEST_HOST = 'imap.gmail.com' -DEST_PORT = 993 -DEST_SSL = true -DEST_USER = 'username@gmail.com' -DEST_PASS = 'password' - -# Mapping of source folders to destination folders. The key is the name of the -# folder on the source server, the value is the name on the destination server. -# Any folder not specified here will be ignored. If a destination folder does -# not exist, it will be created. -FOLDERS = { - 'INBOX' => 'INBOX', - 'sourcefolder' => 'gmailfolder' -} - -# Utility methods. -def dd(message) - puts "[#{DEST_HOST}] #{message}" -end - -def ds(message) - puts "[#{SOURCE_HOST}] #{message}" -end - -# Connect and log into both servers. -ds 'connecting...' -source = Net::IMAP.new(SOURCE_HOST, SOURCE_PORT, SOURCE_SSL) - -ds 'logging in...' -source.login(SOURCE_USER, SOURCE_PASS) - -dd 'connecting...' -dest = Net::IMAP.new(DEST_HOST, DEST_PORT, DEST_SSL) - -dd 'logging in...' -dest.login(DEST_USER, DEST_PASS) - -# Loop through folders and copy messages. -FOLDERS.each do |source_folder, dest_folder| - # Open source folder in read-only mode. - begin - ds "selecting folder '#{source_folder}'..." - source.examine(source_folder) - rescue => e - ds "error: select failed: #{e}" - next - end - - # Open (or create) destination folder in read-write mode. - begin - dd "selecting folder '#{dest_folder}'..." - dest.select(dest_folder) - rescue => e - begin - dd "folder not found; creating..." - dest.create(dest_folder) - dest.select(dest_folder) - rescue => ee - dd "error: could not create folder: #{e}" - next - end - end - - # Build a lookup hash of all message ids present in the destination folder. - dest_info = {} - - dd 'analyzing existing messages...' - dest.uid_fetch(dest.uid_search(['ALL']), ['ENVELOPE']).each do |data| - dest_info[data.attr['ENVELOPE'].message_id] = true - end - - # Loop through all messages in the source folder. - source.uid_fetch(source.uid_search(['ALL']), ['ENVELOPE']).each do |data| - mid = data.attr['ENVELOPE'].message_id - - # If this message is already in the destination folder, skip it. - next if dest_info[mid] - - # Download the full message body from the source folder. - ds "downloading message #{mid}..." - msg = source.uid_fetch(data.attr['UID'], ['RFC822', 'FLAGS', - 'INTERNALDATE']).first - - # Append the message to the destination folder, preserving flags and - # internal timestamp. - dd "storing message #{mid}..." - dest.append(dest_folder, msg.attr['RFC822'], msg.attr['FLAGS'], - msg.attr['INTERNALDATE']) - end - - source.close - dest.close -end - -puts 'done' -