diff --git a/CREDITS b/CREDITS index af4c221..df1132a 100644 --- a/CREDITS +++ b/CREDITS @@ -1,5 +1,5 @@ #!/bin/cat -# $Id: CREDITS,v 1.159 2011/05/30 21:58:46 gilles Exp gilles $ +# $Id: CREDITS,v 1.160 2011/07/11 01:30:09 gilles Exp gilles $ If you want to make a donation to the author, Gilles LAMIRAL, use any of the following ways: @@ -30,6 +30,13 @@ 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. +Paulo Victor Fernandes da Silva +Contributed by giving money 1 USD + + +Daniel Rohde +Bugfix. Solaris 10. ps -o vsz -p @PID + Dex Kelson. Contributed by his patch for a better good_date() with --idatefromheader over 100000 messages. diff --git a/ChangeLog b/ChangeLog index 00af703..ad998dd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,17 +1,42 @@ RCS file: RCS/imapsync,v Working file: imapsync -head: 1.446 +head: 1.452 branch: locks: strict - gilles: 1.446 + gilles: 1.452 access list: symbolic names: keyword substitution: kv -total revisions: 446; selected revisions: 446 +total revisions: 452; selected revisions: 452 description: ---------------------------- -revision 1.446 locked by: gilles; +revision 1.452 locked by: gilles; +date: 2011/07/11 00:29:06; author: gilles; state: Exp; lines: +64 -47 +Added the --search option allowing to select messages with the powerful IMAP SEARCH command. +---------------------------- +revision 1.451 +date: 2011/06/30 11:44:38; author: gilles; state: Exp; lines: +7 -8 +Added IO::Socket::INET version info. +---------------------------- +revision 1.450 +date: 2011/06/21 00:17:20; author: gilles; state: Exp; lines: +7 -7 +Bugfix. Fixed ps call to work with Solaris 10. Thanks to Daniel Rohde. +---------------------------- +revision 1.449 +date: 2011/06/16 12:20:42; author: gilles; state: Exp; lines: +13 -10 +Kerio 7.2.0P1 success. +MDaemon 12.0.3 success. +---------------------------- +revision 1.448 +date: 2011/06/03 00:54:15; author: gilles; state: Exp; lines: +9 -9 +Bugfix. Date reference to select messages with --maxdate --mindate is the beginning of imapsync run now. +---------------------------- +revision 1.447 +date: 2011/06/02 00:01:01; author: gilles; state: Exp; lines: +13 -13 +Added PERMANENTFLAGS output with --debugflags +---------------------------- +revision 1.446 date: 2011/05/31 09:11:18; author: gilles; state: Exp; lines: +17 -17 Bugfix. Try to handle Markus bug in foldersizes() when select_msgs() returns a list of undef. ---------------------------- diff --git a/FAQ b/FAQ index b25bcee..7a54e78 100644 --- a/FAQ +++ b/FAQ @@ -1,5 +1,5 @@ #!/bin/cat -# $Id: FAQ,v 1.88 2011/05/26 00:53:26 gilles Exp gilles $ +# $Id: FAQ,v 1.89 2011/07/11 01:17:39 gilles Exp gilles $ +------------------+ | FAQ for imapsync | @@ -285,6 +285,25 @@ the backslash character \ (see next question to find a solution to this issue) +======================================================================= +Q. How to convert flags? + +R. use --regexflag +For example to convert flag IMPORTANT to flag CANWAIT + + imapsync ... --regexflag 's/IMPORTANT/CANWAIT/g' --debugflags + +option --debugflags is usefull to see in details what imapsync +does with flags. + +======================================================================= +Q. How to convert flags with $ to \ character? + +R. $ and \ are special characters we have to "escape" them. +For example to convert flag $label1 to \label1 + + imapsync ... --regexflag 's/\$label1/\\label1/g' --debugflags + ======================================================================= Q. I need to keep only a defind list of flags, how can I do? The destination imap server complains about bad flags (Exchange). diff --git a/Makefile b/Makefile index 326ed8f..e73c0da 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -# $Id: Makefile,v 1.79 2011/05/31 21:32:16 gilles Exp gilles $ +# $Id: Makefile,v 1.82 2011/07/11 01:02:45 gilles Exp gilles $ .PHONY: help usage all @@ -152,7 +152,7 @@ test_imapsync_exe: dosify_bat time ssh Admin@c 'C:/msys/1.0/home/Admin/imapsync/test_exe.bat' -imapsync.exe: imapsync build_exe.bat test_exe.bat .dosify_bat +imapsync.exe: imapsync build_exe.bat .dosify_bat rcsdiff imapsync ssh Admin@c 'perl -V' (date "+%s"| tr "\n" " "; echo -n "BEGIN " $(VERSION) ": "; date) >> .BUILD_EXE_TIME @@ -223,6 +223,8 @@ lalala: dist_prepa: tarball dist_dir ln -f ../prepa_dist/$(DIST_FILE) $(DIST_PATH)/ + rcsdiff imapsync + cp -a imapsync $(DIST_PATH)/ #cd $(DIST_PATH)/ && md5sum $(DIST_FILE) > $(DIST_FILE).md5.txt #cd $(DIST_PATH)/ && md5sum -c $(DIST_FILE).md5.txt ls -l $(DIST_PATH)/ @@ -244,36 +246,35 @@ dist_prepa_exe: imapsync.exe ks: - 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/ \ - ; } + rsync -avz --delete --exclude imapsync.exe \ + . imapsync@ks.lamiral.info:public_html/imapsync/ PUBLIC_FILES = ./ChangeLog ./COPYING ./CREDITS ./FAQ \ ./index.shtml ./INSTALL ./TIME \ ./logo_imapsync.png ./logo_imapsync_s.png \ ./paypal.shtml ./paypal_return.shtml ./paypal_return_support.shtml \ -./README ./style.css ./TODO ./VERSION ./VERSION_EXE +./README ./style.css ./TODO ./VERSION ./VERSION_EXE ./memo upload_ks: - rsync -lptvHz $(PUBLIC_FILES) \ + rsync -lptvHzP $(PUBLIC_FILES) \ root@ks.lamiral.info:/var/www/imapsync/ - rsync -lptvHzr ./dist/ \ + rsync -lptvHzrP ./dist/ \ root@ks.lamiral.info:/var/www/imapsync/dist/ upload_lfo: #rm -rf /home/gilles/public_html/www.linux-france.org/html/prj/imapsync/ #rm -rf /home/gilles/public_html/www.linux-france.org/ftp/prj/imapsync/ - rsync -avH $(PUBLIC_FILES) \ + rsync -avHz $(PUBLIC_FILES) \ /home/gilles/public_html/www.linux-france.org/html/prj/imapsync/ - rsync -avH ./dist/index.shtml \ - /home/gilles/public_html/www.linux-france.org/html/prj/imapsync/dist/ + rsync -lptvHzP ./lfo.htaccess \ + /home/gilles/public_html/www.linux-france.org/html/prj/imapsync/.htaccess sh ~/memo/lfo-rsync upload_index: index.shtml validate --verbose index.shtml rcsdiff index.shtml + rsync -avH index.shtml root@ks.lamiral.info:/var/www/imapsync/ rsync -avH index.shtml \ ../../public_html/www.linux-france.org/html/prj/imapsync/ sh $(HOME)/memo/lfo-rsync diff --git a/README b/README index 8304429..fce9363 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.446 $ + $Revision: 1.452 $ SYNOPSIS To synchronise imap account "foo" on "imap.truc.org" to imap account @@ -294,7 +294,7 @@ IMAP SERVERS Patient and confident testers are welcome. - Imail 7.04 (maybe). - Success stories reported with the following 41 imap servers (software + Success stories reported with the following 44 imap servers (software names are in alphabetic order): - 1und1 H mimap1 84498 [host1] @@ -331,8 +331,10 @@ IMAP SERVERS - 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, 11.03 [host1] + - Kerio 7.2.0P1 [host1] - MailEnable 4.23 [host1] [host2] - - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform), 12 [host2] + - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform), 12 [host2], + 12.0.3 [host1] - 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], 6.5 [host1], Exchange 2007 SP1 (with Update Rollup 2), @@ -357,7 +359,7 @@ IMAP SERVERS (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 + - VMS, 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, Zimbra 5.0.24_GA_3356.RHEL4 [host1], 5.5, 6.x @@ -424,5 +426,5 @@ SIMILAR SOFTWARES Feedback (good or bad) will often be welcome. - $Id: imapsync,v 1.446 2011/05/31 09:11:18 gilles Exp gilles $ + $Id: imapsync,v 1.452 2011/07/11 00:29:06 gilles Exp gilles $ diff --git a/TIME b/TIME index 768afef..112e959 100644 --- a/TIME +++ b/TIME @@ -1,3 +1,5 @@ + 60 Added --search option. +600 (1.446) new host ks. newsletter for imapsync updates. first letter to 563 members. 30 Patched tests_good_date() and good_date() with Dax Kelson patches. 120 Added a good reply for buying support. 540 (1.434) (1.433) (1.432) diff --git a/TODO b/TODO index 5913d99..40d06e4 100644 --- a/TODO +++ b/TODO @@ -1,5 +1,5 @@ #!/bin/cat -# $Id: TODO,v 1.98 2011/05/30 21:59:06 gilles Exp gilles $ +# $Id: TODO,v 1.100 2011/07/11 01:09:39 gilles Exp gilles $ TODO file for imapsync ---------------------- @@ -25,6 +25,8 @@ http://www.yippiemove.com/ Find a way to avoid passwords in --debugimap unless needed. +Explain that users can win time/bandwidth by using --expunge + Fix long path over than 256 character on Win32. Think about Digest::SHA or Digest::SHA::PurePerl. @@ -158,6 +160,8 @@ http://asg.web.cmu.edu/cyrus/download/imapd/altnamespace.html =========================================================================== +DONE. Add --search option allowing to select messages with any IMAP SEARCH command. + DONE. Make --usecache works with --maxage --maxsize etc. DONE. Fix Exchange 2010 SP1 issue with --foldersizes when diff --git a/VERSION b/VERSION index 126917f..6268907 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -1.446 +1.452 diff --git a/VERSION_EXE b/VERSION_EXE index 126917f..6268907 100644 --- a/VERSION_EXE +++ b/VERSION_EXE @@ -1 +1 @@ -1.446 +1.452 diff --git a/W/CONCEPTION b/W/CONCEPTION new file mode 100644 index 0000000..a786035 --- /dev/null +++ b/W/CONCEPTION @@ -0,0 +1,26 @@ + +===== Synopsis ===== + +$mailbox_1 = Mail::imapsync::mailbox->new(); +$mailbox_2 = Mail::imapsync::mailbox->new(); + + +$mailbox_1->host('imap1.lala.org'); +$mailbox_1->user('toto1'); +... + +$mailbox_2->host('imap2.lala.org'); +$mailbox_2->user('toto2'); +... + + +$transfer = Mail::imapsync::transfer->new(); +$transfer->sync($mailbox_1, $mailbox_2); + + +- an object for mailbox +- an object for a transfer +- ?an object for a folder? +- ?an object for a message? + + diff --git a/W/RECORD b/W/RECORD new file mode 100644 index 0000000..108f272 --- /dev/null +++ b/W/RECORD @@ -0,0 +1,46 @@ + ++------------------+ +| 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/W/adwords b/W/adwords new file mode 100644 index 0000000..b4503f3 --- /dev/null +++ b/W/adwords @@ -0,0 +1,6 @@ +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/W/freshmeat/freshmeat b/W/freshmeat/freshmeat new file mode 100644 index 0000000..abffb76 --- /dev/null +++ b/W/freshmeat/freshmeat @@ -0,0 +1,10 @@ +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/W/freshmeat/freshmeat_submition.inp b/W/freshmeat/freshmeat_submition.inp new file mode 100644 index 0000000..ce85cb0 --- /dev/null +++ b/W/freshmeat/freshmeat_submition.inp @@ -0,0 +1,15 @@ + +# +#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/W/freshmeat/freshmeat_submition.json b/W/freshmeat/freshmeat_submition.json new file mode 100644 index 0000000..abc407c --- /dev/null +++ b/W/freshmeat/freshmeat_submition.json @@ -0,0 +1,9 @@ +{ + "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/W/freshmeat/freshmeat_submition.out b/W/freshmeat/freshmeat_submition.out new file mode 100644 index 0000000..391d5de --- /dev/null +++ b/W/freshmeat/freshmeat_submition.out @@ -0,0 +1,12 @@ +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/W/lsm.imapsync b/W/lsm.imapsync new file mode 100644 index 0000000..a007b99 --- /dev/null +++ b/W/lsm.imapsync @@ -0,0 +1,16 @@ +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/W/paypal_reply/8859_utf8 b/W/paypal_reply/8859_utf8 new file mode 100755 index 0000000..02f5630 --- /dev/null +++ b/W/paypal_reply/8859_utf8 @@ -0,0 +1,13 @@ +#!/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/W/paypal_reply/TODO b/W/paypal_reply/TODO new file mode 100644 index 0000000..63227b7 --- /dev/null +++ b/W/paypal_reply/TODO @@ -0,0 +1,6 @@ + + +Rewrite all with less scripts +use Email::Simple module + + diff --git a/W/paypal_reply/memo b/W/paypal_reply/memo new file mode 100644 index 0000000..36f9529 --- /dev/null +++ b/W/paypal_reply/memo @@ -0,0 +1,293 @@ +#!/bin/sh + +# $Id: memo,v 1.5 2011/05/20 12:57:31 gilles Exp gilles $ + +echo paypal_bilan_tests_refact_4 +paypal_bilan_tests_refact_4() { +# DID output no diff between paypal_bilan_1.33 and 1.?? +( +#set -x + +# from 147 to 213 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan_1.33 --bnc --debug --first_in 147 /g/paypal/paypal_2010_11_complet.csv > /g/var/paypal_bilan/tests/paypal_2010_11_complet.csv.1.33_first_in.out1 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug --first_in 147 /g/paypal/paypal_2010_11_complet.csv > /g/var/paypal_bilan/tests/paypal_2010_11_complet.csv.1.33_first_in.out2 +echo diff /g/var/paypal_bilan/tests/paypal_2010_11_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2010_11_complet.csv.1.33_first_in.out2 +diff /g/var/paypal_bilan/tests/paypal_2010_11_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2010_11_complet.csv.1.33_first_in.out2 + +# from 214 to 291 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan_1.33 --bnc --debug --first_in 214 /g/paypal/paypal_2010_12_complet.csv > /g/var/paypal_bilan/tests/paypal_2010_12_complet.csv.1.33_first_in.out1 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug --first_in 214 /g/paypal/paypal_2010_12_complet.csv > /g/var/paypal_bilan/tests/paypal_2010_12_complet.csv.1.33_first_in.out2 +echo diff /g/var/paypal_bilan/tests/paypal_2010_12_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2010_12_complet.csv.1.33_first_in.out2 +diff /g/var/paypal_bilan/tests/paypal_2010_12_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2010_12_complet.csv.1.33_first_in.out2 + +# from 294 to 381 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan_1.33 --bnc --debug --first_in 294 /g/paypal/paypal_2011_01_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_01_complet.csv.1.33_first_in.out1 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug --first_in 294 /g/paypal/paypal_2011_01_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_01_complet.csv.1.33_first_in.out2 +echo diff /g/var/paypal_bilan/tests/paypal_2011_01_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_01_complet.csv.1.33_first_in.out2 +diff /g/var/paypal_bilan/tests/paypal_2011_01_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_01_complet.csv.1.33_first_in.out2 + +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug --first_in 292 --avoid_numbers '292 293' /g/paypal/paypal_2011_01_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_01_complet.csv.1.33_first_in.out3 +echo diff /g/var/paypal_bilan/tests/paypal_2011_01_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_01_complet.csv.1.33_first_in.out3 +diff /g/var/paypal_bilan/tests/paypal_2011_01_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_01_complet.csv.1.33_first_in.out3 + +# from 382 to 472 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan_1.33 --bnc --debug --first_in 382 /g/paypal/paypal_2011_02_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_02_complet.csv.1.33_first_in.out1 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug --first_in 382 /g/paypal/paypal_2011_02_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_02_complet.csv.1.33_first_in.out2 +echo diff /g/var/paypal_bilan/tests/paypal_2011_02_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_02_complet.csv.1.33_first_in.out2 +diff /g/var/paypal_bilan/tests/paypal_2011_02_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_02_complet.csv.1.33_first_in.out2 + +# from 473 to 569 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan_1.33 --bnc --debug --first_in 473 /g/paypal/paypal_2011_03_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_03_complet.csv.1.33_first_in.out1 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug --first_in 473 /g/paypal/paypal_2011_03_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_03_complet.csv.1.33_first_in.out2 +echo diff /g/var/paypal_bilan/tests/paypal_2011_03_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_03_complet.csv.1.33_first_in.out2 +diff /g/var/paypal_bilan/tests/paypal_2011_03_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_03_complet.csv.1.33_first_in.out2 + +# from 570 to 642 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan_1.33 --bnc --debug --first_in 570 /g/paypal/paypal_2011_04_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_04_complet.csv.1.33_first_in.out1 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug --first_in 570 /g/paypal/paypal_2011_04_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_04_complet.csv.1.33_first_in.out2 +echo diff /g/var/paypal_bilan/tests/paypal_2011_04_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_04_complet.csv.1.33_first_in.out2 +diff /g/var/paypal_bilan/tests/paypal_2011_04_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_04_complet.csv.1.33_first_in.out2 + +# from 645 to 730 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan_1.33 --bnc --debug --first_in 645 /g/paypal/paypal_2011_05_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_05_complet.csv.1.33_first_in.out1 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug --first_in 645 /g/paypal/paypal_2011_05_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_05_complet.csv.1.33_first_in.out2 +echo diff /g/var/paypal_bilan/tests/paypal_2011_05_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_05_complet.csv.1.33_first_in.out2 +diff /g/var/paypal_bilan/tests/paypal_2011_05_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_05_complet.csv.1.33_first_in.out2 + +# from 733 to 764 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan_1.33 --bnc --debug --first_in 733 /g/paypal/paypal_2011_06_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out1 +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug --first_in 733 /g/paypal/paypal_2011_06_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out2 +echo diff /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out2 +diff /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out2 + +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug --first_in 733 --avoid_numbers '' \ + /g/paypal/paypal_2011_06_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out3 +echo diff /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out3 +diff /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out3 + +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug --first_in 731 --avoid_numbers '731 732' \ + /g/paypal/paypal_2011_06_complet.csv > /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out4 +echo diff /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out4 +diff /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out1 /g/var/paypal_bilan/tests/paypal_2011_06_complet.csv.1.33_first_in.out4 + + +for f in /g/paypal/paypal_201?_??_complet.csv; do + fb=`basename "$f"` + f1=/g/var/paypal_bilan/tests/${fb}_1.32.out1 + f2=/g/var/paypal_bilan/tests/${fb}_1.32.out2 + rm "$f2" + /g/public_html/imapsync/W/paypal_reply/paypal_bilan_1.33 \ + --bnc --debug --debug_csv "$f" \ + > "$f1" + + /g/public_html/imapsync/W/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/W/paypal_reply/paypal_bilan_1.33 \ + "$f" \ + > "$f1" + + /g/public_html/imapsync/W/paypal_reply/paypal_bilan \ + "$f" \ + > "$f2" + + echo diff "$f1" "$f2" + diff "$f1" "$f2" +done + +) +} + + +#echo paypal_bilan_tests_refact_3 +paypal_bilan_tests_refact_3() { +# DID output no diff between paypal_bilan_1.27 and 1.?? +( +#set -x +for f in /g/paypal/paypal_201?_??_complet.csv; do + fb=`basename "$f"` + f1=/g/var/paypal_bilan/tests/${fb}_1.27.out1 + f2=/g/var/paypal_bilan/tests/${fb}_1.27.out2 + rm "$f2" + /g/public_html/imapsync/W/paypal_reply/paypal_bilan_1.27 \ + --bnc --debug --debug_csv "$f" \ + > "$f1" + + /g/public_html/imapsync/W/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/W/paypal_reply/paypal_bilan_1.27 \ + "$f" \ + > "$f1" + + /g/public_html/imapsync/W/paypal_reply/paypal_bilan \ + "$f" \ + > "$f2" + + echo diff "$f1" "$f2" + diff "$f1" "$f2" +done +) +} + + +#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/W/paypal_reply/paypal_bilan b/W/paypal_reply/paypal_bilan new file mode 100755 index 0000000..7e86005 --- /dev/null +++ b/W/paypal_reply/paypal_bilan @@ -0,0 +1,1073 @@ +#!/usr/bin/perl + +# $Id: paypal_bilan,v 1.35 2011/06/28 23:18:12 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); +use Test::More 'no_plan' ; + +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_HT_EUR_sup = 0 ; +my $total_TVA_EUR_sup = 0 ; + +my $total_eur_received = 0 ; +my $total_eur_invoice = 0 ; +my $nb_invoice = 0 ; +my $nb_invoice_refund = 0 ; +my $nb_invoice_suspended = 0 ; + +my ( $tests, $testeur ) ; +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 %invoice_suspended ; +my $write_invoices = 0 ; +my $avoid_numbers ; + +my $dir_invoices = '/g/var/paypal_invoices' ; + +my $option_ret = GetOptions ( + 'tests' => \$tests, + '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, + 'avoid_numbers=s' => \$avoid_numbers, +); + +$testeur = Test::More->builder ; +$testeur->no_ending(1) ; + +if ( $tests ) { + $testeur->no_ending( 0 ) ; + exit( tests( ) ) ; +} + + +my @files = @ARGV ; +my %action_of_invoice ; + +my %invoice_paypal ; +#$invoice_paypal{ $first_invoice } = 1 ; + +my @invoices_wanted = split( /\s+/, $invoices ) if $invoices ; + +my @avoid_numbers = split( /\s+/, $avoid_numbers ) if $avoid_numbers ; +my %avoid_numbers ; +@avoid_numbers{ @avoid_numbers } = ( ) if @avoid_numbers ; + +#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, $Titre_de_l_objet ) + = @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', "Titre de l'objet") } ; + #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, $Titre_de_l_objet ) ; + + # index by invoice number + $action_of_invoice{ $action->{ 'invoice' } } = $action ; + } + delete $action_of_invoice{ 'NONE' } ; +} + +my $last_invoice ; +my @invoice_paypal = sort { $a <=> $b } keys %invoice_paypal ; +$last_invoice = $invoice_paypal[-1] || 0 ; +my $first_invoice_paypal = $invoice_paypal[0] || 0 ; + +@invoices_wanted = ( $first_invoice .. $last_invoice ) if ( ! @invoices_wanted ) ; + +my @invoice_sent ; +my %invoice_sent ; +my @invoice_not_sent ; +my %invoice_not_sent ; + +foreach my $invoice ( @invoices_wanted ) { + + my $action = $action_of_invoice{ $invoice } ; + next if ! $action ; + my $email_address = $action->{ "De l'adresse email" } ; + + my $invoice_sent = invoice_sent( $dir_invoices, $invoice, $email_address ) ; + #print "$invoice $invoice_sent\n" ; + + if ( $invoice_sent ) { + $invoice_sent{ $invoice }++ ; + }else{ + $invoice_not_sent{ $invoice }++ ; + build_invoice( $invoice ) ; + } +} + +@invoice_sent = sort { $a <=> $b } keys( %invoice_sent ) ; +my $nb_invoice_sent = scalar( @invoice_sent ) ; +@invoice_not_sent = sort { $a <=> $b } keys( %invoice_not_sent ) ; + +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_HT_EUR_sup = sprintf('%2.f', $total_HT_EUR_sup) ; +$total_TVA_EUR_sup = sprintf('%2.f', $total_TVA_EUR_sup) ; + +$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 "EUR total HT sup $total_HT_EUR_sup\n" ; +print "EUR total TVA sup $total_TVA_EUR_sup\n" ; +print "Nb invoice $nb_invoice ( from $first_invoice_paypal to $last_invoice )\n" ; +print "Nb invoice refund $nb_invoice_refund\n" ; +print "Nb invoice suspended $nb_invoice_suspended\n" ; +print "Nb invoice sent $nb_invoice_sent\n" ; +print "Have to send invoices @invoice_not_sent\n" if ( @invoice_not_sent ) ; + +print "$total_eur != $total_HT_EUR_exo + $total_HT_EUR_ass + $total_TVA_EUR + $total_HT_EUR_sup + $total_TVA_EUR_sup\n" +if ( $total_eur != $total_HT_EUR_exo + $total_HT_EUR_ass + $total_TVA_EUR + $total_HT_EUR_sup + $total_TVA_EUR_sup ) ; + +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 next_invoice { + my @current_numbers = sort { $a <=> $b } ( $first_invoice - 1, keys( %invoice_paypal ) ) ; + my $last_invoice = $current_numbers[ -1 ] || 0 ; + + #keys( %avoid_numbers ), + my $next_invoice = $last_invoice + 1 ; + while ( exists( $avoid_numbers{ $next_invoice } ) ) { $next_invoice++ ; } + $invoice_paypal{ $next_invoice } = 1 ; + #print "AAA [@current_numbers] [$last_invoice] [$next_invoice]\n" ; + + return( $next_invoice ) ; +} + +sub keyval { + my %hash = @_ ; + return( join( " ", map( { "$_ => " . $hash{ $_ } } keys %hash ) ) . "\n" ) ; +} + + +sub tests_next_invoice { + ok( 1 == next_invoice( ) ) ; + ok( 2 == next_invoice( ) ) ; + @avoid_numbers{ (3, 4, 6, 8 ) } = ( ) ; + ok( 5 == next_invoice( ) ) ; + ok( 7 == next_invoice( ) ) ; + ok( 9 == next_invoice( ) ) ; + %invoice_paypal = () ; + $first_invoice = 7 ; + ok( 7 == next_invoice( ) ) ; + +} + + +sub tests { + tests_next_invoice( ) ; + +} + +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, $Titre_de_l_objet ) = @_ ; + + $debug and print( "-" x 60, "\n", + "[$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] ", + "[$Devise] [$Hors_taxe_paypal] [$Montant] [$Numero_davis_de_reception] [$Solde]\n", + "[$Pays] [$Nom_Option_1] [$Valeur_Option_1] [$Titre_de_l_objet]\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 ) ; + my( $montant_HT_EUR_sup, $montant_TVA_EUR_sup ) ; + + if ( $bnc ) { + $MontantEUR = $Montant ; + $MontantEUR = sprintf( "%.4f", $Montant/$usdeur ) if ($Devise eq 'USD') ; + print( "\n", "=" x 60, "\n" ) ; + print( "[$Date] [$Nom] [$Type] [$Etat] [$Devise] [$Hors_taxe_paypal] [$Montant] [EUR $MontantEUR]\n", + "[$Pays] [$Nom_Option_1] [$Valeur_Option_1] [$Titre_de_l_objet]\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, $montant_HT_EUR_sup, $montant_TVA_EUR_sup ) + = tva_line( $Devise, $Montant2_usd, $Pays, $Nom_Option_1, $Valeur_Option_1, $Titre_de_l_objet ) ; + $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 ; + $invoice = next_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, $montant_HT_EUR_sup, $montant_TVA_EUR_sup ) + = tva_line( $Devise, $Montant2_eur, $Pays, $Nom_Option_1, $Valeur_Option_1, $Titre_de_l_objet ) ; + $total_HT_EUR_exo += $montant_HT_EUR_exo ; + $total_HT_EUR_ass += $montant_HT_EUR_ass ; + $total_TVA_EUR += $montant_TVA_EUR ; + $total_HT_EUR_sup += $montant_HT_EUR_sup ; + $total_TVA_EUR_sup += $montant_TVA_EUR_sup ; + + + #$invoice = $first_invoice + $nb_invoice ; + $invoice = next_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 ; + $invoice = next_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 'Suspendu' eq $Etat + ) { + #$invoice = $first_invoice + $nb_invoice ; + $invoice = next_invoice( ) ; + $nb_invoice++ ; + $nb_invoice_suspended++; + $invoice_suspended{ $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 ; + $invoice = next_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, $Titre_de_l_objet ) ; + if ( $write_invoices and ! invoice_sent( $dir_invoices, $invoice, $De_l_adresse_email ) ) { + 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 $quantity = '1' ; + + my ( + $descriptionFR, + $descriptionEN, + $usageFR, + $usageEN, + ) + = description_stuff( $Titre_de_l_objet, $clientTypeEN ) ; + + my ( + $priceHT, + $tvaFR, + $tvaEN, + $priceTVA, + $priceTTC, + $messageTVAFR, + $messageTVAEN, + $priceTTCusd + ) + = tva_stuff( $clientTypeEN, $Pays, $Hors_taxe, $Devise, $Titre_de_l_objet ) ; + + my $object_type = object_type( $Titre_de_l_objet ) ; + + my ( $urlSrc, $urlExe ) = download_urls( $Date, $object_type ) ; + #print "ZZZ $object_type ( $urlSrc, $urlExe )\n" ; + + my $tex_variables = qq{ +%% Begin input from $0 +\\providecommand{\\invoiceNumber}{$invoice} +\\providecommand{\\clientName}{$Nom} +\\providecommand{\\clientEmail}{$De_l_adresse_email} +\\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{\\descriptionFR}{$descriptionFR} +\\providecommand{\\descriptionEN}{$descriptionEN} +\\providecommand{\\usageFR}{$usageFR} +\\providecommand{\\usageEN}{$usageEN} +\\providecommand{\\quantity}{$quantity} + +\\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 ; + + #print "$invoice ", invoice_sent( $dir_invoices, $invoice, $De_l_adresse_email ), "\n" ; + if ( $write_invoices and ! invoice_sent( $dir_invoices, $invoice, $De_l_adresse_email ) ) { + write_tex_variables_file( $dir_invoices, $invoice, $Date, $tex_variables ) ; + } + +} + +sub description_stuff { + my ( $object, $clientTypeEN ) = @_ ; + + my $object_type = object_type( $object ) ; + + my ( $descriptionFR, $descriptionEN ) ; + if ( 'software' eq $object_type ) { + $descriptionFR = 'Logiciel imapsync. Tous droits cédés.' ; + $descriptionEN = '(Imapsync software. All rights conceded.)' ; + } + + my ( $usageFR, $usageEN ) ; + if ( 'professional' eq $clientTypeEN + and 'software' eq $object_type ) { + $usageFR = 'Usage à titre professionnel.' ; + $usageEN = '(professional usage.)' ; + } + + if ( 'individual' eq $clientTypeEN + and 'software' eq $object_type ) { + $usageFR = 'Usage à titre individuel.' ; + $usageEN = '(individual usage.)' ; + } + + if ( 'support' eq $object_type ) { + $descriptionFR = 'Support sur le logiciel imapsync.' ; + $descriptionEN = '(Imapsync support.)' ; + $usageFR = '' ; + $usageEN = '' ; + } + return( $descriptionFR, $descriptionEN, $usageFR, $usageEN ) ; +} + + + +sub object_type { + my $object = shift ; + + if ( 'imapsync' eq $object + or 'imapsync.exe' eq $object + or 'imapsync source' eq $object + or 'imapsync source code' eq $object + ) { + return( 'software' ) ; + }elsif ( 'imapsync support' eq $object ) { + return( 'support' ) ; + } +} + +sub build_email_message { + + my ( $date, $name, $email, $invoice, $objet ) = @_ ; + + my $object_type = object_type( $objet ) ; + + my $message_header_software = qq{X-imapsync: invoice $invoice for imapsync software +From: Gilles LAMIRAL +Bcc: gilles\@lamiral.info +Subject: [imapsync invoice] $invoice ($date) for imapsync software +Disposition-Notification-To: Gilles LAMIRAL +} ; + + my $message_header_support = qq{X-imapsync: invoice $invoice for imapsync support +From: Gilles LAMIRAL +Bcc: gilles\@lamiral.info +Subject: [imapsync invoice] $invoice ($date) for imapsync support +Disposition-Notification-To: Gilles LAMIRAL +} ; + + my $message_body_software = qq{ +Hello $name, + +First of all, I'm sorry for the delay in getting back to you. + +You'll find in the attachment the invoice of imapsync +software you bought and paid (dd/mm/yyyy $date). +The invoice file is named facture_imapsync-${invoice}.pdf +This invoice is in PDF format, ready to be print. + +Should you need a hardcopy of this invoice, +I'll send it to you upon request by regular mail. + +As the law requires, 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 +you will also find in the attachment. + +You can check I (Gilles LAMIRAL) really did generate +this invoice with the following command line: + + gpg --verify facture_imapsync-${invoice}.pdf.asc facture_imapsync-${invoice}.pdf + +or any other gpg graphical tool. + +Once more, thank you for buying and using imapsync. + +Any feedback is welcome. + + +-- +Best Regards, 09 51 84 42 42 +Gilles Lamiral. France, Baulon (35580) 06 20 79 76 06 +} ; + + + my $message_body_support = qq{ +Hello $name, + +First of all, I'm sorry for the delay in getting back to you. + +You'll find in the attachment the invoice of imapsync +support you bought and paid (dd/mm/yyyy $date). +The invoice file is named facture_imapsync-${invoice}.pdf +This invoice is in PDF format, ready to be print. + +Should you need a hardcopy of this invoice, +I'll send it to you upon request by regular mail. + +As the law requires, 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 +you will also find in the attachment. + +You can check I (Gilles LAMIRAL) really did generate +this invoice with the following command line: + + gpg --verify facture_imapsync-${invoice}.pdf.asc facture_imapsync-${invoice}.pdf + +or any other gpg graphical tool. + +Once more, thank you for buying imapsync support. + +Any feedback is welcome. + +-- +Best Regards, 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. +} ; + + my ( $message_header, $message_body ) ; + if ( 'support' eq $object_type ) { + $message_header = $message_header_support ; + $message_body = $message_body_support ; + }elsif ( 'software' eq $object_type ) { + $message_header = $message_header_software ; + $message_body = $message_body_software ; + } + 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 invoice_sent { + + my ( $dir_invoices, $invoice, $email_address ) = @_ ; + + return( 1 ) if ( -f "$dir_invoices/$invoice/SENT_TO_$email_address" ) ; + return( 0 ) ; + +} + +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 ) ; + if ( ! -f "$dir_invoices/$invoice/imapsync_var_manual.tex" ) { + open( FILE, "> $dir_invoices/$invoice/imapsync_var_manual.tex") or die ; + print FILE "%% $0 created file +%% Can be used to override imapsync_var.tex definitions\n" ; + close( FILE ) ; + } + +} + +sub download_urls { + my $date_jjSmmSaaaa = shift ; + my $object_type = shift ; + + my $date_aaaa_mm_jj = date_aaaa_mm_jj( $date_jjSmmSaaaa ) ; + #print "$date_aaaa_mm_jj $date_jjSmmSaaaa $object_type\n" ; + my ( $urlSrc, $urlExe ) ; + + if ('2011_05_01' le $date_aaaa_mm_jj + and 'software' eq $object_type ) { + $urlSrc = 'http://ks.lamiral.info/imapsync/paypal_return.shtml' ; + $urlExe = '' ; + return( $urlSrc, $urlExe ) ; + } + + if ('2011_05_01' le $date_aaaa_mm_jj + and 'support' eq $object_type ) { + $urlSrc = 'http://ks.lamiral.info/imapsync/paypal_return_support.shtml' ; + $urlExe = '' ; + return( $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, $Titre_de_l_objet ) = @_ ; + my( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) = ( 0, 0, 0 ) ; + + my( $montant_HT_EUR_sup, $montant_TVA_EUR_sup ) = ( 0, 0 ) ; + + $Montant2 = $Montant2/$usdeur if 'USD' eq $Devise ; + + if ( 'imapsync' eq $Titre_de_l_objet + or 'imapsync.exe' eq $Titre_de_l_objet + or 'imapsync source' eq $Titre_de_l_objet + or 'imapsync source code' eq $Titre_de_l_objet + + ) { + if ( + ( 'imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) + or + ( 'France' eq $Pays ) + ) { + $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 ; + } + } + + if ( 'imapsync support' eq $Titre_de_l_objet ) { + #print "ZZZZ $Titre_de_l_objet $Montant2\n" ; + $montant_HT_EUR_sup = $Montant2 / 1.196 ; + $montant_TVA_EUR_sup = $Montant2 / 1.196 * 0.196 ; + } + + + return( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR, $montant_HT_EUR_sup, $montant_TVA_EUR_sup ) ; +} + + + +sub tva_stuff { + my( $clientTypeEN, $Pays, $Hors_taxe, $Devise, $Titre_de_l_objet ) = @_ ; + + 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 ) + or + ( 'imapsync support' eq $Titre_de_l_objet ) + ) { + $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/W/paypal_reply/paypal_bilan_1.22 b/W/paypal_reply/paypal_bilan_1.22 new file mode 100755 index 0000000..a66c377 --- /dev/null +++ b/W/paypal_reply/paypal_bilan_1.22 @@ -0,0 +1,756 @@ +#!/usr/bin/perl + +# $Id: paypal_bilan,v 1.22 2011/04/19 12:52:27 gilles Exp $ + +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/W/paypal_reply/paypal_bilan_1.27 b/W/paypal_reply/paypal_bilan_1.27 new file mode 100755 index 0000000..f137c1f --- /dev/null +++ b/W/paypal_reply/paypal_bilan_1.27 @@ -0,0 +1,826 @@ +#!/usr/bin/perl + +# $Id: paypal_bilan,v 1.27 2011/05/01 12:57:37 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 $nb_invoice_suspended = 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 %invoice_suspended ; +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' } ; +} + +my $last_invoice = $first_invoice + $nb_invoice -1 ; +@invoices = ( $first_invoice .. $last_invoice ) if ( ! @invoices ) ; + +my @invoice_sent ; +my %invoice_sent ; +my @invoice_not_sent ; +my %invoice_not_sent ; + +foreach my $invoice ( @invoices ) { + + my $action = $action_of_invoice{ $invoice } ; + my $email_address = $action->{ "De l'adresse email" } ; + + my $invoice_sent = invoice_sent( $dir_invoices, $invoice, $email_address ) ; + #print "$invoice $invoice_sent\n" ; + + if ( $invoice_sent ) { + $invoice_sent{ $invoice }++ ; + }else{ + $invoice_not_sent{ $invoice }++ ; + build_invoice( $invoice ) ; + } +} + +@invoice_sent = sort { $a <=> $b } keys( %invoice_sent ) ; +my $nb_invoice_sent = scalar( @invoice_sent ) ; +@invoice_not_sent = sort { $a <=> $b } keys( %invoice_not_sent ) ; + +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 ( from $first_invoice to $last_invoice )\n" ; +print "Nb invoice refund $nb_invoice_refund\n" ; +print "Nb invoice suspended $nb_invoice_suspended\n" ; +print "Nb invoice sent $nb_invoice_sent\n" ; +print "Have to send invoices @invoice_not_sent\n" if ( @invoice_not_sent ) ; + +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 'Suspendu' eq $Etat + ) { + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $nb_invoice_suspended++; + $invoice_suspended{ $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 and ! invoice_sent( $dir_invoices, $invoice, $De_l_adresse_email ) ) { + 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 ; + + #print "$invoice ", invoice_sent( $dir_invoices, $invoice, $De_l_adresse_email ), "\n" ; + if ( $write_invoices and ! invoice_sent( $dir_invoices, $invoice, $De_l_adresse_email ) ) { + write_tex_variables_file( $dir_invoices, $invoice, $Date, $tex_variables ) ; + } + +} + +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 of all, I'm sorry for the delay in getting back to you. + +You'll find in the attachment 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. + +Should you need a hardcopy of this invoice, +I'll send it to you upon request by regular mail. + +As the law requires, 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 +you will also find in the attachment. + +You can check I (Gilles LAMIRAL) really did generate +this invoice with the following command line: + + gpg --verify facture_imapsync-${invoice}.pdf.asc facture_imapsync-${invoice}.pdf + +or any other gpg graphical tool. + +Once more, thank you for buying and using imapsync. + +Any feedback is welcome. + + +-- +Best Regards, 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 invoice_sent { + + my ( $dir_invoices, $invoice, $email_address ) = @_ ; + + return( 1 ) if ( -f "$dir_invoices/$invoice/SENT_TO_$email_address" ) ; + return( 0 ) ; + +} + +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/W/paypal_reply/paypal_bilan_1.33 b/W/paypal_reply/paypal_bilan_1.33 new file mode 100755 index 0000000..8b45716 --- /dev/null +++ b/W/paypal_reply/paypal_bilan_1.33 @@ -0,0 +1,1008 @@ +#!/usr/bin/perl + +# $Id: paypal_bilan,v 1.33 2011/06/12 11:58:45 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_HT_EUR_sup = 0 ; +my $total_TVA_EUR_sup = 0 ; + +my $total_eur_received = 0 ; +my $total_eur_invoice = 0 ; +my $nb_invoice = 0 ; +my $nb_invoice_refund = 0 ; +my $nb_invoice_suspended = 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 %invoice_suspended ; +my $write_invoices = 0 ; +my $avoid_numbers ; + +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, + 'avoid_numbers' => \$avoid_numbers, +); + +my @files = @ARGV ; +my %action_of_invoice ; + +my @invoices = split( /\s+/, $invoices ) if $invoices ; +my @avoid_numbers = split( /\s+/, $avoid_numbers ) if $avoid_numbers ; +my %avoid_numbers ; + +@avoid_numbers{ @avoid_numbers } = ( ) if @avoid_numbers ; + +#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, $Titre_de_l_objet ) + = @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', "Titre de l'objet") } ; + #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, $Titre_de_l_objet ) ; + + # index by invoice number + $action_of_invoice{ $action->{ 'invoice' } } = $action ; + } + delete $action_of_invoice{ 'NONE' } ; +} + +my $last_invoice = $first_invoice + $nb_invoice -1 ; +@invoices = ( $first_invoice .. $last_invoice ) if ( ! @invoices ) ; + +my @invoice_sent ; +my %invoice_sent ; +my @invoice_not_sent ; +my %invoice_not_sent ; + +foreach my $invoice ( @invoices ) { + + my $action = $action_of_invoice{ $invoice } ; + my $email_address = $action->{ "De l'adresse email" } ; + + my $invoice_sent = invoice_sent( $dir_invoices, $invoice, $email_address ) ; + #print "$invoice $invoice_sent\n" ; + + if ( $invoice_sent ) { + $invoice_sent{ $invoice }++ ; + }else{ + $invoice_not_sent{ $invoice }++ ; + build_invoice( $invoice ) ; + } +} + +@invoice_sent = sort { $a <=> $b } keys( %invoice_sent ) ; +my $nb_invoice_sent = scalar( @invoice_sent ) ; +@invoice_not_sent = sort { $a <=> $b } keys( %invoice_not_sent ) ; + +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_HT_EUR_sup = sprintf('%2.f', $total_HT_EUR_sup) ; +$total_TVA_EUR_sup = sprintf('%2.f', $total_TVA_EUR_sup) ; + +$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 "EUR total HT sup $total_HT_EUR_sup\n" ; +print "EUR total TVA sup $total_TVA_EUR_sup\n" ; +print "Nb invoice $nb_invoice ( from $first_invoice to $last_invoice )\n" ; +print "Nb invoice refund $nb_invoice_refund\n" ; +print "Nb invoice suspended $nb_invoice_suspended\n" ; +print "Nb invoice sent $nb_invoice_sent\n" ; +print "Have to send invoices @invoice_not_sent\n" if ( @invoice_not_sent ) ; + +print "$total_eur != $total_HT_EUR_exo + $total_HT_EUR_ass + $total_TVA_EUR + $total_HT_EUR_sup + $total_TVA_EUR_sup\n" +if ( $total_eur != $total_HT_EUR_exo + $total_HT_EUR_ass + $total_TVA_EUR + $total_HT_EUR_sup + $total_TVA_EUR_sup ) ; + +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, $Titre_de_l_objet ) = @_ ; + + $debug and print( "-" x 60, "\n", + "[$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] ", + "[$Devise] [$Hors_taxe_paypal] [$Montant] [$Numero_davis_de_reception] [$Solde]\n", + "[$Pays] [$Nom_Option_1] [$Valeur_Option_1] [$Titre_de_l_objet]\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 ) ; + my( $montant_HT_EUR_sup, $montant_TVA_EUR_sup ) ; + + if ( $bnc ) { + $MontantEUR = $Montant ; + $MontantEUR = sprintf( "%.4f", $Montant/$usdeur ) if ($Devise eq 'USD') ; + print( "\n", "=" x 60, "\n" ) ; + print( "[$Date] [$Nom] [$Type] [$Etat] [$Devise] [$Hors_taxe_paypal] [$Montant] [EUR $MontantEUR]\n", + "[$Pays] [$Nom_Option_1] [$Valeur_Option_1] [$Titre_de_l_objet]\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, $montant_HT_EUR_sup, $montant_TVA_EUR_sup ) + = tva_line( $Devise, $Montant2_usd, $Pays, $Nom_Option_1, $Valeur_Option_1, $Titre_de_l_objet ) ; + $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, $montant_HT_EUR_sup, $montant_TVA_EUR_sup ) + = tva_line( $Devise, $Montant2_eur, $Pays, $Nom_Option_1, $Valeur_Option_1, $Titre_de_l_objet ) ; + $total_HT_EUR_exo += $montant_HT_EUR_exo ; + $total_HT_EUR_ass += $montant_HT_EUR_ass ; + $total_TVA_EUR += $montant_TVA_EUR ; + $total_HT_EUR_sup += $montant_HT_EUR_sup ; + $total_TVA_EUR_sup += $montant_TVA_EUR_sup ; + + + $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 'Suspendu' eq $Etat + ) { + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $nb_invoice_suspended++; + $invoice_suspended{ $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, $Titre_de_l_objet ) ; + if ( $write_invoices and ! invoice_sent( $dir_invoices, $invoice, $De_l_adresse_email ) ) { + 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 $quantity = '1' ; + + my ( + $descriptionFR, + $descriptionEN, + $usageFR, + $usageEN, + ) + = description_stuff( $Titre_de_l_objet, $clientTypeEN ) ; + + my ( + $priceHT, + $tvaFR, + $tvaEN, + $priceTVA, + $priceTTC, + $messageTVAFR, + $messageTVAEN, + $priceTTCusd + ) + = tva_stuff( $clientTypeEN, $Pays, $Hors_taxe, $Devise, $Titre_de_l_objet ) ; + + my $object_type = object_type( $Titre_de_l_objet ) ; + + my ( $urlSrc, $urlExe ) = download_urls( $Date, $object_type ) ; + #print "ZZZ $object_type ( $urlSrc, $urlExe )\n" ; + + my $tex_variables = qq{ +%% Begin input from $0 +\\providecommand{\\invoiceNumber}{$invoice} +\\providecommand{\\clientName}{$Nom} +\\providecommand{\\clientEmail}{$De_l_adresse_email} +\\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{\\descriptionFR}{$descriptionFR} +\\providecommand{\\descriptionEN}{$descriptionEN} +\\providecommand{\\usageFR}{$usageFR} +\\providecommand{\\usageEN}{$usageEN} +\\providecommand{\\quantity}{$quantity} + +\\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 ; + + #print "$invoice ", invoice_sent( $dir_invoices, $invoice, $De_l_adresse_email ), "\n" ; + if ( $write_invoices and ! invoice_sent( $dir_invoices, $invoice, $De_l_adresse_email ) ) { + write_tex_variables_file( $dir_invoices, $invoice, $Date, $tex_variables ) ; + } + +} + +sub description_stuff { + my ( $object, $clientTypeEN ) = @_ ; + + my $object_type = object_type( $object ) ; + + my ( $descriptionFR, $descriptionEN ) ; + if ( 'software' eq $object_type ) { + $descriptionFR = 'Logiciel imapsync. Tous droits cédés.' ; + $descriptionEN = '(Imapsync software. All rights conceded.)' ; + } + + my ( $usageFR, $usageEN ) ; + if ( 'professional' eq $clientTypeEN + and 'software' eq $object_type ) { + $usageFR = 'Usage à titre professionnel.' ; + $usageEN = '(professional usage.)' ; + } + + if ( 'individual' eq $clientTypeEN + and 'software' eq $object_type ) { + $usageFR = 'Usage à titre individuel.' ; + $usageEN = '(individual usage.)' ; + } + + if ( 'support' eq $object_type ) { + $descriptionFR = 'Support sur le logiciel imapsync.' ; + $descriptionEN = '(Imapsync support.)' ; + $usageFR = '' ; + $usageEN = '' ; + } + return( $descriptionFR, $descriptionEN, $usageFR, $usageEN ) ; +} + + + +sub object_type { + my $object = shift ; + + if ( 'imapsync' eq $object + or 'imapsync.exe' eq $object + or 'imapsync source' eq $object + or 'imapsync source code' eq $object + ) { + return( 'software' ) ; + }elsif ( 'imapsync support' eq $object ) { + return( 'support' ) ; + } +} + +sub build_email_message { + + my ( $date, $name, $email, $invoice, $objet ) = @_ ; + + my $object_type = object_type( $objet ) ; + + my $message_header_software = qq{X-imapsync: invoice $invoice for imapsync software +From: Gilles LAMIRAL +Bcc: gilles\@lamiral.info +Subject: [imapsync invoice] $invoice ($date) for imapsync software +Disposition-Notification-To: Gilles LAMIRAL +} ; + + my $message_header_support = qq{X-imapsync: invoice $invoice for imapsync support +From: Gilles LAMIRAL +Bcc: gilles\@lamiral.info +Subject: [imapsync invoice] $invoice ($date) for imapsync support +Disposition-Notification-To: Gilles LAMIRAL +} ; + + my $message_body_software = qq{ +Hello $name, + +First of all, I'm sorry for the delay in getting back to you. + +You'll find in the attachment 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. + +Should you need a hardcopy of this invoice, +I'll send it to you upon request by regular mail. + +As the law requires, 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 +you will also find in the attachment. + +You can check I (Gilles LAMIRAL) really did generate +this invoice with the following command line: + + gpg --verify facture_imapsync-${invoice}.pdf.asc facture_imapsync-${invoice}.pdf + +or any other gpg graphical tool. + +Once more, thank you for buying and using imapsync. + +Any feedback is welcome. + + +-- +Best Regards, 09 51 84 42 42 +Gilles Lamiral. France, Baulon (35580) 06 20 79 76 06 +} ; + + + my $message_body_support = qq{ +Hello $name, + +First of all, I'm sorry for the delay in getting back to you. + +You'll find in the attachment the invoice of imapsync support you bought ($date). +The invoice file is named facture_imapsync-${invoice}.pdf +This invoice is in PDF format, ready to be print. + +Should you need a hardcopy of this invoice, +I'll send it to you upon request by regular mail. + +As the law requires, 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 +you will also find in the attachment. + +You can check I (Gilles LAMIRAL) really did generate +this invoice with the following command line: + + gpg --verify facture_imapsync-${invoice}.pdf.asc facture_imapsync-${invoice}.pdf + +or any other gpg graphical tool. + +Once more, thank you for buying imapsync support. + +Any feedback is welcome. + +-- +Best Regards, 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. +} ; + + my ( $message_header, $message_body ) ; + if ( 'support' eq $object_type ) { + $message_header = $message_header_support ; + $message_body = $message_body_support ; + }elsif ( 'software' eq $object_type ) { + $message_header = $message_header_software ; + $message_body = $message_body_software ; + } + 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 invoice_sent { + + my ( $dir_invoices, $invoice, $email_address ) = @_ ; + + return( 1 ) if ( -f "$dir_invoices/$invoice/SENT_TO_$email_address" ) ; + return( 0 ) ; + +} + +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 ) ; + if ( ! -f "$dir_invoices/$invoice/imapsync_var_manual.tex" ) { + open( FILE, "> $dir_invoices/$invoice/imapsync_var_manual.tex") or die ; + print FILE "%% $0 created file +%% Can be used to override imapsync_var.tex definitions\n" ; + close( FILE ) ; + } + +} + +sub download_urls { + my $date_jjSmmSaaaa = shift ; + my $object_type = shift ; + + my $date_aaaa_mm_jj = date_aaaa_mm_jj( $date_jjSmmSaaaa ) ; + #print "$date_aaaa_mm_jj $date_jjSmmSaaaa $object_type\n" ; + my ( $urlSrc, $urlExe ) ; + + if ('2011_05_01' le $date_aaaa_mm_jj + and 'software' eq $object_type ) { + $urlSrc = 'http://ks.lamiral.info/imapsync/paypal_return.shtml' ; + $urlExe = '' ; + return( $urlSrc, $urlExe ) ; + } + + if ('2011_05_01' le $date_aaaa_mm_jj + and 'support' eq $object_type ) { + $urlSrc = 'http://ks.lamiral.info/imapsync/paypal_return_support.shtml' ; + $urlExe = '' ; + return( $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, $Titre_de_l_objet ) = @_ ; + my( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) = ( 0, 0, 0 ) ; + + my( $montant_HT_EUR_sup, $montant_TVA_EUR_sup ) = ( 0, 0 ) ; + + $Montant2 = $Montant2/$usdeur if 'USD' eq $Devise ; + + if ( 'imapsync' eq $Titre_de_l_objet + or 'imapsync.exe' eq $Titre_de_l_objet + or 'imapsync source' eq $Titre_de_l_objet + or 'imapsync source code' eq $Titre_de_l_objet + + ) { + if ( + ( 'imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) + or + ( 'France' eq $Pays ) + ) { + $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 ; + } + } + + if ( 'imapsync support' eq $Titre_de_l_objet ) { + #print "ZZZZ $Titre_de_l_objet $Montant2\n" ; + $montant_HT_EUR_sup = $Montant2 / 1.196 ; + $montant_TVA_EUR_sup = $Montant2 / 1.196 * 0.196 ; + } + + + return( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR, $montant_HT_EUR_sup, $montant_TVA_EUR_sup ) ; +} + + + +sub tva_stuff { + my( $clientTypeEN, $Pays, $Hors_taxe, $Devise, $Titre_de_l_objet ) = @_ ; + + 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 ) + or + ( 'imapsync support' eq $Titre_de_l_objet ) + ) { + $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/W/paypal_reply/paypal_build_invoices b/W/paypal_reply/paypal_build_invoices new file mode 100755 index 0000000..066d379 --- /dev/null +++ b/W/paypal_reply/paypal_build_invoices @@ -0,0 +1,101 @@ +#!/bin/sh + +# usage: sh paypal_build_invoices /g/var/paypal_invoices/??? + +lyx -e latex /home/gilles/public_html/AGIL/factures/000/facture_imapsync-000.lyx +cp /home/gilles/public_html/AGIL/factures/000/facture_imapsync-000.tex /g/var/paypal_invoices/ + +set -x +#/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 147 /g/paypal/paypal_2010_11_complet.csv +#/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 214 /g/paypal/paypal_2010_12_complet.csv +#/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 294 /g/paypal/paypal_2011_01_complet.csv +#/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 382 /g/paypal/paypal_2011_02_complet.csv +#/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 473 /g/paypal/paypal_2011_03_complet.csv +#/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 570 /g/paypal/paypal_2011_04_complet.csv +#/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 645 /g/paypal/paypal_2011_05_complet.csv +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 733 /g/paypal/paypal_2011_06_complet.csv +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 824 /g/paypal/paypal_2011_07_complet.csv +set +x + +# La totale +: || /g/public_html/imapsync/W/paypal_reply/paypal_bilan --bnc --debug \ + --first_in 147 --avoid_numbers '292 293 643 644 731 732' \ + /g/paypal/paypal_201?_??_complet.csv + +# 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` + + if ls SENT_TO_* 2>/dev/null ; then + echo "!!! Already sent " + continue + fi + + rm -f facture_imapsync-$bd.tex + cp -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/W/paypal_reply/paypal_build_reply b/W/paypal_reply/paypal_build_reply new file mode 100755 index 0000000..326e2d8 --- /dev/null +++ b/W/paypal_reply/paypal_build_reply @@ -0,0 +1,208 @@ +#!/usr/bin/perl + +# $Id: paypal_build_reply,v 1.16 2011/05/31 21:25:48 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, $object, + $url_source, $url_exe, $url, $release, $release_exe, +); + +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; + } +} + + +$release = firstline( '/g/public_html/imapsync/VERSION' ) ; +$release_exe = firstline( '/g/public_html/imapsync/VERSION_EXE' ) ; +my $path_last = firstline( '/g/public_html/imapsync/dist/path_last.txt' ) ; +$url_source = firstline( '/g/var/paypal_reply/url_source' ) ; +$url_exe = firstline( '/g/var/paypal_reply/url_exe' ) ; + +$url = "http://ks.lamiral.info/imapsync/dist/$path_last/" ; + +#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 :(.*)/ ); + $object = $1 ; + $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.16 2011/05/31 21:25:48 gilles Exp gilles $'; + +my $download_info = "You will find the latest imapsync.exe binary (release $release_exe) +and the latest imapsync source code (release $release) at the following link: +$url" ; + +my $next_releases ="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 soon)" ; + +my $thanks_software = "I thank you for buying and using imapsync, +I wish you successful transfers!" ; + +my $thanks_support = "I thank you for buying support and using imapsync, +I wish you successful transfers, I will help you to succeed." ; + +my $support_info = 'Now you have access to imapsync professional support. + +You can contact me (Gilles LAMIRAL) by email or phone. + +Email address: gilles.lamiral@laposte.net. +Professionnal phone number: +33 951 84 42 42 (France) +Mobile phone number: +33 620 79 76 06 (France). + +I can call you back for free in many countries on landline telephone numbers +and to mobile numbers in the United States and France. So do not hesitate +to send me a note if you need vocal support.' ; + + +my $text_software = "$download_info\n +$next_releases\n +You will receive an invoice soon.\n +$thanks_software" ; + +my $text_support = "$support_info\n +You will receive an invoice soon.\n +$thanks_support" ; + +my $subject_software = "[imapsync download] imapsync release $release [$email]" ; + +my $subject_support = "[imapsync support] imapsync release $release [$email]" ; + +my $subject ; + +my $text ; +if ( 'imapsync support' eq $object ) { + $text = $text_support ; + $subject = $subject_support ; +}else{ + $text = $text_software ; + $subject = $subject_software ; +} + + +my $message = < +To: <$email> +Bcc: Gilles LAMIRAL <$address>, <$address2> +Subject: $subject + +Hello $name, + +$text + +$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] [$object]\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/W/paypal_reply/paypal_functions b/W/paypal_reply/paypal_functions new file mode 100755 index 0000000..6565c6d --- /dev/null +++ b/W/paypal_reply/paypal_functions @@ -0,0 +1,234 @@ +#!/bin/sh + +# $Id: paypal_functions,v 1.17 2011/05/31 21:26:24 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 +} + +debug_mode() { + #return 0 + return 1 +} + +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" + debug_mode && echo "paypal_send $f" + 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 + 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/W/paypal_reply/paypal_imapget b/W/paypal_reply/paypal_imapget new file mode 100755 index 0000000..ac56213 --- /dev/null +++ b/W/paypal_reply/paypal_imapget @@ -0,0 +1,134 @@ +#!/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/W/paypal_reply/paypal_mimeexplode b/W/paypal_reply/paypal_mimeexplode new file mode 100755 index 0000000..afba608 --- /dev/null +++ b/W/paypal_reply/paypal_mimeexplode @@ -0,0 +1,187 @@ +#!/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/W/paypal_reply/paypal_run_dev b/W/paypal_reply/paypal_run_dev new file mode 100755 index 0000000..0c35253 --- /dev/null +++ b/W/paypal_reply/paypal_run_dev @@ -0,0 +1,30 @@ +#!/bin/sh + +# $Id: paypal_run_dev,v 1.5 2011/05/20 10:50:05 gilles Exp gilles $ + +set -e +#set -x + + +# Add path to commands at home +PATH=$PATH:/g/public_html/imapsync/W/paypal_reply +PERL5LIB=/g/public_html/imapsync/Mail-IMAPClient-3.28/lib +export PERL5LIB + +test -f /g/public_html/imapsync/W/paypal_reply/paypal_functions \ +&& . /g/public_html/imapsync/W/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/W/paypal_reply/paypal_run_laposte b/W/paypal_reply/paypal_run_laposte new file mode 100755 index 0000000..d02a2ed --- /dev/null +++ b/W/paypal_reply/paypal_run_laposte @@ -0,0 +1,30 @@ +#!/bin/sh + +# $Id: paypal_run_laposte,v 1.4 2011/05/20 10:48:01 gilles Exp gilles $ + +set -e +#set -x + + +# Add path to commands at home +PATH=$PATH:/g/public_html/imapsync/W/paypal_reply +PERL5LIB=/g/public_html/imapsync/Mail-IMAPClient-3.28/lib +export PERL5LIB + +test -f /g/public_html/imapsync/W/paypal_reply/paypal_functions \ +&& . /g/public_html/imapsync/W/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/W/paypal_reply/paypal_run_petite b/W/paypal_reply/paypal_run_petite new file mode 100755 index 0000000..5ed89d0 --- /dev/null +++ b/W/paypal_reply/paypal_run_petite @@ -0,0 +1,30 @@ +#!/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/W/paypal_reply/paypal_send b/W/paypal_reply/paypal_send new file mode 100755 index 0000000..185ca40 --- /dev/null +++ b/W/paypal_reply/paypal_send @@ -0,0 +1,71 @@ +#!/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 '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + echo "!!! Already SENT_TO_$email" + echo '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + } + mailq + 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/W/paypal_reply/texput.log b/W/paypal_reply/texput.log new file mode 100644 index 0000000..9a96b6b --- /dev/null +++ b/W/paypal_reply/texput.log @@ -0,0 +1,20 @@ +This is pdfTeXk, Version 3.141592-1.40.3 (Web2C 7.5.6) (format=pdflatex 2010.5.16) 3 MAY 2011 20:33 +entering extended mode + %&-line parsing enabled. +**facture_imapsync-700.tex + +! Emergency stop. +<*> facture_imapsync-700.tex + +End of file on the terminal! + + +Here is how much of TeX's memory you used: + 3 strings out of 95086 + 127 string characters out of 1183255 + 45034 words of memory out of 1500000 + 3277 multiletter control sequences out of 10000+50000 + 3640 words of font info for 14 fonts, out of 1200000 for 2000 + 28 hyphenation exceptions out of 8191 + 0i,0n,0p,1b,6s stack positions out of 5000i,500n,6000p,200000b,5000s +! ==> Fatal error occurred, no output PDF file produced! diff --git a/W/t/01_connect b/W/t/01_connect new file mode 100755 index 0000000..25bda46 --- /dev/null +++ b/W/t/01_connect @@ -0,0 +1,15 @@ +#!/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/W/t/01_connect.229.dump b/W/t/01_connect.229.dump new file mode 100644 index 0000000..503bc92 --- /dev/null +++ b/W/t/01_connect.229.dump @@ -0,0 +1,16 @@ +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/W/t/02_append_string b/W/t/02_append_string new file mode 100755 index 0000000..d470fe9 --- /dev/null +++ b/W/t/02_append_string @@ -0,0 +1,35 @@ +#!/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/W/t/03_message_to_file b/W/t/03_message_to_file new file mode 100755 index 0000000..7be09bf --- /dev/null +++ b/W/t/03_message_to_file @@ -0,0 +1,53 @@ +#!/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/W/t/03_message_to_file.dump b/W/t/03_message_to_file.dump new file mode 100644 index 0000000..b01e3ee --- /dev/null +++ b/W/t/03_message_to_file.dump @@ -0,0 +1,91 @@ +$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/W/t/04_parse_headers b/W/t/04_parse_headers new file mode 100755 index 0000000..0280a65 --- /dev/null +++ b/W/t/04_parse_headers @@ -0,0 +1,21 @@ +#!/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/W/t/05_parse_headers_ssl b/W/t/05_parse_headers_ssl new file mode 100755 index 0000000..bf761ed --- /dev/null +++ b/W/t/05_parse_headers_ssl @@ -0,0 +1,26 @@ +#!/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/W/t/06_parse_headers_ssl_titi b/W/t/06_parse_headers_ssl_titi new file mode 100755 index 0000000..4ec32de --- /dev/null +++ b/W/t/06_parse_headers_ssl_titi @@ -0,0 +1,26 @@ +#!/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/W/tools/wonko_ruby_imapsync b/W/tools/wonko_ruby_imapsync new file mode 100644 index 0000000..014f26e --- /dev/null +++ b/W/tools/wonko_ruby_imapsync @@ -0,0 +1,116 @@ +#!/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' + diff --git a/imapsync b/imapsync index 8f08011..b809719 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.446 $ +$Revision: 1.452 $ =head1 SYNOPSIS @@ -342,7 +342,7 @@ Failure stories reported with the following 3 imap servers: Patient and confident testers are welcome. - Imail 7.04 (maybe). -Success stories reported with the following 41 imap servers +Success stories reported with the following 44 imap servers (software names are in alphabetic order): - 1und1 H mimap1 84498 [host1] @@ -379,8 +379,10 @@ Success stories reported with the following 41 imap servers - 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, 11.03 [host1] + - Kerio 7.2.0P1 [host1] - MailEnable 4.23 [host1] [host2] - - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform), 12 [host2] + - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform), 12 [host2], + 12.0.3 [host1] - 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], 6.5 [host1], Exchange 2007 SP1 (with Update Rollup 2), @@ -405,7 +407,7 @@ Success stories reported with the following 41 imap servers (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 + - VMS, 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, Zimbra 5.0.24_GA_3356.RHEL4 [host1], 5.5, 6.x @@ -498,7 +500,7 @@ Entries for imapsync: Feedback (good or bad) will often be welcome. -$Id: imapsync,v 1.446 2011/05/31 09:11:18 gilles Exp gilles $ +$Id: imapsync,v 1.452 2011/07/11 00:29:06 gilles Exp gilles $ =cut @@ -560,6 +562,7 @@ my( $syncacls, $fastio1, $fastio2, $maxsize, $minsize, $maxage, $minage, + $search, $skipheader, @useheader, $skipsize, $allowsizemismatch, $foldersizes, $buffersize, $delete, $delete2, @@ -611,7 +614,7 @@ my( # global variables initialisation -$rcs = '$Id: imapsync,v 1.446 2011/05/31 09:11:18 gilles Exp gilles $ '; +$rcs = '$Id: imapsync,v 1.452 2011/07/11 00:29:06 gilles Exp gilles $ '; $total_bytes_transferred = 0; $total_bytes_skipped = 0; @@ -687,8 +690,6 @@ if ( $fast ) { # 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"; @@ -868,7 +869,7 @@ Use --nousecache or suppress the --max* --min* options\n" ) ; my $imap1 = (); my $imap2 = (); -$timestart = time(); +$timestart = time( ); $timebefore = $timestart; $debugimap1 and print "Host1 connection\n"; @@ -1466,6 +1467,7 @@ sub modules_VERSION { foreach my $module (qw( Mail::IMAPClient IO::Socket +IO::Socket::INET IO::Socket::SSL Digest::MD5 Digest::HMAC_MD5 @@ -1803,8 +1805,8 @@ sub banner_imapsync { my @argv_copy = @_; my $banner_imapsync = join("", '$RCSfile: imapsync,v $ ', - '$Revision: 1.446 $ ', - '$Date: 2011/05/31 09:11:18 $ ', + '$Revision: 1.452 $ ', + '$Date: 2011/07/11 00:29:06 $ ', "\n",localhost_info(), "\n", "Command line used:\n", "$0 ", command_line_nopassword(@argv_copy), "\n", @@ -2407,16 +2409,16 @@ sub tests_permanentflags { } sub permanentflags { - my @lines = @_; + my @lines = @_ ; foreach my $line (@lines) { - if ($line =~ m{\[PERMANENTFLAGS \(([^)]+?)\)\]}) { - $debug and print "permanentflags: $line"; - my $permanentflags = $1; - if ($permanentflags =~ m{\\\*}) { - $permanentflags = ''; + if ( $line =~ m{\[PERMANENTFLAGS \(([^)]+?)\)\]} ) { + ( $debugflags or $debug ) and print "permanentflags: $line" ; + my $permanentflags = $1 ; + if ( $permanentflags =~ m{\\\*} ) { + $permanentflags = '' ; } - return($permanentflags); + return($permanentflags) ; }; } } @@ -2496,36 +2498,44 @@ sub select_msgs { my ( $imap, $msgs_all_hash_ref ) = @_ ; my ( @msgs, @msgs_all, @max, @min, @union, @inter ) ; - + # Need to have the whole list in msgs_all_hash_ref + # without calling messages() several times. if ( defined( $msgs_all_hash_ref ) - or ( ! defined( $maxage ) and ! defined( $minage ) ) + or ( ! defined( $maxage ) and ! defined( $minage ) and ! defined( $search ) ) ) { - @msgs = $imap->messages() ; + @msgs = $imap->messages() ; if ( defined( $msgs_all_hash_ref ) ) { - @msgs_all = @msgs ; + @msgs_all = @msgs ; @{ $msgs_all_hash_ref }{ @msgs_all } = () ; } - if ( ! defined( $maxage ) and ! defined( $minage ) ) { + # return all messages + if ( ! defined( $maxage ) and ! defined( $minage ) and ! defined( $search ) ) { return( @msgs ) ; } } - if (defined($maxage)) { - @max = $imap->sentsince(time - 86400 * $maxage); + + if ( defined( $search ) ) { + @msgs = $imap->search( $search ) ; + return( @msgs ) ; + } + + if ( defined( $maxage ) ) { + @max = $imap->sentsince( $timestart - 86400 * $maxage ) ; } - if (defined($minage)) { - @min = $imap->sentbefore(time - 86400 * $minage); + if ( defined($minage ) ) { + @min = $imap->sentbefore( $timestart - 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); + 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}; + if ( $minage <= $maxage ) { @msgs = @inter ; last SWITCH } ; # just exclude messages between - if ($minage > $maxage) {@msgs = @union; last SWITCH}; + if ( $minage > $maxage ) { @msgs = @union ; last SWITCH } ; } return(@msgs); @@ -3315,6 +3325,7 @@ sub get_options { "minsize=i" => \$minsize, "maxage=i" => \$maxage, "minage=i" => \$minage, + "search=s" => \$search, "foldersizes!" => \$foldersizes, "dry!" => \$dry, "expunge!" => \$expunge, @@ -3551,7 +3562,7 @@ sub check_last_release { } sub imapsync_version { - my $rcs = '$Id: imapsync,v 1.446 2011/05/31 09:11:18 gilles Exp gilles $ '; + my $rcs = '$Id: imapsync,v 1.452 2011/07/11 00:29:06 gilles Exp gilles $ '; $rcs =~ m/,v (\d+\.\d+)/; my $VERSION = ($1) ? $1: "UNKNOWN"; return($VERSION); @@ -3731,17 +3742,17 @@ Several options are mandatory. --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 +--sep1 : host1 separator in case namespace is not supported. +--sep2 : idem for host2. +--delete : Deletes 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. + 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): + host1 server. Useful for backup or pre-sync. +--delete2folders : Delete folders in host2 that are not in host1 server. + For safety, first try it like this (it is safe): --delete2folders --dry --justfolders --nofoldersizes --delete2foldersonly : delete only folders matching regex. --delete2foldersbutnot : do not delete folders matching regex. @@ -3751,8 +3762,8 @@ Several options are mandatory. 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. +--expunge1 : Expunge messages on host1 after messages transfer. +--expunge2 : Expunge messages on host2 after messages transfer. --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. @@ -3772,17 +3783,10 @@ Several options are mandatory. 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.*' +--search : Select messages returned by this IMAP SEARCH command --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 @@ -3812,14 +3816,6 @@ Several options are mandatory. credentials, then exit. --justfolders : just do things about folders (ignore messages). --fast : be faster, equivalent to --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" @@ -3839,6 +3835,29 @@ $thank EOF } +sub usage_complete { + print < : Don't take into account header keyword + matching ex: --skipheader 'X.*' + +--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 + +--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. + +EOF +} sub memory_consumption { # memory consumed by imapsync until now in bytes @@ -3855,7 +3874,7 @@ sub memory_consumption_of_pids { @val = memory_consumption_of_pids_win32(@PID); }else{ # Unix - my @ps = qx{ ps -o vsz @PID }; + my @ps = qx{ ps -o vsz -p @PID }; shift @ps; # First line is column name "VSZ" chomp @ps; # convert to diff --git a/index.shtml b/index.shtml index 666a629..fae8ee8 100644 --- a/index.shtml +++ b/index.shtml @@ -5,7 +5,7 @@ Imapsync: an IMAP migration tool ( release <!--#exec cmd="cat VERSION"--> ) - + @@ -71,13 +71,22 @@ where the user plays independently on both sides. Use offlineimap

New features or bugfixes since previous releases:

    + +
  • 1.452
    • +
  • New feature: Added --search option allowing to select messages with the powerful IMAP SEARCH command. +
  • Bugfix: Date reference to select messages with --maxdate --mindate is the beginning of imapsync run now. +
  • Bugfix: Fixed ps call to work with Solaris 10. Thanks to Daniel Rohde. +
  • Success: Kerio 7.2.0P1 success story. +
  • Success: MDaemon 12.0.3 success story. + +
  • 1.446
  • Bugfix: Better --idatefromheader behavior (thank to Dax Kelson patches).
  • Usability: Now --delete2 sets --uidexpunge2 instead of --expunge2 if possible.
  • Usability: Adapted the usage output multiline character to Unix or Win, \ or ^
    • -
  • Bugfix: Avoid a "not a number" warning when size is null.
    • +
  • Bugfix: Avoid a "not a number" warning when size is null.
  • Bugfix: Added "Date" in the default --useheader list. It is ("Message-Id", "Message-ID", "Date")
    • -
  • Bugfix: allows bad header beginning with a blank character.
    • +
  • Bugfix: allows bad header beginning with a blank character.
  • 1.434
  • Bugfix: Changed the way imapsync knows whether a folder exists or not. Exchange might be happy and stop deconnecting for this reason.
    • @@ -153,6 +162,7 @@ The Perl imapsync source code will run anywhere a Perl interpreter can

    You will receive a download link just after the payment.
    +One year of imapsync updates without extra payment.
    30 days money-back guarantee!

    Buy standalone imapsync.exe for win32

    @@ -183,6 +193,7 @@ name="submit" alt="PayPal - The safer, easier way to pay online!"/>

    You will receive a download link just after the payment.
    +One year of imapsync updates without extra payment.
    30 days money-back guarantee!

    This document last modified on -($Id: index.shtml,v 1.70 2011/05/31 16:43:38 gilles Exp gilles $) +($Id: index.shtml,v 1.75 2011/07/11 01:42:17 gilles Exp gilles $)

    diff --git a/lfo.htaccess b/lfo.htaccess new file mode 100644 index 0000000..8942bac --- /dev/null +++ b/lfo.htaccess @@ -0,0 +1,3 @@ + +Redirect Permanent /prj/imapsync/ http://ks.lamiral.info/imapsync/ + diff --git a/memo b/memo index 2f1ddcb..1f27723 100644 --- a/memo +++ b/memo @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: memo,v 1.31 2011/05/07 02:30:54 gilles Exp gilles $ +# $Id: memo,v 1.32 2011/07/11 01:06:49 gilles Exp gilles $ software_version() { @@ -24,7 +24,23 @@ tail -f /usr/local/apache/logs/access_log|cat -n|grep prj/imapsync/VERSION|cat - EOFF } -statistics_VERSION() { +statistics_ks() { + +cat < stats_imapsync_2011_${month}.runs cat stats_imapsync_2011_${month}.runs } - - - } +statistics_VERSION_ks() { + +TMPDIR=. +export TMPDIR + +echo statistics_VERSION_getstats +statistics_VERSION_getstats() { + ( + cd /home/imapsync/imapsync_stats + for f in /var/log/apache2/access.log_????????.gz ; do + b=`basename "$f" .gz` + echo "$b" + test -f ${b}.imapsync_VERSION && continue + echo NOT DONE ${b}.imapsync_VERSION + zgrep -h /prj/imapsync/VERSION "$f" > ${b}.imapsync_VERSION + done + ) +} + +echo statistics_VERSION_monthly_ip +statistics_VERSION_monthly_ip() { + month=$1 + ( + cd /home/imapsync/imapsync_stats + cut -d ' ' -f 1,12,13,18,19 access.log_2011${month}??.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 + ( + cd /home/imapsync/imapsync_stats + 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 + ( + cd /home/imapsync/imapsync_stats + # test -f stats_imapsync_2011_${month}.runs || + wc -l access.log_2011${month}??.imapsync_VERSION > stats_imapsync_2011_${month}.runs + cat stats_imapsync_2011_${month}.runs + ) +} +} + + niouzes_compil() { ( cd /g/public_html/www.linux-france.org/html/ diff --git a/test_exe.bat b/test_exe.bat index 14de74f..45d960f 100755 --- a/test_exe.bat +++ b/test_exe.bat @@ -4,8 +4,8 @@ cd C:\msys\1.0\home\Admin\imapsync perl -mMail::IMAPClient -mDigest::MD5 -mTerm::ReadKey -mIO::Socket::SSL -mFile::Spec -mDigest::HMAC_MD5 -e '' .\imapsync.exe -.\imapsync.exe --host1 p --user1 toto --passfile1 secret.toto --host2 p --user2 titi --passfile2 secret.titi --noauthmd5 --ssl1 --ssl2 --justconnect -.\imapsync.exe --host1 p --user1 toto --passfile1 secret.toto --host2 p --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 -.\imapsync.exe --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 --folder INBOX -.\imapsync.exe --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi --noauthmd5 --delete2 --expunge2 --folder INBOX --usecache +.\imapsync.exe --host1 p --user1 toto --passfile1 secret.toto --host2 p --user2 titi --passfile2 secret.titi --ssl1 --ssl2 --justconnect +.\imapsync.exe --host1 p --user1 toto --passfile1 secret.toto --host2 p --user2 titi --passfile2 secret.titi --ssl1 --ssl2 --delete2 +.\imapsync.exe --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi --ssl1 --ssl2 --delete2 --folder INBOX +.\imapsync.exe --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi --ssl1 --ssl2 --delete2 --folder INBOX --usecache diff --git a/tests.sh b/tests.sh index dda382d..795b086 100644 --- a/tests.sh +++ b/tests.sh @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: tests.sh,v 1.168 2011/05/31 16:42:38 gilles Exp gilles $ +# $Id: tests.sh,v 1.170 2011/07/11 01:03:48 gilles Exp gilles $ # Example 1: # CMD_PERL='perl -I./Mail-IMAPClient-3.25/lib' sh -x tests.sh @@ -354,7 +354,7 @@ ll_folderrec() { --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ - --folderrec INBOX.yop --debugimap --justfolders + --folderrec INBOX.yop --justfolders } ll_folderrec_star() { @@ -728,8 +728,6 @@ ll_noauthmd5() } - - ll_maxage() { can_send && sendtestmessage @@ -741,6 +739,54 @@ ll_maxage() --maxage 1 } +ll_maxage_0() +{ + can_send && sendtestmessage + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --maxage 0 --folder INBOX +} + + +ll_search_ALL() +{ + can_send && sendtestmessage + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --search 'ALL' --folder INBOX +} + +ll_search_FLAGGED() +{ + can_send && sendtestmessage + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --search 'FLAGGED' --folder INBOX +} + +ll_search_SENTSINCE() +{ + can_send && sendtestmessage + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --search 'SENTSINCE 11-Jul-2011' --folder INBOX +} + + + + ll_maxage_nonew() { can_send && sendtestmessage @@ -911,23 +957,52 @@ ll_exclude_INBOX() ll_regextrans2() { - if can_send; then - #echo3 Here is plume - sendtestmessage - else - : - fi - $CMD_PERL ./imapsync \ - --host1 $HOST1 --user1 tata \ - --passfile1 ../../var/pass/secret.tata \ - --host2 $HOST2 --user2 titi \ - --passfile2 ../../var/pass/secret.titi \ - --justfolders \ - --nofoldersize \ - --regextrans2 's/yop/yoX/' \ - --folder 'INBOX.yop.yap' + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --justfolders \ + --nofoldersize \ + --regextrans2 's/yop/yoX/' \ + --folder 'INBOX.yop.yap' } +ll_regextrans2_downcase() +{ +# lowercase the last basename part +# [INBOX.yop.YAP] -> [INBOX.yop.yap] using re [s/(.*)\Q${h1_sep}\E(.+)$/$1${h2_sep}\L$2\E/] +# [INBOX.yop.YAP] -> [INBOX.yop.yap] + + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --justfolders \ + --nofoldersize \ + --regextrans2 's/(.*)\Q${h1_sep}\E(.+)$/$1${h2_sep}\L$2\E/' \ + --folder 'INBOX.yop.YAP' --justfolders --debug --dry +} + +ll_regextrans2_ucfirst() +{ +# lowercase the last basename part +# [INBOX.yop.YAP] -> [INBOX.yop.yap] using re [s/(.*)\Q${h1_sep}\E(.+)$/$1${h2_sep}\L$2\E/] +# [INBOX.yop.YAP] -> [INBOX.yop.yap] + + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --justfolders \ + --nofoldersize \ + --regextrans2 's/(.*)\Q${h1_sep}\E(.)(.+)$/$1${h2_sep}\u$2\L$3\E/' \ + --folder 'INBOX.yop.YAP' --justfolders --debug --dry +} + + ll_regextrans2_slash() { $CMD_PERL ./imapsync \ @@ -1137,6 +1212,20 @@ ll_regex_flag3() echo 'rm -f /home/vmail/titi/.yop.yap/cur/*' } +ll_regex_flag4() +{ + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --folder INBOX.yop.yap --nofoldersizes \ + --regexflag 's/\$label1/\\label1/g' --debugflags + + echo 'sudo rm -f /home/vmail/titi/.yop.yap/cur/*' +} + + ll_regex_flag_keep_only() { $CMD_PERL ./imapsync \ @@ -1675,6 +1764,23 @@ ll_usecache() { --folder INBOX } +ll_usecache_all() { + if can_send; then + sendtestmessage + else + : + fi + + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --usecache --nofoldersizes +} + + + ll_nousecache() { if can_send; then @@ -1767,11 +1873,22 @@ ll_useuid() --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ --folder INBOX.useuid \ - --delete2 --expunge2 \ + --delete2 \ --useuid - echo 'rm /home/vmail/titi/.yop.yap/cur/*' } +ll_useuid_all() +{ + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --delete2 --useuid --nofoldersizes +} + + + ll_useuid_nousecache() { $CMD_PERL ./imapsync \ diff --git a/tmp/cache/G1/G2/100_200 b/tmp/cache/G1/G2/100_200 new file mode 100644 index 0000000..e69de29 diff --git "a/tmp/cache/rr\\uee/177_377" "b/tmp/cache/rr\\uee/177_377" new file mode 100644 index 0000000..e69de29 diff --git a/tmp/imapsync_1404 b/tmp/imapsync_1404 new file mode 100755 index 0000000..f75d4b5 --- /dev/null +++ b/tmp/imapsync_1404 @@ -0,0 +1,4830 @@ +#!/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/tmp/imapsync_1434 b/tmp/imapsync_1434 new file mode 100755 index 0000000..516cc9c --- /dev/null +++ b/tmp/imapsync_1434 @@ -0,0 +1,5273 @@ +#!/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.434 $ + +=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] [--nouid2] + [--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. + + - the run context. Do you run imapsync.exe, a unix binary or the perl script imapsync. + + - operating system running imapsync. + + - virtual software context (vmware, xen etc.) + + - operating systems on both sides and the third side in case + you run imapsync on a foreign host from the both. + +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) but MailEnable 4.23 is supported. + - DBMail 0.9, 2.0.7 (GPL). But DBMail 1.2.1 is supported. + Patient and confident testers are welcome. + - Imail 7.04 (maybe). + +Success stories reported with the following 41 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 + - Gimap (Gmail imap) + - 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, 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), 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], 6.5 [host1], Exchange 2007 SP1 (with Update Rollup 2), + Exchange2007-EP-SP2, + Exchange 2010 RTM (Release to Manufacturing) [host2], + Exchange 2010 SP1 RU2[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, + Zimbra 5.0.24_GA_3356.RHEL4 [host1], 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 + isync : http://isync.sourceforge.net/ + pop2imap : http://www.linux-france.org/prj/pop2imap/ + + +Feedback (good or bad) will often be welcome. + +$Id: imapsync,v 1.434 2011/05/16 07:16:19 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, $debugcontent, $debugflags, + $debugLIST, $debugsleep, + $nb_errors, + $host1, $host2, $port1, $port2, + $user1, $user2, $domain1, $domain2, + $password1, $password2, $passfile1, $passfile2, + @folder, @include, @exclude, @folderrec, + $prefix1, $prefix2, + @regextrans2, @regexmess, @regexflag, + $flagsCase, + $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, + $relogin1, $relogin2, + $tests, $test_builder, $tests_debug, + $allow3xx, $justlogin, + $tmpdir, + $releasecheck, + $max_msg_size_in_bytes, + $modules_version, + $delete2folders, $delete2foldersonly, $delete2foldersbutnot, + $usecache, $debugcache, + $wholeheaderifneeded, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess, +); + +# main program + +# global variables initialisation + +$rcs = '$Id: imapsync,v 1.434 2011/05/16 07:16:19 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; + +$wholeheaderifneeded = defined( $wholeheaderifneeded ) ? $wholeheaderifneeded : 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 ; + $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 ( $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"; + $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", "Message-ID" ) unless ( @useheader ) ; + +my %useheader ; + +# Make a hash %useheader of each --useheader 'key' in uppercase +@useheader{ map( { uc( $_ ) } @useheader ) } = ( ) ; + +my %useheaderclassic ; +@useheaderclassic{ qw(MESSAGE-ID DATE) } = ( ) ; + +#require Data::Dumper ; +#print Data::Dumper->Dump( [ \%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; + +if ( ! ( 1 + or ( $maxsize + or $minsize + or $maxage + or $minage ) + and $usecache + and ! $delete ) ) { + die_clean( +"Problem --usecache can not be used safely with options --maxsize--minsize --maxage --minage +Use --nousecache or suppress the --max* --min* options\n" ) ; +} + +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, $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, $split2); + + +$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); + +# +# 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_wanted, %h2_folders_from_1_wanted, +@h2_folders_from_1_all, %h2_folders_from_1_all, +); + + +# 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_wanted{$h2_fold}++; +} +@h2_folders_from_1_wanted = sort keys(%h2_folders_from_1_wanted); + +foreach my $h1_fold (@h1_folders_all) { + my $h2_fold; + $h2_fold = imap2_folder_name($h1_fold); + $h2_folders_from_1_all{$h2_fold}++; +} +#@h2_folders_from_1_all = sort keys(%h2_folders_from_1_all); + + +if ($foldersizes) { + foldersizes( "Host1", $imap1, @h1_folders_wanted ) ; + foldersizes( "Host2", $imap2, @h2_folders_from_1_wanted ) ; + sleep( 2 ) ; +} + + +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); + #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, $h1_fold ) 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); + $debug and print "permanentflags: $permanentflags2\n" ; + if ( $expunge or $expunge1 ){ + 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_all_hash_ref = { } ; + my @h1_msgs = select_msgs( $imap1, $h1_msgs_all_hash_ref ); + + ( $debug or $debugLIST ) and print "Host1 LIST: ", scalar( @h1_msgs ), " messages [@h1_msgs]\n" ; + #( $debug or $debugLIST ) and print "Host1 LIST: ", scalar( @$h1_msgs_all_ref ), " messages [@$h1_msgs_all_ref]\n" ; + # internal dates on host2 are after the ones on host1 + # normally... + + my $h2_msgs_all_hash_ref = { } ; + my @h2_msgs = select_msgs( $imap2, $h2_msgs_all_hash_ref ) ; + + ( $debug or $debugLIST ) and print "Host2 LIST: ", scalar(@h2_msgs), " messages [@h2_msgs]\n"; + #( $debug or $debugLIST ) and print "Host2 LIST ALL: ", scalar( keys %$h2_msgs_all_hash_ref ), " messages [", + # join( ' ', keys( %$h2_msgs_all_hash_ref ) ), "]\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, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; + 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"; + } + #sleep 4 ; + + my %h1_hash = (); + my %h2_hash = (); + + my ( %h1_msgs, %h2_msgs ) ; + @h1_msgs{ @h1_msgs } = (); + @h2_msgs{ @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 ; + %h2_msgs_no_cache = %h2_msgs ; + 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 ; + #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 + @h1_msgs_copy_by_uid{ @h1_msgs_no_cache } = ( ) ; + @h2_msgs_delete2_no_cache = @h2_msgs_no_cache if $usecache ; + @h1_msgs_no_cache = ( ) ; + @h2_msgs_no_cache = ( ) ; + + #print "delete2: @h2_msgs_delete2_no_cache\n"; + } + + $debug and print "Host1 parsing headers of folder [$h1_fold]\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 "Host1 parsing headers of folder [$h1_fold] took ", timenext(), " s\n"; + + @$h1_fir_ref{@h1_msgs} = (undef); + + $debug and print "Host1 getting flags idate and sizes of folder [$h1_fold]\n" ; + $h1_fir_ref = $imap1->fetch_hash_2("FLAGS", "INTERNALDATE", "RFC822.SIZE", $h1_fir_ref) + if (@h1_msgs); + $debug and print "Host1 getting flags idate and sizes of folder [$h1_fold] took ", 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, 'Host1', \%h1_hash); + if (! defined($rc)) { + my $h1_size = $h1_fir_ref->{$m}->{"RFC822.SIZE"} || 0; + print "Host1 $h1_fold/$m size $h1_size ignored (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 "Host1 whole time parsing headers took ", timenext(), " s\n"; + $debug and print "\n"; + + $debug and print "Host2 parsing headers of folder [$h2_fold]\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 "Host2 parsing headers of folder [$h2_fold] took ", timenext(), " s\n" ; + + $debug and print "Host2 getting flags idate and sizes of folder [$h2_fold]\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 "Host2 getting flags idate and sizes of folder [$h2_fold] took ", 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, 'Host2', \%h2_hash); + my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; + if (! defined($rc)) { + print "Host2 $h2_fold/$m size $h2_size ignored (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 "Host2 whole time parsing headers took ", 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 marked \\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 marked \\Deleted [duplicate] on host2\n"; + push(@h2_expunge, $h2_msg) if $uidexpunge2; + unless ($dry) { + $imap2->delete_message($h2_msg); + $h2_nb_msg_deleted += 1; + } + } + foreach my $h2_msg ( @h2_msgs_delete2_no_cache ) { + print "msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2\n"; + 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; + } + if ($expunge2){ + print "Expunging host2 folder $h2_fold\n"; + unless($dry) { $imap2->expunge() }; + } + } + + 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'}; + + 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_fold, $h1_msg, $h2_fold, $h2_msg, $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 or $expunge1 ); + } + } + + } + # 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 flags $h1_msg->$h2_msg\n"; + 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 + $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 ($expunge or $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 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_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ; + $debug and print "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 = 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 ); + my @h2_flags = sort split(' ', $h2_flags ); + my $diff = compare_lists( \@h1_flags, \@h2_flags ); + + #$diff = 1 ; + $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 + # 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->Starttls( 1 ) ; + } + + $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 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, $split ) = @_; + 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); + $split and $imap->Split( $split ) ; + + 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.434 $ ', + '$Date: 2011/05/16 07:16:19 $ ', + "\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( $imap2, $h2_fold, $h1_fold ) = @_ ; + + print "Creating folder [$h2_fold] on host2\n"; + if ( ( 'INBOX' eq uc( $h2_fold) ) + and ( $imap2->exists( $h2_fold ) ) ) { + print "Folder [$h2_fold] already exists\n" ; + return( 1 ) ; + } + 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{ + #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]"); + if ( 'Host2' eq $side and ! exists( $h2_folders_all{ $folder } ) ) { + print(" does not exist yet\n") ; + next ; + } + if ( 'Host1' eq $side and ! exists( $h1_folders_all{ $folder } ) ) { + print(" does not exist\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; + $debugflags and print "eval \$h1_flags =~ $regexflag\n"; + eval("\$h1_flags =~ $regexflag"); + die_clean("error: eval regexflag '$regexflag': $@\n") if $@; + $debugflags 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 \(([^)]+?)\)\]}) { + $debug and print "permanentflags: $line"; + 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 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, $msgs_all_hash_ref ) = @_ ; + my ( @msgs, @msgs_all, @max, @min, @union, @inter ) ; + + + if ( defined( $msgs_all_hash_ref ) + or ( ! defined( $maxage ) and ! defined( $minage ) ) + ) { + @msgs = $imap->messages() ; + if ( defined( $msgs_all_hash_ref ) ) { + @msgs_all = @msgs ; + @{ $msgs_all_hash_ref }{ @msgs_all } = () ; + } + if ( ! defined( $maxage ) and ! defined( $minage ) ) { + 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 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"} || '' ; + + return() if size_filtered( $h1_size, $h1_msg, $h1_fold, $h2_fold ) ; + + my $string; + do { print "SLEEP 5\n" and sleep 5 ; } if ( $debugsleep ) ; + 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); + + + 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 {$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( ) ; + } + + if (@regexmess) { + $string = regexmess($string); + } + + $debugcontent 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 = flagsCase( $h1_flags ) if $flagsCase ; + $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 {$string_len} 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/%-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; + $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 or $expunge1 ); + } + } + #print "PRESS ENTER" and my $a = <> ; + } + } + 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, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_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, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; + + #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 $msgs_all_1 = { 120 => '', 142 => '', 143 => '', 144 => '', 177 => '' } ; + my $msgs_all_2 = { 242 => '', 243 => '', 299 => '', 377 => '', 777 => '', 255 => '' } ; + + my( $c12, $c21 ) ; + ok( ( $c12, $c21 ) = get_cache( 'tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_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 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, $msgs_all_1, $msgs_all_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 ]; + + $msgs_all_1 = { 120 => '', 142 => '', 143 => '', 144 => '', 177 => '' } ; + $msgs_all_2 = { 242 => '', 243 => '', 299 => '', 377 => '', 777 => '', 255 => '' } ; + + ok( ( $c12, $c21 ) = get_cache('tmp/cache/rr\uee', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_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, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_ ; + + $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" ; +# or ( ! exists( $cache_1_2_ref->{ $uid1 } ) ) +# or ( ! ( $uid2 == $cache_1_2_ref->{ $uid1 } ) ) + if ( ( ! defined( $uid1 ) ) + or ( ! defined( $uid2 ) ) + or ( ! exists( $h1_msgs_all_hash_ref->{ $uid1 } ) ) + or ( ! exists( $h2_msgs_all_hash_ref->{ $uid2 } ) ) + ) { + $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, + } ; + + my $all_1 = { + 142 => '', + 177 => '', + } ; + + my $all_2 = { + 200 => '', + 242 => '', + 777 => '', + } ; + ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), '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_clean_cache_2 { + + ok( ( ! -d 'tmp/cache/G1/G2' or rmtree( 'tmp/cache/G1/G2' )), 'clean_cache_2: rmtree tmp/cache/G1/G2' ) ; + ok( mkpath( 'tmp/cache/G1/G2' ), 'clean_cache_2: 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_2: touch tmp/cache/G1/G2/...' ) ; + + ok( -f 'tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 before' ); + ok( -f 'tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 before' ); + ok( -f 'tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 before' ); + ok( -f 'tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 before' ); + ok( -f 'tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 before' ); + ok( -f 'tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 before' ); + + my $cache = { + 142 => 242, + 177 => 777, + } ; + + my $all_1 = { + 100 => '', + 142 => '', + 177 => '', + } ; + + my $all_2 = { + 200 => '', + 242 => '', + 777 => '', + } ; + + + + ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache_2: ' ) ; + + ok( -f 'tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 after' ); + ok( -f 'tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 after' ); + ok( ! -f 'tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 after' ); + ok( ! -f 'tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 after' ); + ok( -f 'tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 after' ); + ok( ! -f 'tmp/cache/G1/G2/155_255', 'clean_cache_2: 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 tests_mkpath { + + my $long_path = "123456789/" x 30 ; + ok( (-d "tmp/tests/long/$long_path" or mkpath( "tmp/tests/long/$long_path" )), 'tests_mkpath: mkpath > 300 char' ) ; + ok( (-d "tmp/tests/long/$long_path" and rmtree( "tmp/tests/long/" )), 'tests_mkpath: rmtree > 300 char' ) ; + ok( 1 == 1, 'tests_mkpath: 1 == 1' ) ; +} + +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, + "debugLIST!" => \$debugLIST, + "debugcontent!" => \$debugcontent, + "debugsleep!" => \$debugsleep, + "debugflags!" => \$debugflags, + "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, + "flagsCase!" => \$flagsCase, + "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, + "wholeheaderifneeded!" => \$wholeheaderifneeded, + "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" => \$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, + "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 "$s uid $m_uid head nb pass one: ", $headnum, "\n"; + + my $headstr; + + if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){ + print "$s uid $m_uid no header by classic way so taking whole header\n"; + $imap->fetch($m_uid, "BODY.PEEK[HEADER]"); + my $whole_header = $imap->_transaction_literals; + + #print $whole_header; + $head = decompose_header( $whole_header ) ; + + $headnum = scalar( keys( %$head ) ) ; + $debug and print "$s uid $m_uid head nb pass two: ", $headnum, "\n"; + } + + #require Data::Dumper ; + #print Data::Dumper->Dump( [ $head, \%useheader ] ) ; + + foreach my $h (sort keys(%$head)){ + next if ( ! exists( $useheader{ uc( $h ) } ) + and ! exists( $useheader{ 'ALL' } ) + and ! exists( $useheaderclassic{ uc( $h ) } ) + ) ; + 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 uid $m_uid header [$H]", "\n"; + + if ($skipheader and $H =~ m/$skipheader/i) { + $debug and print "$s uid $m_uid skipping header [$H]\n"; + next; + } + $headstr .= "$H"; + } + } + + 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 uid $m_uid sig $m_md5 size $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.434 2011/05/16 07:16:19 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. +--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. +--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 --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 = ' +0000' 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 = ' +0000' 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 +0000"' 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 +0000"' 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_all, \%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 extract_header { + my $string = shift ; + + my ( $header ) = split( /\n\n/, $string ) ; + #print "[$header]\n" ; + return( $header ) ; +} + +sub tests_extract_header { + ok( +'Message-Id: <20100428101817.A66CB162474E@plume.est.belle> +Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) +From: gilles@louloutte.dyndns.org (Gilles LAMIRAL)' +eq extract_header( +'Message-Id: <20100428101817.A66CB162474E@plume.est.belle> +Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) +From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) + +body +lalala +' ), 'extract_header: 1') ; + +} + +sub decompose_header{ + my $string = shift ; + + my $header = { } ; + + my ($key, $val ) ; + my @line = split( /\n|\r\n/, $string ) ; + foreach my $line ( @line ) { + #print "DDD $line\n" ; + if( $line =~ m/(^[^ :]+): (.*)/ ) { + $key = $1 ; + $val = $2 ; + #print "DDD [$key] [$val]\n" ; + push( @{ $header->{ $key } }, $val ) ; + }elsif( $line =~ m/^(\s+)(.*)/ ) { + $val = $2 ; + #print "DDD only [$val]\n" ; + @{ $header->{ $key } }[ -1 ] .= " $val" ; + }else{ + next ; + } + } + #require Data::Dumper ; + #print Data::Dumper->Dump( [ $header ] ) ; + + return( $header ) ; +} + + +sub tests_decompose_header{ + + my $header_dec ; + + $header_dec = decompose_header( +'KEY_1: VAL_1 +KEY_2: VAL_2 + VAL_2_+ + VAL_2_++ +KEY_3: VAL_3 +KEY_1: VAL_1_other +' + ) ; + + ok( 'VAL_3' + eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: VAL_3' ) ; + + ok( 'VAL_1' + eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: VAL_1' ) ; + + ok( 'VAL_1_other' + eq $header_dec->{ 'KEY_1' }[1], 'decompose_header: VAL_1_other' ) ; + + ok( 'VAL_2 VAL_2_+ VAL_2_++' + eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: VAL_2 VAL_2_+ VAL_2_++' ) ; + + + $header_dec = decompose_header( +'Message-Id: <20100428101817.A66CB162474E@plume.est.belle> +Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) +From: gilles@louloutte.dyndns.org (Gilles LAMIRAL)' + ) ; + + ok( '<20100428101817.A66CB162474E@plume.est.belle>' + eq $header_dec->{ 'Message-Id' }[0], 'decompose_header: 1' ) ; + + $header_dec = decompose_header( +'Return-Path: +Received: by plume.est.belle (Postfix, from userid 1000) + id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST) +Subject: test:eekahceishukohpe' + ) ; + ok( +'by plume.est.belle (Postfix, from userid 1000) id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST)' + eq $header_dec->{ 'Received' }[0], 'decompose_header: 2' ) ; + + $header_dec = decompose_header( +'Received: from plume (localhost [127.0.0.1]) + by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9 + for ; Mon, 26 Nov 2007 10:39:06 +0100 (CET) +Received: from plume [192.168.68.7] + by plume with POP3 (fetchmail-6.3.6) + for (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET)' + ) ; + ok( + 'from plume (localhost [127.0.0.1]) by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9 for ; Mon, 26 Nov 2007 10:39:06 +0100 (CET)' + eq $header_dec->{ 'Received' }[0], 'decompose_header: 3' ) ; + ok( + 'from plume [192.168.68.7] by plume with POP3 (fetchmail-6.3.6) for (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET)' + eq $header_dec->{ 'Received' }[1], 'decompose_header: 3' ) ; +} + + +sub tests_debug { + + SKIP: { + skip "No test in normal run" if ( not $tests_debug ); + tests_match_a_cache_file( ) ; + tests_cache_map( ) ; + tests_get_cache( ) ; + tests_clean_cache( ) ; + tests_clean_cache_2( ) ; + } +} + +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_match_a_cache_file( ) ; + tests_cache_map( ) ; + tests_get_cache( ) ; + tests_clean_cache( ) ; + tests_clean_cache_2( ) ; + tests_touch( ) ; + tests_ucsecond( ) ; + tests_flagsCase( ) ; + tests_mkpath( ) ; + tests_extract_header( ) ; + tests_decompose_header( ) ; + } +} + +# 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::Starttls = sub { + my $self = shift; + + if (@_) { $self->{Starttls} = shift } + return $self->{Starttls}; +}; + + + +*Mail::IMAPClient::exists = sub { + # Bad implementation STATUS fails and can close the connexion + # Exchange does this after 10 failures + 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/tmp/index.shtml b/tmp/index.shtml new file mode 100644 index 0000000..2f5f37f --- /dev/null +++ b/tmp/index.shtml @@ -0,0 +1,384 @@ + + + + +imapsync <!--#exec cmd="cat VERSION" --> + + + + + + + + + + + + + + + + + + + + + + +
    +imapsync logo + +

    Welcome to the imapsync web site!

    +
    + + +

    What is imapsync?

    + +

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

    + +

    imapsync is useful for imap account migration or imap account backup. +

    + +

    imapsync is not adequate for maintaining two active imap accounts in synchronization +where the user plays independently on both sides. Use offlineimap +(written by John Goerzen) for this purpose. +

    + + +

    Who is the author?

    + +

    Gilles LAMIRAL
    + Email: gilles.lamiral@laposte.net

    + +

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

    + +

    Where to talk about imapsync?

    + +

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

    + +

    Latest release is imapsync + +

    + +

    Written on

    + +

    See ChangeLog to know what's new in details.

    + +

    New features since previous releases 1.383 and 1.398:

    + +
      +
    • Fixed the not enough memory issue with big messages by using perl module Mail-IMAPClient 3.27 (thanks to Phil Pearl Lobbes)
      • +
    • New option --useuid to speed up or deal with problems using headers.
      • +
    • New option --notakebody to avoid getting first 2Ko body when got "no header"
      • +
    • Better performance of --usecache with MS Exchange
      • +
    • New option --usecache to speedup transfers when using multiple runs.
      • +
    + + +

    The next imapsync release should see:

    +
      +
    • An option to sync to and from files (local backup)
      • +
    + + +

    Buy imapsync source code

    + +

    +The Perl imapsync source code will run anywhere a Perl interpreter can run: any Unix, Linux, Windows, or Mac OS operating system. +

    + +

    Buy latest imapsync Perl source code for 30 EUR +

    +

    +30 EUR is about 40 USD, no problem to pay in USD with paypal: +

    + + +
    +

    + +imapsync usage +
    + + + + +

    +
    + +

    You will receive a download link in few minutes (contact me if the delay is over a couple of hours).
    +30 days money-back guarantee.

    + +

    Standalone imapsync.exe for win32

    + +

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

    + +

    +30 EUR is about 40 USD, no problem to pay in USD with paypal: +

    + + +
    +

    + +imapsync usage +
    + + + +

    +
    + +

    You will receive a download link in few minutes (contact me if the delay is over a couple of hours).
    +30 days money-back guarantee.

    + + + +

    Documentation

    + +

    Read the INSTALL file to know how to install imapsync on your system. +

    + +

    The README file has many tips to understand imapsync and succeed in your migration or backup. +

    + +

    The FAQ file presents Frequently Asked Questions (and not so frequently asked ones). +

    + +

    The TODO file list what may be coded or done in the future.
    +See also the wanted section. +

    + +

    All the people I thank are in the CREDITS file. +

    + +

    What you can do with imapsync is listed in COPYING. +

    + +

    The imapsync mailing list

    + +

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

    +

    + To write on the mailing-list, the address is: + imapsync@linux-france.org
    +

    + +

    + To subscribe, send a message to: + imapsync-subscribe@listes.linux-france.org
    +

    + +

    + To unsubscribe, send a message to: + imapsync-unsubscribe@listes.linux-france.org
    +

    + +

    + To contact the person in charge for the list: + imapsync-request@listes.linux-france.org
    +

    + +

    + The list archives are available at + + http://linux-france.org/prj/imapsync_list/
    + So consider that the list is public, anyone can see your post.
    + Use a pseudonym or do not post to + this list if you want to stay private.
    +

    + +
    +

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

    +
    + +

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

    + + +

    WANTED!

    + +

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

    + +

    On february 2011: 1 EUR ~ 1.3 USD.

    + + +
    +

    + + + + +

    +
    + + +

    Some features and their time/money to be done evaluation:

    + + + + + + + + + + + + + + + +
    DONEFeature Time guessedTime spentMoney receivedMoney needed
    NoBackup to files 20 hours 60 min 0 $ 800 $
    NoEfficient Gmail backup 20 hours 80 min 0 $ 800 $
    YesAdd cache 10 hours 1310 min 400 $ 400 $
    YesSpeedup 50% 10 hours 80 min 10 $ 400 $
    Yes--delete2folders 3 hours 270 min 90 $ 0 $
    YesNTLM auth 3 hours 300 min 15 $ 150 $
    YesWin32 imapsync.exe 8 hours 520 min 45 $ 240 $
    YesWin32 bug fixes various 370 min 100 $ 85 $
    YesFix capability changes 1 hour 80 min 0 $ 40 $
    YesLarge mailbox --maxage 4 hours 270 min 0 $ 160 $
    Yesdkimap support 3 hours 120 min 0 $ 120 $
    Nogratis from here 4 hours 0 min 0 $ 60000 $
    + +

    Lists of imap server software failures and success stories

    + +

    Let's start with reported failure stories over the past +(maybe new imapsync release can run successfully with them). +

    + +
      +
    • DBMail 0.9, 2.0.7 (GPL). But most other DBMail releases work (see below)
      • +
    • Imail 7.04 (maybe).
      • +
    • MailEnable 1.54 (Proprietary) http://www.mailenable.com/
      • +
    + +

    Now the long reported success stories list +([host1] means "source server", +[host2] means "destination server"): +

    + +
      +
    • 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.1-Invoca-RPM-2.3.1-2.8.fc5 [host1], + 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, 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.
      • +
    • 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
      • +
    • 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 server
      • +
    • Netscape Mail Server 3.6 (Wintel)
      • +
    • Netscape Messaging Server 4.15 Patch 7
      • +
    • OpenMail IMAP server B.07.00.k0
      • +
    • 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
      • +
    • VMS, 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
      • +
    + +
    +

    + + Valid XHTML 1.0 Strict + + + + CSS Valide ! + + + + + +

    + +
    +

    + + +This document last modified on +($Id: index.shtml,v 1.57 2011/02/22 00:53:54 gilles Exp $) +

    + + +