From 4a1d71d8fdab0706b0611e2257a817285ef8e1dd Mon Sep 17 00:00:00 2001 From: Nick Bebout Date: Mon, 3 Aug 2015 20:44:40 -0500 Subject: [PATCH] 1.644 --- .gitignore | 4 +- CREDITS | 6 +- ChangeLog | 39 +- FAQ | 507 +-- FAQ.d/FAQ.Duplicates.txt | 88 + FAQ.d/FAQ.Exchange.txt | 17 +- FAQ.d/FAQ.Flags.txt | 282 ++ FAQ.d/FAQ.Folders_Mapping.txt | 221 ++ FAQ.d/FAQ.Gmail.txt | 25 +- .../{INSTALL.Centos => INSTALL.Centos.txt} | 0 INSTALL.d/prerequisites_imapsync | 5 +- Makefile | 66 +- OPTIONS | 20 +- README | 119 +- S/imapservers.shtml | 83 +- TODO | 56 +- TUTORIAL.html | 73 +- VERSION | 2 +- VERSION_EXE | 2 +- W/.BUILD_EXE_TIME | 12 + W/Mail-IMAPClient-3.35/lib/Mail/IMAPClient.pm | 2 +- .../lib/Mail/IMAPClient.pm-3.35 | 3482 +++++++++++++++++ W/TUTORIAL.t2t | 49 +- W/build_exe.bat | 10 +- W/build_mac.sh | 22 + W/imapsync.1 | 131 +- W/install_modules.bat | 6 +- W/learn/imapclient3xx_skeleton_test | 0 W/learn/mail2world | 43 + W/memo | 7 +- W/ml_announce.in | 20 +- W/paypal_reply/bnc_col_prep.txt | 93 - W/paypal_reply/memo | 2 +- W/paypal_reply/paypal_bilan_1.73 | 1348 ------- W/paypal_reply/paypal_bilan_1.74 | 1448 ------- W/paypal_reply/paypal_bilan_1.75 | 1372 ------- W/paypal_reply/paypal_bilan_1.76 | 1347 ------- W/paypal_reply/paypal_bilan_1.77 | 1417 ------- W/paypal_reply/paypal_bilan_1.78 | 1445 ------- W/paypal_reply/paypal_build_invoices | 34 +- W/perlcritic_2.out | 1464 +++---- W/perlcritic_3.out | 173 +- W/prereq.Ubuntu | 4 +- W/prereq.scandeps | 65 +- W/test3.bat | 20 +- W/test_cook_exe.bat | 2 +- W/test_cook_src.bat | 2 +- W/test_exe_2.bat | 9 +- W/test_reg.bat | 14 + W/test_tests.bat | 5 +- imapsync | 219 +- index.shtml | 6 +- tests.sh | 119 +- 53 files changed, 5656 insertions(+), 10351 deletions(-) create mode 100644 FAQ.d/FAQ.Duplicates.txt create mode 100644 FAQ.d/FAQ.Flags.txt create mode 100644 FAQ.d/FAQ.Folders_Mapping.txt rename INSTALL.d/{INSTALL.Centos => INSTALL.Centos.txt} (100%) create mode 100644 W/Mail-IMAPClient-3.35/lib/Mail/IMAPClient.pm-3.35 create mode 100755 W/build_mac.sh mode change 100644 => 100755 W/learn/imapclient3xx_skeleton_test create mode 100755 W/learn/mail2world delete mode 100644 W/paypal_reply/bnc_col_prep.txt delete mode 100755 W/paypal_reply/paypal_bilan_1.73 delete mode 100755 W/paypal_reply/paypal_bilan_1.74 delete mode 100755 W/paypal_reply/paypal_bilan_1.75 delete mode 100755 W/paypal_reply/paypal_bilan_1.76 delete mode 100755 W/paypal_reply/paypal_bilan_1.77 delete mode 100755 W/paypal_reply/paypal_bilan_1.78 mode change 100755 => 100644 W/test_cook_exe.bat mode change 100755 => 100644 W/test_cook_src.bat create mode 100644 W/test_reg.bat mode change 100755 => 100644 W/test_tests.bat diff --git a/.gitignore b/.gitignore index 6cfda2c..e4593ab 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,7 @@ imapsync_elf_x86.bin - +imapsync_bin_Darwin +imapsync_bin_Linux_i686 +imapsync_bin_Linux_i686_petite *~ debian/*.log debian/*.subvars diff --git a/CREDITS b/CREDITS index 0ce2de1..27c89c7 100644 --- a/CREDITS +++ b/CREDITS @@ -1,5 +1,5 @@ #!/bin/cat -# $Id: CREDITS,v 1.181 2014/09/19 19:46:35 gilles Exp gilles $ +# $Id: CREDITS,v 1.182 2015/05/26 10:16:16 gilles Exp gilles $ If you want to make a donation to me, imapsync author, Gilles LAMIRAL, use any of the following ways: @@ -24,6 +24,10 @@ I thank very much all of these people. I thank also very much all people who bought imapsync from the homepage but I don't cite them here. +Ingo Wichmann +Contributed by giving the book +14.95 USD "Rambles Through My Library" + David Karnowski. Suggested --disarm_read_receipts for its regex. diff --git a/ChangeLog b/ChangeLog index 3f47a9b..f7d1bde 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,17 +1,48 @@ RCS file: RCS/imapsync,v Working file: imapsync -head: 1.637 +head: 1.644 branch: locks: strict - gilles: 1.637 + gilles: 1.644 access list: symbolic names: keyword substitution: kv -total revisions: 637; selected revisions: 637 +total revisions: 644; selected revisions: 644 description: ---------------------------- -revision 1.637 locked by: gilles; +revision 1.644 locked by: gilles; +date: 2015/07/17 01:22:52; author: gilles; state: Exp; lines: +9 -7 +Added NOOP in --dry mode during fake APPEND. +---------------------------- +revision 1.643 +date: 2015/06/24 01:01:00; author: gilles; state: Exp; lines: +17 -10 +Added --fetch_hash_set "1:*" to permit Mail2World success. +Need a patched Mail::IMAPClient 3.35 in sub fetch_hash() +See https://rt.cpan.org/Public/Bug/Display.html?id=105456 +---------------------------- +revision 1.642 +date: 2015/05/11 01:07:37; author: gilles; state: Exp; lines: +9 -6 +Added JSON::WebToken in modules list. +---------------------------- +revision 1.641 +date: 2015/05/09 17:52:27; author: gilles; state: Exp; lines: +27 -128 +Replaced imap servers software list by a link to the web list. +Added option --subfolder2 SUB Move whole host1 folders hierarchy under folder SUB. +---------------------------- +revision 1.640 +date: 2015/05/05 01:03:34; author: gilles; state: Exp; lines: +18 -12 +No folders sizes if --justfolders, unless really wanted. +---------------------------- +revision 1.639 +date: 2015/04/16 19:33:59; author: gilles; state: Exp; lines: +7 -7 +*** empty log message *** +---------------------------- +revision 1.638 +date: 2015/04/09 22:47:24; author: gilles; state: Exp; lines: +19 -11 +No warning about messages when --dry --justfolders together. +---------------------------- +revision 1.637 date: 2015/04/01 01:36:37; author: gilles; state: Exp; lines: +9 -9 Bugfix. Win32 regression with long_path_2_prefix test. Was too long. ---------------------------- diff --git a/FAQ b/FAQ index 0f6d795..d6f4caa 100644 --- a/FAQ +++ b/FAQ @@ -1,11 +1,12 @@ #!/bin/cat -# $Id: FAQ,v 1.205 2015/03/26 08:13:29 gilles Exp gilles $ +# $Id: FAQ,v 1.209 2015/05/09 20:53:23 gilles Exp gilles $ -+------------------+ -| FAQ for imapsync | -+------------------+ ++-------------------+ +| FAQs for imapsync | ++-------------------+ http://imapsync.lamiral.info/FAQ +http://imapsync.lamiral.info/FAQ.d/ Unix versus Windows syntax. There are several differences between Unix and Windows @@ -180,10 +181,11 @@ R. Yes Q. How can I fix this? -R. The cache path reflects hostnames or ip addresses, just change the - directory names of host1 or host2. Use --dry to see if next runs - will generate duplicates. - By default the cache is like +R. The cache path reflects exactly hostnames or ip addresses given via + --host1 and --host2 values. So just change the directory names + of host1 or host2. Use --dry to see if next runs will generate + duplicates. + By default on Unix the cache is like /tmp/imapsync_cache/host1/user1/host2/user2/... @@ -414,7 +416,8 @@ synchronization of mailboxes? Is there a better solution? R. If messages are delivered remotely and you play locally with the copy, in order to have fast access, then the synchronization can't be one way. You may change flags, you may move messages in -different folders etc. +different folders etc. The issue described is clearly +two-ways sync. A better tool with this scenario is offlineimap, designed for this issue, and faster than imapsync. @@ -500,22 +503,19 @@ The result is that you can have more messages on host1 than on host2. R2. With option --useuid imapsync doesn't use headers to identify messages on both sides but it uses their imap uid. In that case -duplicates on host1 are transfered on host2. - -======================================================================= -Q. How can I remove duplicates on a unique host - -R. Just run imapsync on the same account with option --delete2, - ie with host1 == host2 and user1 == user2 +duplicates on host1 are transferred on host2. ======================================================================= Q. I need to log every output on a file named log.txt -R. Use redirections of both standard and error outputs "> log.txt 2>&1" +R1. imapsync logs on a file by default, its name is given at the + beginning and the end of each run. This name is unique since + it is compound of the current date and time and user2 value. - imapsync ... > log.txt 2>&1 +R2. To change this default name, use --logfile log.txt + + imapsync ... --logfile log.txt -This syntax is available both on Windows and Unix. ======================================================================= Q. I need to log every output on a file named log.txt and also to the @@ -617,8 +617,8 @@ R. imapsync does not POP3 but I think you mean UID in IMAP. Q. Is it possible to sync also the UIDs of the IMAP server? UIDs in IMAP are chosen and created by the servers, not by the clients, -imapsync is a client. So UIDs can not be synced by any method, -unless the server is duplicated as is. +imapsync is a client. So UIDs cannot be synced by any imap method. +UIDs might be synced via a rsync command on the server part. ======================================================================= Q. The option --subscribe does not seem to work @@ -684,270 +684,6 @@ Full explanation: past|----maxage+++++minage---->now (intersection) past|++++minage-----maxage++++>now (union) -======================================================================= -Q. Does imapsync retain the \Answered and $Forwarded flags? - -R. It depends on the destination server. - -a) If the destination server honors the "PERMAENTFLAGS \*" -directive (meaning it accepts any flag) or no PERMAENTFLAGS at all -then imapsync synchronizes all flags except the \Recent flag -(RFC 3501 says about \Recent flag "This flag can not be -altered by the client."). - -b) If the destination server honors the "PERMAENTFLAGS without the -special "\*" then imapsync synchronizes only the flags listed -in PERMANENTFLAGS. - -Some imap servers have problems with flags not beginning with -the backslash character \ -(see next question to find a solution to this issue) - - -======================================================================= -Q. Is there a way to only sync messages with a specific flag set, -for example, the \Seen flag? - -R. use --search - - imapsync ... --search SEEN - -or - - imapsync ... --search UNSEEN - -or ... - -The complete list of search things are listed below - -http://www.faqs.org/rfcs/rfc3501.html - -6.4.4. SEARCH Command -... - ALL - All messages in the mailbox; the default initial key for - ANDing. - - ANSWERED - Messages with the \Answered flag set. - - BCC - Messages that contain the specified string in the envelope - structure's BCC field. - - BEFORE - Messages whose internal date (disregarding time and timezone) - is earlier than the specified date. - - BODY - Messages that contain the specified string in the body of the - message. - - CC - Messages that contain the specified string in the envelope - structure's CC field. - - DELETED - Messages with the \Deleted flag set. - - DRAFT - Messages with the \Draft flag set. - - FLAGGED - Messages with the \Flagged flag set. - - FROM - Messages that contain the specified string in the envelope - structure's FROM field. - - HEADER - Messages that have a header with the specified field-name (as - defined in [RFC-2822]) and that contains the specified string - in the text of the header (what comes after the colon). If the - string to search is zero-length, this matches all messages that - have a header line with the specified field-name regardless of - the contents. - - KEYWORD - Messages with the specified keyword flag set. - - LARGER - Messages with an [RFC-2822] size larger than the specified - number of octets. - - NEW - Messages that have the \Recent flag set but not the \Seen flag. - This is functionally equivalent to "(RECENT UNSEEN)". - - NOT - Messages that do not match the specified search key. - - OLD - Messages that do not have the \Recent flag set. This is - functionally equivalent to "NOT RECENT" (as opposed to "NOT - NEW"). - - ON - Messages whose internal date (disregarding time and timezone) - is within the specified date. - - OR - Messages that match either search key. - - RECENT - Messages that have the \Recent flag set. - - SEEN - Messages that have the \Seen flag set. - - SENTBEFORE - Messages whose [RFC-2822] Date: header (disregarding time and - timezone) is earlier than the specified date. - - SENTON - Messages whose [RFC-2822] Date: header (disregarding time and - timezone) is within the specified date. - - SENTSINCE - Messages whose [RFC-2822] Date: header (disregarding time and - timezone) is within or later than the specified date. - - SINCE - Messages whose internal date (disregarding time and timezone) - is within or later than the specified date. - - SMALLER - Messages with an [RFC-2822] size smaller than the specified - number of octets. - - SUBJECT - Messages that contain the specified string in the envelope - structure's SUBJECT field. - - TEXT - Messages that contain the specified string in the header or - body of the message. - - TO - Messages that contain the specified string in the envelope - structure's TO field. - - UID - Messages with unique identifiers corresponding to the specified - unique identifier set. Sequence set ranges are permitted. - - UNANSWERED - Messages that do not have the \Answered flag set. - - UNDELETED - Messages that do not have the \Deleted flag set. - - UNDRAFT - Messages that do not have the \Draft flag set. - - UNFLAGGED - Messages that do not have the \Flagged flag set. - - UNKEYWORD - Messages that do not have the specified keyword flag set. - - UNSEEN - Messages that do not have the \Seen flag set. - -======================================================================= -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 fix this error: BAD Invalid system flag \FORWARDED - -R. Filter flag \FORWARDED with --regexflag like this: - -On Windows: - - imapsync ... --regexflag "s/\\FORWARDED//g" - -On Unix: - - imapsync ... --regexflag 's/\\FORWARDED//g' - -or - - imapsync ... --regexflag "s/\\\\FORWARDED//g" - - -======================================================================= -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 defined list of flags, how can I do? -The destination imap server complains about bad flags (Exchange). - -R1. Recent imapsync deals with this issue by filter with PERMANENTFLAGS -automatically. - -R2. For example if you want to keep only the following flags -\Seen \Answered \Flagged \Deleted \Draft -then use these magic --regexflag options (thanks to Phil): - - --regexflag 's/.*?(?:(\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg' - -Analysis is left to the reader. - -This one is longer and may be use with old perl (no /e regex extension): - --regexflag 's/(.*)/$1 jrdH8u/' \ - --regexflag 's/.*?(\\Seen|\\Answered|\\Flagged|\\Deleted|\\Draft|jrdH8u)/$1 /g' \ - --regexflag 's/(\\Seen|\\Answered|\\Flagged|\\Deleted|\\Draft|jrdH8u) (?!(\\Seen|\\Answered|\\Flagged|\\Deleted|\\Draft|jrdH8u)).*/$1 /g' \ - --regexflag 's/jrdH8u *//' - - -====================================================================== -Q. imapsync fails with the following error: -flags from : [\Seen NonJunk]["10-Aug-2006 13:00:30 -0400"] -Error trying to append string: 58 NO APPEND Invalid flag list - -R. For some servers, flags have to begin with a \ character. -The flag "NonJunk" may be a invalid flag for your server -so use for example: - -imapsync ... --regexflag "s/NonJunk//g" - -Remark (thanks to Arnt Gulbrandsen): -IMAP system flags have to begin with \ character. -Any other flag must begin with another character. -System flags are just flags defined by an RFC instead of by users. -Conclusion, some imap server coders don't read the RFCs (so do I). - -Recent imapsync deals with this issue by filter with PERMANENTFLAGS -automatically. - -======================================================================= -Q. Flags are not well synchronized. Is it a bug? - -R. It happens with some servers on the first sync. -Also, it was a bug from revision 1.200 to revision 1.207 - -Two solutions: - -* Run imapsync a second time. imapsync synchronizes flags on each run. - -* Use option --syncflagsaftercopy. With this option imapsync will - also sync flags after each message transfer. Flags are already - synced during the transfer with the imap APPEND command but - option --syncflagsaftercopy does it again using the imap STORE - command. ======================================================================= Q. On Unix, some passwords contain * and " characters. Login fails. @@ -1067,61 +803,6 @@ b) or use stunnel : c) or use stunnel on inetd imaps stream tcp nowait cyrus /usr/sbin/stunnel -s cyrus -p /etc/ssl/certs/imapd.pem -r localhost:imap2 -======================================================================= -Q: Multiple copies, duplicates, when I run imapsync twice ore more. - -R1. You can use option --useuid, imapsync then won't use header lines to -compare messages in folders. Keep in ming it uses a local cache. - - imapsync ... --useuid - -R2. Multiple copies of the emails on the destination server. Some IMAP -servers (Domino for example) change some headers for each message -transferred. All messages are transferred again and again each time you -run imapsync. This is bad of course. The explanation is that imapsync -considers messages are not the same on each side, default headers used -to identify the messages have changed. - -You can look at the headers found by imapsync by using the --debug -option (and search for the message on both part), Header lines from -the source server begin with a "FH:" prefix, Header lines from the -destination server begin with a "TH:" prefix. Since --debug is very -verbose I suggest to isolate a email in a specific folder in case you -want to forward me the output. - -A way to avoid this problem is by using option --useheader with -a different set than the default ones used by imapsync. - -The default set is like: - - imapsync ... --useheader "Message-ID" --useheader "Received" - -The big problem is that what can be used instead of Message-ID -and Received lines? Sometimes standalone Message-ID works: - - imapsync ... --useheader "Message-ID" - -Another good way to the solution is to isolate two or three messages -in a BUG folder and send the --debug output to the author -gilles.lamiral@laposte.net - - imapsync ... --debug --folder BUG - -I will take a close look at the log and modify imapsync to fix -this faulty duplicate behaviour. - -Remark. (Trick found by Tomasz Kaczmarski) - -Option --useheader "Message-ID" asks the server to send only header -lines beginning with "Message-ID". Some (buggy) servers send the whole -header (all lines) instead of the "Message-ID" line. In that case, a -trick to keep the --useheader filtering behaviour is to use ---skipheader with a negative lookahead pattern : - - imapsync ... --skipheader "^(?!Message-ID)" - - Read it as "skip every header except Message-ID". - ====================================================================== Q. I am transferring mails from one IMAP server to another. I am using an SSL connection. Transferring huge mails (>10MB) takes ages. @@ -1311,148 +992,20 @@ In imapsync, you can achieve this by using the following options: Q. Is there anyway of making imapsync purge the destination folder when the source folder is deleted? -R. No, that's too dangerous. May be coded in future release. +R. Yes, use --delete2folders -But if the source folder is empty (not deleted) and options --delete2 ---expunge2 are used then the destination folder will be empty. +--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 : Deleted only folders matching regex. + Example: --delete2foldersonly "/^Junk$|^INBOX.Junk$/" +--delete2foldersbutnot : Do not delete folders matching regex. + Example: --delete2foldersbutnot "/Tasks$|Contacts$|Foo$/" -====================================================================== -Q. Is it possible to synchronize all messages from one server to -another without recreating the folder structure and the target server. - -R. Yes. - -For example, to synchronize all messages in all folders on host1 -to folder INBOX only on host2: - -1) First try (safe mode): - -imapsync \ - ... - --regextrans2 "s/(.*)/INBOX/" \ - --dry --justfolders - -2) See if the output says everything you want imapsync to do, - --dry option is safe and does nothing real. - -3) Remove --dry - Check the imap folder tree on the target side, you should - only have one: the classical INBOX. - -4) Remove --justfolders - - -====================================================================== -Q. I have moved from Braunschweig to Graz, so I would like to have my - whole Braunschweig mail sorted into a sub-folder INBOX.Braunschweig - of my new mail account. - -R. -1) First try (safe mode): - -imapsync \ - ... - --regextrans2 "s/INBOX(.*)/INBOX.Braunschweig\$1/" \ - --dry --justfolders - -On Windows, in the previous example containing \$1 you have to -replace the two \$1 by $1 (remove the \ before $). - - -2) See if the output says everything you want imapsync to do, - --dry option is safe and does nothing real. - -3) Remove --dry - Check the imap folder tree on the target side - -4) Remove --justfolders - -======================================================================= -Q. Give examples about --regextrans2 - -R. --regextrans2 is used to transform folder names - -Remember that --regextrans2 applies after the default -inversion prefix1 <-> prefix2 and sep1 <-> sep2 - -Examples: - -0) First try with --dry --justfolders options since imapsync shows the - transformations it will do without really doing them. Then when - happy with the output remove the --dry --justfolders options. - -1) To remove INBOX. in the name of destination folders: - - --regextrans2 's/^INBOX\.(.+)/$1/' - -2a) To sync all folders to INBOX: - - imapsync ... --regextrans2 "s/.*/INBOX/" - - -2b) To sync a complete account in a subfolder called FOO: - - a) Seperator is dot character "." and "INBOX" prefixes every folder - - --regextrans2 's/^INBOX(.*)/INBOX.FOO$1/' - - or: - - b) Seperator is slash character "/" and there is no prefix - - --regextrans2 's#(.*)#FOO/$1#' - - or: - - c) Any separator, any prefix solution, FOO is the subfolder: - - It is a complicated line because every case is taken into account. - Type it in one line (or with the \ at the end of first line on Unix shells. - - --regextrans2 's,${h2_prefix}(.*),${h2_prefix}FOO${h2_sep}$1,' \ - --regextrans2 's,^INBOX$,${h2_prefix}FOO{h2_sep}INBOX,' - - -3) to substitute all characters dot "." by underscores "_" - --regextrans2 's/\./_/g' - -4) to change folder names like this: -[mail/Sent Items] -> [Sent] -[mail/Test] -> [INBOX/Test] -[mail/Test2] -> [INBOX/Test2] - - --regextrans2 's#^mail/Sent Items$#Sent#' \ - --regextrans2 's#^mail/#INBOX/#' - -======================================================================= -Q. I would like to move emails from InBox to a sub-folder called, - say "2010-INBOX" based on the date (Like all emails received in the - Year 2010 should be moved to the folder called "2010-INBOX"). - -R. 2 ways : - -a) Manually: ------------- - -1) You create a folder INBOX.2010-INBOX - -2) Mostly every email software allow sorting by date. In INBOX, you - select from 1 January to 31 December 2010 messages with the shift key. - (in mutt, use ~d) - -3) Cut/paste in INBOX.2010-INBOX - -b) With imapsync: ------------------ - -imapsync ... \ ---search 'SENTSINCE 1-Jan-2010 SENTBEFORE 31-Dec-2010' ---regextrans2 's/^INBOX$/INBOX.2010-INBOX/' \ ---folder INBOX ======================================================================= Q. I want to play with headers line and --regexmess but I want to leave - the body as is + the body as is. R. The header/body separation is a blank line so an example: --regexmess 's{\A(.*?(?! ^$))^Date:(.*?)$}{$1Date:$2\nX-Date:$2}gxms' diff --git a/FAQ.d/FAQ.Duplicates.txt b/FAQ.d/FAQ.Duplicates.txt new file mode 100644 index 0000000..d7ad840 --- /dev/null +++ b/FAQ.d/FAQ.Duplicates.txt @@ -0,0 +1,88 @@ +#!/bin/cat +$Id: FAQ.Duplicates.txt,v 1.3 2015/04/02 23:40:08 gilles Exp gilles $ + +====================================================================== + Imapsync and message duplicates issues +====================================================================== + +======================================================================= +Q. How can I remove duplicates in an lone account? + +R. Just run imapsync on the same account with option --delete2, + ie with host1 == host2 and user1 == user2 + +======================================================================= +Q: Multiple copies, duplicates, when I run imapsync twice ore more. + +R0. +Normally and by default, imapsync doesn't generate duplicates. +So if it does generate duplicates it means a problem occurs +with message identification. It happens sometimes with IMAP +servers changing the "Message-Id" line or "Received:" in +the header part of messages. + +R1. +You can use option --useuid, with it, imapsync won't use +header lines to compare messages in folders. +Keep in mind it uses a local cache. + + imapsync ... --useuid + +A big issue with --useuid is that it doesn't generate duplicates if +used from the first time. But it does generate duplicates after a previous +run without --useuid (because it uses a different method to identify +the messages). A solution? it depends. --delete2 solves this problem +if you are permitted to use it. + +R2. +Best way if you can follow it. +Multiple copies of the emails on the destination server. Some IMAP +servers (Domino for example) change some headers for each message +transferred. All messages are transferred again and again each time you +run imapsync. This is bad of course. The explanation is that imapsync +considers messages are not the same on each side, default headers used +to identify the messages have changed. + +You can look at the headers found by imapsync by using the --debug +option (and search for the message on both part), Header lines from +the source server begin with a "FH:" prefix, Header lines from the +destination server begin with a "TH:" prefix. Since --debug is very +verbose I suggest to isolate a email in a specific folder in case you +want to forward me the output. + +A way to avoid this problem is by using option --useheader with +a different set than the default ones used by imapsync. + +The default set is like: + + imapsync ... --useheader "Message-Id" --useheader "Received" + +The big problem is that what can be used instead of Message-Id +and Received lines? Often standalone Message-Id works: + + imapsync ... --useheader "Message-Id" + +Another good way toward a solution is to isolate two or three messages +in a BUG folder and send me the --debug output by email at +gilles.lamiral@laposte.net + + imapsync ... --debug --folder BUG + +I will take a close look at the log and modify imapsync to fix +this faulty duplicate behaviour. + +Remark. (Trick found by Tomasz Kaczmarski) + +Option --useheader "Message-Id" asks the server to send only header +lines beginning with "Message-Id". Some (buggy) servers send the whole +header (all lines) instead of the "Message-Id" line. In that case, a +trick to keep the --useheader filtering behaviour is to use +--skipheader with a negative lookahead pattern: + + imapsync ... --skipheader "^(?!Message-Id)" + + Read it as "skip every header except Message-Id". + +======================================================================= + + diff --git a/FAQ.d/FAQ.Exchange.txt b/FAQ.d/FAQ.Exchange.txt index 2e3d61b..1dff510 100644 --- a/FAQ.d/FAQ.Exchange.txt +++ b/FAQ.d/FAQ.Exchange.txt @@ -1,5 +1,5 @@ #!/bin/cat -$Id: FAQ.Exchange.txt,v 1.2 2015/03/16 15:11:32 gilles Exp gilles $ +$Id: FAQ.Exchange.txt,v 1.4 2015/06/03 15:33:48 gilles Exp gilles $ ======================================================================= Exchange 20xx and Office365 specific issues and solutions @@ -16,11 +16,12 @@ R. Here is a command line resume that solves most encountered issues when On Windows: - imapsync ... ^ + imapsync.exe ... ^ --maxsize 10000000 ^ --maxlinelength 9900 ^ --regexflag "s/\\Flagged//g" ^ - --disarmreadreceipts + --disarmreadreceipts ^ + --maxlinelength 9000 On Unix: @@ -29,7 +30,12 @@ On Unix: --maxsize 10000000 \ --maxlinelength 9900 \ --regexflag "s/\\Flagged//g" \ - --disarmreadreceipts + --disarmreadreceipts \ + --maxlinelengthcmd 'reformime -r7' + +To get the "reformime" command on Linux install the "maildrop" package +No "reformime" on Windows so for now messages with too long line length +can't be synced to Exchange or Office365. ======================================================================= @@ -197,7 +203,8 @@ So don't use --authmech1 SOMETHING with --authuser1 admin_user, it will not work. Same behavior with the --authuser2 option. - +See also: +http://www.linux-france.org/prj/imapsync_list/msg02203.html diff --git a/FAQ.d/FAQ.Flags.txt b/FAQ.d/FAQ.Flags.txt new file mode 100644 index 0000000..88d6a42 --- /dev/null +++ b/FAQ.d/FAQ.Flags.txt @@ -0,0 +1,282 @@ +#!/bin/cat +$Id: FAQ.Flags.txt,v 1.3 2015/04/03 21:05:11 gilles Exp gilles $ + +====================================================================== + Imapsync and flags +====================================================================== + +Questions answered here are: + +Q. How to debug flag issues? + +Q. Is there a way to only sync messages with a specific flag set, + for example, the \Seen flag? + +Q. How to convert flags? + +Q. Does imapsync retain the \Answered and $Forwarded flags? + +Q. How to fix this error: BAD Invalid system flag \FORWARDED + +Q. How to convert flags with $ to \ character? + +Q. imapsync fails with the following error: +flags from : [\Seen NonJunk] +Error trying to append string: 58 NO APPEND Invalid flag list + +Q. Flags are not well synchronized. Is it a bug? + +======================================================================= +Q. How to debug flag issues? + +R. Use --debugflags + + imapsync ... --debugflags + + +======================================================================= +Q. Is there a way to only sync messages with a specific flag set, + for example, the \Seen flag? + +R. use --search + + imapsync ... --search SEEN + +or + + imapsync ... --search UNSEEN + +or ... + +The complete list of search things are listed below + +http://www.faqs.org/rfcs/rfc3501.html + +6.4.4. SEARCH Command +... + ALL + All messages in the mailbox; the default initial key for + ANDing. + + ANSWERED + Messages with the \Answered flag set. + + BCC + Messages that contain the specified string in the envelope + structure's BCC field. + + BEFORE + Messages whose internal date (disregarding time and timezone) + is earlier than the specified date. + + BODY + Messages that contain the specified string in the body of the + message. + + CC + Messages that contain the specified string in the envelope + structure's CC field. + + DELETED + Messages with the \Deleted flag set. + + DRAFT + Messages with the \Draft flag set. + + FLAGGED + Messages with the \Flagged flag set. + + FROM + Messages that contain the specified string in the envelope + structure's FROM field. + + HEADER + Messages that have a header with the specified field-name (as + defined in [RFC-2822]) and that contains the specified string + in the text of the header (what comes after the colon). If the + string to search is zero-length, this matches all messages that + have a header line with the specified field-name regardless of + the contents. + + KEYWORD + Messages with the specified keyword flag set. + + LARGER + Messages with an [RFC-2822] size larger than the specified + number of octets. + + NEW + Messages that have the \Recent flag set but not the \Seen flag. + This is functionally equivalent to "(RECENT UNSEEN)". + + NOT + Messages that do not match the specified search key. + + OLD + Messages that do not have the \Recent flag set. This is + functionally equivalent to "NOT RECENT" (as opposed to "NOT + NEW"). + + ON + Messages whose internal date (disregarding time and timezone) + is within the specified date. + + OR + Messages that match either search key. + + RECENT + Messages that have the \Recent flag set. + + SEEN + Messages that have the \Seen flag set. + + SENTBEFORE + Messages whose [RFC-2822] Date: header (disregarding time and + timezone) is earlier than the specified date. + + SENTON + Messages whose [RFC-2822] Date: header (disregarding time and + timezone) is within the specified date. + + SENTSINCE + Messages whose [RFC-2822] Date: header (disregarding time and + timezone) is within or later than the specified date. + + SINCE + Messages whose internal date (disregarding time and timezone) + is within or later than the specified date. + + SMALLER + Messages with an [RFC-2822] size smaller than the specified + number of octets. + + SUBJECT + Messages that contain the specified string in the envelope + structure's SUBJECT field. + + TEXT + Messages that contain the specified string in the header or + body of the message. + + TO + Messages that contain the specified string in the envelope + structure's TO field. + + UID + Messages with unique identifiers corresponding to the specified + unique identifier set. Sequence set ranges are permitted. + + UNANSWERED + Messages that do not have the \Answered flag set. + + UNDELETED + Messages that do not have the \Deleted flag set. + + UNDRAFT + Messages that do not have the \Draft flag set. + + UNFLAGGED + Messages that do not have the \Flagged flag set. + + UNKEYWORD + Messages that do not have the specified keyword flag set. + + UNSEEN + Messages that do not have the \Seen flag set. + +======================================================================= +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. Does imapsync retain the \Answered and $Forwarded flags? + +R. It depends on the destination server. + +a) If the destination server honours the "PERMAENTFLAGS \*" +directive (meaning it accepts any flag) or no PERMAENTFLAGS at all +then imapsync synchronizes all flags except the \Recent flag +(RFC 3501 says about \Recent flag "This flag can not be +altered by the client."). + +b) If the destination server honours the "PERMAENTFLAGS without the +special "\*" then imapsync synchronizes only the flags listed +in PERMANENTFLAGS. + +Some imap servers have problems with flags not beginning with +the backslash character \ +(see next question to find a solution to this issue) + + +======================================================================= +Q. How to fix this error: BAD Invalid system flag \FORWARDED + +R. Filter flag \FORWARDED with --regexflag like this: + +On Windows: + + imapsync ... --regexflag "s/\\FORWARDED//g" + +On Unix: + + imapsync ... --regexflag 's/\\FORWARDED//g' + +or + + imapsync ... --regexflag "s/\\\\FORWARDED//g" + + +======================================================================= +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. imapsync fails with the following error: +flags from : [\Seen NonJunk] +Error trying to append string: 58 NO APPEND Invalid flag list + +R. For some servers, flags have to begin with a \ character. +The flag "NonJunk" may be a invalid flag for your server +so use for example: + +imapsync ... --regexflag "s/NonJunk//g" + +Remark (thanks to Arnt Gulbrandsen): +IMAP system flags have to begin with \ character. +Any other flag must begin with another character. +System flags are just flags defined by an RFC instead of by users. +Conclusion, some imap server coders don't read the RFCs (so do I). + +Recent imapsync deals with this issue by filter with PERMANENTFLAGS +automatically. + +======================================================================= +Q. Flags are not well synchronized. Is it a bug? + +R. It happens with some servers on the first sync. +Also, it was a bug from revision 1.200 to revision 1.207 + +Two solutions: + +* Run imapsync a second time. imapsync synchronizes flags on each run. + +* Use option --syncflagsaftercopy. With this option imapsync will + also sync flags after each message transfer. Flags are already + synced during the transfer with the imap APPEND command but + option --syncflagsaftercopy does it again using the imap STORE + command. + + +======================================================================= \ No newline at end of file diff --git a/FAQ.d/FAQ.Folders_Mapping.txt b/FAQ.d/FAQ.Folders_Mapping.txt new file mode 100644 index 0000000..2192879 --- /dev/null +++ b/FAQ.d/FAQ.Folders_Mapping.txt @@ -0,0 +1,221 @@ +#!/bin/cat +$Id: FAQ.Folders_Mapping.txt,v 1.5 2015/05/11 10:36:33 gilles Exp gilles $ + +=========================================== + Imapsync changing folders names +=========================================== + +Things to know and understand before playing with --regextrans2 + +*) --regextrans2 is used to transform folders names. + +*) --regextrans2 applies after the default + inversion prefix1 <-> prefix2 and sep1 <-> sep2 + So when elaborating the regex you should focus on + the right part of the default mapping printed by + imapsync, the part showing the host2 folder name. + The section to look at is within the folder loop: +++++ Looping on each folder +Here +++++ End looping on each folder + +*) Several --regextrans2 is possible, they will be applied in the order + of the command line, each one on the result of the previous one. + +*) --regextrans2 uses Perl regex mechanism so it may be hard to master + this part. It is powerful but not very simple. + +*) Windows vs Unix quotes. + + On windows don't use single quotes ' around the regex string, + use double quotes instead, like --regextrans2 "myregex" + + On Linux/Unix use single quotes ' around the regex string, it is + easier to get what we want with single quotes since the shell + won't change the inner string. Like --regextrans2 'myregex' + +*) Good method to elaborate any --regextrans2 string + + First elaborate the --regextrans2 string with --dry --justfolders + --nofoldersizes options. + With --dry imapsync shows the transformations it will do without + really doing them. + With --justfolders imapsync will work only with folders, + messages won't be taken into account. + With --nofoldersizes imapsync won't spend time useless time on + evaluating folders sizes. + + When the output shows what you escape imapsync to do with folders + names, you can remove the --dry option. Keep the --justfolders + option in order to see if the destination server host2 accepts + to create the folders. + + When everything is ok with folders you can remove --justfolders + and --nofoldersizes imapsync will also transfer messages. + Showing folders sizes is good then transferring messages, it allows + ETA calculation and it's a supplementary check on folders. + +======================================================================= +Q. Give examples about --regextrans2 + + +Examples: + +1) To remove INBOX. in the name of destination folders: + + --regextrans2 's/^INBOX\.(.+)/$1/' + +2a) To sync all folders to INBOX: + + imapsync ... --regextrans2 "s/.*/INBOX/" + + +2b) To sync a complete account in a subfolder called FOO: + +Since imapsync release 1.641 simply use: + + imapsync ... --subfolder2 FOO + +Next examples are subfolder solutions for any release. + + a) Separator is dot character "." and "INBOX" prefixes every folder + +On Linux/Unix: + + --regextrans2 's,^INBOX(.*),INBOX.FOO$1,' + +On Windows: + + --regextrans2 "s,^INBOX(.*),INBOX.FOO$1," + + or: + + b) Separator is the slash character "/" and there is no prefix + +On Linux/Unix: + + --regextrans2 's,(.*),FOO/$1,' + +On Windows: + + --regextrans2 "s,(.*),FOO/$1," + + or: + + c) Any separator, any prefix solution, FOO is the subfolder: + + It is a complicated line because every case is taken into account. + Type it in one line (or with the \ at the end of first line on Unix shells. + +On Linux/Unix: + + --regextrans2 's,${h2_prefix}(.*),${h2_prefix}FOO${h2_sep}$1,' \ + --regextrans2 's,^INBOX$,${h2_prefix}FOO${h2_sep}INBOX,' + +On Windows: + + --regextrans2 "s,${h2_prefix}(.*),${h2_prefix}FOO${h2_sep}$1," ^ + --regextrans2 "s,^INBOX$,${h2_prefix}FOO${h2_sep}INBOX," + +3) to substitute all characters dot "." by underscores "_" + --regextrans2 "s,\.,_,g" + +3b) to substitute all doublequotes " by underscores _ + +On Linux/Unix: + + --regextrans2 's,\",_,g' + +On Windows: + + --regextrans2 s,\^",_,g + + +4) to change folder names like this: +[mail/Sent Items] -> [Sent] +[mail/Test] -> [INBOX/Test] +[mail/Test2] -> [INBOX/Test2] + +On Linux/Unix: + + --regextrans2 's,^mail/Sent Items$,Sent,' \ + --regextrans2 's,^mail/,INBOX/,' + + +====================================================================== +Q. Is it possible to synchronize all messages from one server to +another without recreating the folder structure and the target server. + +R. Yes. + +For example, to synchronize all messages in all folders on host1 +to folder INBOX only on host2: + +1) First try (safe mode): + + --regextrans2 "s/(.*)/INBOX/" --dry --justfolders + +2) See if the output says everything you want imapsync to do, + --dry option is safe and does nothing real. + +3) Remove --dry + Check the imap folder tree on the target side, you should + only have one: the classical INBOX. + +4) Remove --justfolders + + +====================================================================== +Q. I have moved from Braunschweig to Graz, so I would like to have my + whole Braunschweig mail sorted into a sub-folder INBOX.Braunschweig + of my new mail account. + +R. +1) First try (safe mode): + +imapsync \ + ... + --regextrans2 "s/INBOX(.*)/INBOX.Braunschweig\$1/" \ + --dry --justfolders + +On Windows, in the previous example containing \$1 you have to +replace the two \$1 by $1 (remove the \ before $). + + +2) See if the output says everything you want imapsync to do, + --dry option is safe and does nothing real. + +3) Remove --dry + Check the imap folder tree on the target side + +4) Remove --justfolders + +======================================================================= +Q. I would like to move emails from InBox to a sub-folder called, + say "2010-INBOX" based on the date (Like all emails received in the + Year 2010 should be moved to the folder called "2010-INBOX"). + +R. 2 ways : + +a) Manually: +------------ + +1) You create a folder INBOX.2010-INBOX + +2) Mostly every email software allow sorting by date. In INBOX, you + select from 1 January to 31 December 2010 messages with the shift key. + (in mutt, use ~d) + +3) Cut/paste in INBOX.2010-INBOX + +b) With imapsync: +----------------- + +imapsync ... \ +--search 'SENTSINCE 1-Jan-2010 SENTBEFORE 31-Dec-2010' +--regextrans2 's/^INBOX$/INBOX.2010-INBOX/' \ +--folder INBOX + +======================================================================= + + diff --git a/FAQ.d/FAQ.Gmail.txt b/FAQ.d/FAQ.Gmail.txt index 608876f..320514d 100755 --- a/FAQ.d/FAQ.Gmail.txt +++ b/FAQ.d/FAQ.Gmail.txt @@ -1,5 +1,5 @@ #!/bin/cat -$Id: FAQ.Gmail.txt,v 1.1 2015/03/26 08:12:20 gilles Exp gilles $ +$Id: FAQ.Gmail.txt,v 1.2 2015/05/11 01:11:40 gilles Exp gilles $ ====================================================================== Imapsync with Gmail @@ -71,11 +71,12 @@ and trailing blank characters are problems with gmail, and also successive blanks ending with the IMAP error "NO [CANNOT] Folder contains excess whitespace (Failure)" If you want to change only leading and trailing blank characters -then use instead: ---regextrans2 "s,(/|^) +,\$1,g" --regextrans2 "s, +(/|$),\$1,g" +then use the following instead +On Linux/Unix: + --regextrans2 "s,(/|^) +,\$1,g" --regextrans2 "s, +(/|$),\$1,g" +On Windows: + --regextrans2 "s,(/|^) +,$1,g" --regextrans2 "s, +(/|$),$1,g" -On Windows, in the previous example containing \$1 you have to -replace the two \$1 by $1 (remove the \ before $1). --regextrans2 "s/[\^]/_/g" is mandatory. It converts, since not accepted by gmail, character ^ to character _ underscore. @@ -185,6 +186,20 @@ label CanWait and only it. --skipcrossduplicates, will only put in "[Gmail]/All Mail" the messages that are not labeled at all. +======================================================================= +Q. I can't authenticate with Gmail via IMAP + Gmail says "Please log in via your web browser" + +R1. See Coert Grobbelaar solution: +https://security.stackexchange.com/questions/86404/how-do-i-interact-with-google-to-import-email-via-imapsync + +R2. I had the same issue one time (mars 2015) logging to Gmail +with imapsync. +The Gmail imap message error said "Please log in via your web browser" +so I logged for this account via a web browser, +it asked me to receive a code via a mobile, I said yes, +I entered the code and everything went ok. + ======================================================================= Q. Gmail does not really delete messages in folder [Gmail]/All Mail What happens? What can I do? diff --git a/INSTALL.d/INSTALL.Centos b/INSTALL.d/INSTALL.Centos.txt similarity index 100% rename from INSTALL.d/INSTALL.Centos rename to INSTALL.d/INSTALL.Centos.txt diff --git a/INSTALL.d/prerequisites_imapsync b/INSTALL.d/prerequisites_imapsync index 8b05538..29a2eea 100755 --- a/INSTALL.d/prerequisites_imapsync +++ b/INSTALL.d/prerequisites_imapsync @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: prerequisites_imapsync,v 1.10 2015/03/14 23:46:59 gilles Exp gilles $ +# $Id: prerequisites_imapsync,v 1.12 2015/07/06 03:12:43 gilles Exp gilles $ MODULES_MANDATORY=' Digest::HMAC_MD5 @@ -68,7 +68,7 @@ search_modules_any() { echo "All needed modules are already installed" return } - apt-get -h > /dev/null 2>&1 && { + apt-file -h > /dev/null 2>&1 && { search_modules_apt "$@" return } @@ -114,6 +114,7 @@ search_modules_apt() { #echo apt-file search /$F echo apt-file search /$F + #apt-cache search "$M" echo done } diff --git a/Makefile b/Makefile index 5ceeb8b..76925bc 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -# $Id: Makefile,v 1.179 2015/04/01 03:00:13 gilles Exp gilles $ +# $Id: Makefile,v 1.189 2015/07/17 17:36:56 gilles Exp gilles $ .PHONY: help usage all @@ -19,6 +19,7 @@ usage: @echo "make W/test_tests.bat # run --tests on win32" @echo "make W/test2.bat # run W/test2.bat on win32" @echo "make W/test3.bat # run W/test3.bat on win32" + @echo "make W/test_reg.bat # run W/test_reg.bat on win32" @echo "make W/test_exe_2.bat # run W/test_exe_2.bat on win32" @echo "make prereq_win32 # run W/install_modules.bat on win32" @echo "make all " @@ -27,7 +28,7 @@ usage: @echo "make valid_index # check index.shtml for good syntax" @echo "make upload_ks" @echo "make imapsync.exe" - @echo "make imapsync_elf_x86.bin" + @echo "make bin" @echo "make publish" @echo "make perlcritic" @echo "make prereq # Generates W/prereq.*" @@ -47,12 +48,21 @@ HELLO=$(shell date;uname -a) IMAPClient_3xx=./W/Mail-IMAPClient-3.35/lib IMAPClient=$(IMAPClient_3xx) +HOSTNAME = $(shell hostname -s) +ARCH = $(shell uname -m) +KERNEL = $(shell uname -s) +BIN_NAME = imapsync_bin_$(KERNEL)_$(ARCH) + hello: - echo "$(VERSION)" - echo "$(IMAPClient)" + @echo "$(VERSION)" + @echo "$(IMAPClient)" + @echo "$(HOSTNAME)" + @echo "$(ARCH)" + @echo "$(KERNEL)" + @echo "$(BIN_NAME)" -all: ChangeLog README VERSION OPTIONS W/imapsync.1 prereq perlcritic imapsync_elf_x86.bin imapsync.exe VERSION_EXE +all: ChangeLog README VERSION OPTIONS W/imapsync.1 prereq perlcritic bin mac imapsync.exe VERSION_EXE testp : sh INSTALL.d/prerequisites_imapsync @@ -107,7 +117,7 @@ clean_man: rm -f imapsync.1 W/imapsync.1: imapsync - pod2man < /dev/null +# pod2man < /dev/null pod2man imapsync > W/imapsync.1 install: testp W/imapsync.1 @@ -207,11 +217,16 @@ W/test2.bat: scp imapsync examples/file.txt W/test2.bat Admin@c:'C:/msys/1.0/home/Admin/imapsync/' ssh Admin@c 'C:/msys/1.0/home/Admin/imapsync/test2.bat' -W/test3.bat: +W/test3.bat: unix2dos W/test3.bat scp imapsync W/test3.bat Admin@c:'C:/msys/1.0/home/Admin/imapsync/' ssh Admin@c 'C:/msys/1.0/home/Admin/imapsync/test3.bat' +W/test_reg.bat: + unix2dos W/test_reg.bat + scp imapsync W/test_reg.bat Admin@c:'C:/msys/1.0/home/Admin/imapsync/' + ssh Admin@c 'C:/msys/1.0/home/Admin/imapsync/test_reg.bat' + W/test_exe_2.bat: unix2dos W/test_exe_2.bat scp imapsync W/test_exe_2.bat Admin@c:'C:/msys/1.0/home/Admin/imapsync/' @@ -228,8 +243,8 @@ test_imapsync_exe: time ssh Admin@c 'C:/msys/1.0/home/Admin/imapsync/test_exe.bat' prereq_win32: - unix2dos W/*.bat examples/*.bat - scp W/install_modules.bat Admin@c:'C:/msys/1.0/home/Admin/imapsync/examples/' + unix2dos W/install_modules.bat + scp W/install_modules.bat Admin@c:'C:/msys/1.0/home/Admin/imapsync/' imapsync.exe: imapsync @@ -271,30 +286,22 @@ zip: dosify_bat # C:\Users\mansour\Desktop\imapsync # vadrouille or petite -imapsync_elf_x86.bin: imapsync + +mac: imapsync rcsdiff imapsync - { test 'vadrouille' = "`hostname`" && \ - pp -o imapsync_elf_x86.bin -I $(IMAPClient_3xx) \ + rsync -p -e 'ssh -p 995' imapsync W/build_mac.sh gilleslamira@gate.polarhome.com: + ssh -p 995 gilleslamira@gate.polarhome.com 'sh build_mac.sh' + rsync -P -e 'ssh -p 995' gilleslamira@gate.polarhome.com:imapsync_bin_Darwin . + +bin: imapsync + rcsdiff imapsync + { pp -o $(BIN_NAME) -I $(IMAPClient_3xx) \ -M Mail::IMAPClient -M IO::Socket -M IO::Socket::SSL \ -M Digest::MD5 -M Digest::HMAC_MD5 -M Term::ReadKey \ -M Authen::NTLM \ imapsync ; \ } || : - { test 'petite' = "`hostname`" && \ - pp -o imapsync_elf_x86.bin -I $(IMAPClient_3xx) \ - -M Mail::IMAPClient -M IO::Socket -M IO::Socket::SSL \ - -M Digest::MD5 -M Digest::HMAC_MD5 -M Term::ReadKey \ - -M Authen::NTLM \ - imapsync ; \ - } || : - { test 'ks200821.kimsufi.com' = "`hostname`" && \ - pp -o imapsync_elf_x86.bin -I $(IMAPClient_3xx) \ - -M Mail::IMAPClient -M IO::Socket -M IO::Socket::SSL \ - -M Digest::MD5 -M Digest::HMAC_MD5 -M Term::ReadKey \ - -M Authen::NTLM \ - imapsync ; \ - } || : - ./imapsync_elf_x86.bin + ./$(BIN_NAME) lfo: upload_lfo @@ -405,7 +412,8 @@ PUBLIC_W = ./W/style.css ./W/tw-hash.html \ ./W/paypal.shtml ./W/paypal_return.shtml -ml: dist_dir +ml: dist_dir + rcsdiff W/ml_announce.in m4 -P W/ml_announce.in | mutt -H- mailq @@ -441,7 +449,7 @@ checklinkext: S/news.shtml S/external.shtml S/imapservers.shtml S/template.shtm upload_index: .valid.index.shtml rcsdiff index.shtml S/*.shtml FAQ FAQ.d/*.txt INSTALL LICENSE CREDITS TODO W/*.bat examples/*.bat index.shtml INSTALL.d/prerequisites_imapsync imapsync - rsync -avH index.shtml FAQ INSTALL OPTIONS NOLIMIT LICENSE CREDITS TODO TUTORIAL.html GOOD_PRACTICES.html imapsync ../imapsync_website/ + rsync -avH index.shtml FAQ INSTALL OPTIONS NOLIMIT LICENSE CREDITS TODO TUTORIAL.html GOOD_PRACTICES.html imapsync imapsync.exe $(BIN_NAME) imapsync_Darwin_$(VERSION) ../imapsync_website/ rsync -avH $(PUBLIC_W) ../imapsync_website/W/ rsync -avH S/ ../imapsync_website/S/ rsync -avH W/images/ ../imapsync_website/W/images/ diff --git a/OPTIONS b/OPTIONS index 4bd519b..00138ad 100644 --- a/OPTIONS +++ b/OPTIONS @@ -72,12 +72,17 @@ Several options are mandatory. --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3. --exclude : or this one, etc. +--subfolder2 : Move whole host1 folders hierarchy under this + host2 folder . + It does it by adding two --regextrans2 options before + all others. Add --debug to see what's really going on. + --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. - Have in mind that --regextrans2 is applied after prefix + Have in mind that --regextrans2 is applied after prefix and separator inversion. --tmpdir : Where to store temporary files and subdirectories. @@ -95,8 +100,8 @@ Several options are mandatory. --prefix1 : Remove prefix to all destination folders (usually INBOX. or INBOX/ or an empty string "") you have to use --prefix1 if host1 imap server - does not have NAMESPACE capability, all other - cases are bad. + does not have NAMESPACE capability, so imapsync + suggests to use it. All other cases are bad. --prefix2 : Add prefix to all host2 folders. See --prefix1 --sep1 : Host1 separator in case NAMESPACE is not supported. --sep2 : Host2 separator in case NAMESPACE is not supported. @@ -106,6 +111,10 @@ Several options are mandatory. --skipmess is applied before --regexmess --skipmess : or this one, etc. +--pipemess : Apply this command to each message content before + the copy. +--pipemess : and this one, etc. + --disarmreadreceipts : Disarms read receipts (host2 Exchange issue) --regexmess : Apply the whole regex to each message before transfer. @@ -213,6 +222,7 @@ Several options are mandatory. --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. +--debugmemory : Debug mode showing memory consumption after each copy. --tests : Run non-regression tests. --testslive : Run a live test with test1.lamiral.info imap server. @@ -238,9 +248,9 @@ Example: to synchronize imap account "test1" on "test1.lamiral.info" --host1 test1.lamiral.info --user1 test1 --password1 secret1 \ --host2 test2.lamiral.info --user2 test2 --password2 secret2 -Here is a [linux] system (Linux petite 3.2.0-77-generic #114-Ubuntu SMP Tue Mar 10 17:25:28 UTC 2015 i686) +Here is a [linux] system (Linux petite 3.2.0-84-generic #121-Ubuntu SMP Tue May 5 18:55:46 UTC 2015 i686) With perl 5.14.2 Mail::IMAPClient 3.35 -$Id: imapsync,v 1.637 2015/04/01 01:36:37 gilles Exp gilles $ +$Id: imapsync,v 1.644 2015/07/17 01:22:52 gilles Exp gilles $ This current imapsync is up to date Homepage: http://imapsync.lamiral.info/ diff --git a/README b/README index 8cc1165..f5ed952 100644 --- a/README +++ b/README @@ -4,7 +4,7 @@ NAME More than 52 different IMAP server softwares supported with success, few failures. - $Revision: 1.637 $ + $Revision: 1.644 $ SYNOPSIS To synchronize imap account "foo" on "imap.truc.org" to imap account @@ -322,120 +322,7 @@ BUG REPORT GUIDELINES it. IMAP SERVERS - Failure stories reported in the past with the following 6 imap servers. - Maybe last imapsync release can run successfully with them. Don't - hesitate to have a try, It's been a long time since last failure - occured, I will help you and make efforts to switch them to the success - list, that's my job. - - - 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). - - (2011) MDaemon 12.0.3 as host2 but MDaemon is supported as host1. - MDaemon is simply buggy with the APPEND IMAP command with - any IMAP email client. - - Hotmail since hotmail.com does not provide IMAP access - - Outlook.com since outlook.com does not provide IMAP access - - Success stories reported with the following 62 imap servers (software - names are in alphabetic order): - - - 1und1 H mimap1 84498 [host1] H mibap4 95231 [host1] - - a1.net imap.a1.net IMAP4 Ready [host1] - - Apple Server 10.6 Snow Leopard [host1] - - Archiveopteryx 2.03, 2.04, 2.09, 2.10 [host2], 3.0.0 [host2] - (OSL 3.0) http://www.archiveopteryx.org/ - - Atmail 6.x [host1] - - Axigen Mail Server Version 8.0.0 - - 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.3, 2.2.6, 2.2.10, 2.2.12, 2.2.13, - 2.3-alpha (OSI Approved), 2.3.1, 2.3.7, 2.3.16 - (http://asg.web.cmu.edu/cyrus/) - - David Tobit V8 (proprietary Message system). - - Deerfield VisNetic MailServer 5.8.6 [host1] (http://www.deerfield.net/products/visnetic-mailserver/) - - DBMail 1.2.1, 2.0.4, 2.0.9, 2.2rc1 (GPL) (http://www.dbmail.org/). - 2.0.7 seems buggy. - - DBOX 2.41 System [host1] (http://www.dbox.handshake.de/). - - 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], 8.5.3 [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 - - FirtClass 9 [host1] Read the FAQ! (http://www.firstclass.com/) - - FTGate (http://www.ftgate.com/) - - Fusemail imap.fusemail.net:143 (https://www.fusemail.com/). - - Gimap (Gmail imap) - - GMX IMAP4 StreamProxy. - - Groupwise IMAP (Novell) 6.x and 7.0. Buggy so see the FAQ. - - hMailServer 5.40-B1950 [host12], 5.3.3 [host2], 4.4.1 [host1] (see FAQ) - - IceWarp Server 10.4.5 [host1] (http://www.icewarp.com/) - - iPlanet Messaging server 4.15, 5.1, 5.2 - - IMail 7.15 (Ipswitch/Win2003), 8.12, 11.03 [host1] - - Kerio 7.2.0 Patch 1 [host12], Kerio 8 [host1] - - Mail2World IMAP4 Server 2.5 [host1] (http://www.mail2world.com/) - - MailEnable 4.23 [host1] [host2], 4.26 [host1][host2], 5 [host1] - - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform), - 9.6.5 [host1], 12 [host2], 12.0.3 [host1], 12.5.5 [host1], - 13.5 [host2], 14.5 [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, 4.1.9-GA [host1] - - Netscape Mail Server 3.6 (Wintel !) - - Netscape Messaging Server 4.15 Patch 7 - - Office 365 [host1] [host2] - - OpenMail IMAP server B.07.00.k0 (Samsung Contact ?) - - OpenWave - - Oracle Beehive [host1] - - Parallels Plesk Panel 9.x [host2] 11.x [host2] (http://www.parallels.com/) - - Qualcomm Worldmail (NT) - - QQMail IMAP4Server [host1] [host2] https://en.mail.qq.com/ - - RackSpace hoster secure.emailsrvr.com:993 http://www.rackspace.com/ - - 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, 11.4.6 - - Sendmail Mail Store IMAP4rev1 (5.5.6/mstore-5-5-build-1874 [host1]. - - SmarterMail, Smarter Mail 5.0 Enterprise, Smarter Mail 5.5 [host1], - SmarterMail Professional 10.2 [host1], Smarter Mail 11.7 [host1][host2]. - - Softalk Workgroup Mail 7.6.4 [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, 6.3d-72 [host2] - - 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 - - Yahoo [host1] - - Zarafa 6,40,0,20653 [host1] (http://www.zarafa.com/) - - Zarafa ZCP 7.1.4 IMAP Gateway [host2] - - 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 + See http://imapsync.lamiral.info/S/imapservers.shtml HUGE MIGRATION Pay special attention to options --subscribed --subscribe --delete @@ -500,5 +387,5 @@ SIMILAR SOFTWARES Feedback (good or bad) will often be welcome. - $Id: imapsync,v 1.637 2015/04/01 01:36:37 gilles Exp gilles $ + $Id: imapsync,v 1.644 2015/07/17 01:22:52 gilles Exp gilles $ diff --git a/S/imapservers.shtml b/S/imapservers.shtml index df71f1c..8b5306b 100755 --- a/S/imapservers.shtml +++ b/S/imapservers.shtml @@ -29,43 +29,70 @@

Let's start with the long reported success stories list: -62 different imap server softwares supported!
+63 different imap server softwares supported!
[host1] means "source server" and [host2] means "destination server":

+

Please report to the author (gilles.lamiral@laposte.net) 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. +Examples:

+
+  imapsync --host1 test1.lamiral.info --host2 test2.lamiral.info --justconnect
+
+  imapsync --host1 imap.gmail.com --ssl1 --host2 imap-mail.outlook.com --ssl2 --justconnect
+
+ +

And now the success imap server software list:

Let's finish with reported failure stories over the past.
@@ -177,7 +202,7 @@ alt="Viewable With Any Browser" /> This document last modified on -($Id: imapservers.shtml,v 1.1 2015/03/29 17:24:01 gilles Exp gilles $)
+($Id: imapservers.shtml,v 1.6 2015/06/23 10:45:34 gilles Exp gilles $)
Top of the page

diff --git a/TODO b/TODO index 7698a48..5d20957 100644 --- a/TODO +++ b/TODO @@ -1,5 +1,5 @@ #!/bin/cat -# $Id: TODO,v 1.135 2015/03/31 14:56:25 gilles Exp gilles $ +# $Id: TODO,v 1.140 2015/07/17 17:36:22 gilles Exp gilles $ TODO file for imapsync ---------------------- @@ -19,6 +19,41 @@ MB GB TB + +2015_06_02 Karen F Bath. +Add skipped messages in the final dump. +I would like to request if you could add additional errors to the bottom, as we find that things like “MaxLineLength” and “maxsize limit” are classed as skipped messages and in my opinion are errors; as the email message is not transferred but this is not logged at the bottom. +We have our own scan script which we run on all log files at the end and copy the users logs into subfolders that have issues. I’ve attached a list of things we search for. + +"Error", "Output" +NO Mailbox already exists, "Folder" +NO LOGIN failed, "NoLogin" +Could not create folder, "Linux" +Error sending, "Linux" +Write failed 'no error caught', "Linux" +line length exceeds maxlinelength, "Linux" +BAD Command Argument Error. 11, "Linux" +Failure: can not open, "Linux" +No not connected, "Linux" +Write failed 'Connection reset by peer', "Linux" +could not be fetched:, "Linux" +NO Mailbox does not exist,"Error" +exceeds maxsize limit 20971520 bytes,"Error" +error while reading data from server: Connection reset by peer (4x),"Error" +Folder [Inbox] already exists,"Error" + + +2015_05_18 +I'd like to be able to print the messages subjects, on some logs: +For instance: + msg INBOX.Archived/95551 marked \Deleted on host2 [GyDD6WpsFEtyBzNFnv] + msg [Gmail]/All Mail/281079 copying to INBOX.Archived +It would be great to be able to print the email subject, in order to debug or to get more useful information. + + +2015_04_25 +Add duplicates test option. + 2015_03_24 Add --sslargs with usage like: imapsync ... --sslargs 'SSL_version=' --sslargs 'SSL_use_cert=1' \ @@ -27,6 +62,7 @@ See perldoc IO::Socket::SSL for all possibilities. + 2015_03_06 Dealing with Content-Type Message/Partial Extract the components of the partial messages and construct them @@ -165,6 +201,20 @@ http://asg.web.cmu.edu/cyrus/download/imapd/altnamespace.html Now the TODO done! (or not) =========================================================================== +DONE. Build and distribute a standalone Darwin Mac OS X binary. +It's called imapsync_bin_Darwin + + +DONE. Add a NOP for host2 for each fake copy in --dry mode. +Goal is to avoid timeouts happening only because of --dry + +DONE 2015_05_09 WANTED 2015_04_25 +Add an option "--subfolder2 FOO" to move all folders to a subfolder FOO: +On Windows: + --regextrans2 "s,${h2_prefix}(.*),${h2_prefix}FOO${h2_sep}$1," \ + --regextrans2 "s,^INBOX$,${h2_prefix}FOO${h2_sep}INBOX," + + WON'T DO. Not enough examples. Can you setup an option to make it stop if the destination mailbox reports that it is over quota? @@ -363,9 +413,9 @@ DONE. Write option --delete2foldersonly regex. Example: to permit a sync in a subfolder with --delete2folder --regextrans2 's#(.*)#NEW/$1#' --delete2foldersonly /^NEW/ -DONE. Write option --delete2foldersnot regex. +DONE. Write option --delete2foldersbutnot regex. Example: to permit a sync but not deleting folder OLD ---delete2foldersnot /^OLD/ +--delete2foldersbutnot /^OLD/ DONE. Add cache to speed up transfer. Option --usecache diff --git a/TUTORIAL.html b/TUTORIAL.html index 01ead26..0b54e1b 100644 --- a/TUTORIAL.html +++ b/TUTORIAL.html @@ -1,18 +1,19 @@ - + - - +
+

+ @@ -20,24 +21,45 @@

+

Tutorial for imapsync

+ -

Introduction

+

Background knowledge about emailboxes

+

Three Internet protocols are used to access almost all email accounts: -POP, IMAP, HTTP. +POP3, IMAP, HTTP.

-The oldest one is POP, Post Office Protocol, it allows only -one main box, also called INBOX. -The second protocol is IMAP, Internet Message Access Protocol, which allows -a hierarchy of mailboxes also called folders, it also allows concurrent accesses, +The oldest one still used is POP3, Post Office Protocol. POP3 allows only +one main box called INBOX. With POP3 messages have no flags, no Seen/UnSeen +Forwarded Flagged labels. Messages are often +removed from the POP3 server each time a software client looks into it, +so messages only appear on the client host that fetched them, they are +unavailable from any other system located elsewhere. +

+

+The second protocol to deal with email messages is IMAP, Internet Message Access Protocol. + IMAP allows a hierarchy of mailboxes also called folders, concurrent accesses, tagging with flags, search by many criterium like date, subject, size etc. -The third protocol is HTTP, HyperText Transfer Protocol, via webmails. -Webmails often offer the same features than imap servers and, -since webmails background is often an imap server, -a parallel access via IMAP. +IMAP protocol presents most of the features POP lacks. +Messages stay on the imap server so any client on the network can access them +at any time from anywhere, the same messages with the same flags. +

+

+The third protocol to access email messages is HTTP, HyperText Transfer Protocol. +HTTP is the protocol to surf the web. +Web browsers like Google Chrome, Mozilla Firefox, Internet Explorer, Safari, +are HTTP client softwares. +Webmails often offer the same features than imap servers because +webmails underlying storage systems are often imap servers. +So webmail mailboxes like Gmail, Yahoo, Exchange, Zimbra or Office365 are also accessible via imap. +

+

+The conclusion of this protocol review is that IMAP can be used +to access mailboxes most of the time. Here comes imapsync.

Software imapsync is a command line tool to @@ -47,9 +69,9 @@ copy, migrate, backup or synchronize IMAP mailboxes. Command line means imapsync is not graphical, it is textual, you have to type characters on your keyboard. Your fingers will not suffer anyway because -I wrote examples nearly ready to go. +I wrote file examples nearly ready to go. Most of the time you only have to change values -and adapt them to your context. +in those files and adapt them to your context.

Do not be afraid, the mouse will not be forsaken. @@ -63,9 +85,9 @@ It is because imapsync is written in the Perl language and thanks to the Perl creators Perl runs everywhere. Outside imapsync life is different; Historically Windows came after Unix and the marvelous designers -of this old time decided it would be very cool +in this old times decided it would be very cool to not share the same syntax for doing the same things. -Thanks guys, great thinking! +Thanks guys, great thinking!

To avoid you to learn by headaches a system you do not master @@ -73,8 +95,10 @@ I will give all examples in both worlds, Unix and Windows. Macintosh users are in the Unix world now but do not tell them, it can hurt the olders.

+

Conventions

+

Imapsync has many options but you can ignore most of them and still make great transfers. @@ -92,6 +116,7 @@ or the "^" character on Windows examples.

For example, on Unix

+ 
     imapsync \
        --host1 imap.truc.org \
@@ -99,31 +124,35 @@ For example, on Unix
        --password1 secret1 \
        ...
+

is equivalent to

+ 
     imapsync --host1 imap.truc.org --user1 foo --password1 secret1 ...
-

+

and on Windows

+ 
-    imapsync ^
+    imapsync.exe ^
        --host1 imap.truc.org ^
        --user1 foo ^
        --password1 secret1 ^
        ...
+

is equivalent to

+ 
     imapsync --host1 imap.truc.org --user1 foo --password1 secret1 ...
-

- + diff --git a/VERSION b/VERSION index 4ac1755..6f8061d 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -1.637 +1.644 diff --git a/VERSION_EXE b/VERSION_EXE index 4ac1755..6f8061d 100644 --- a/VERSION_EXE +++ b/VERSION_EXE @@ -1 +1 @@ -1.637 +1.644 diff --git a/W/.BUILD_EXE_TIME b/W/.BUILD_EXE_TIME index cd7eccc..20eccf0 100644 --- a/W/.BUILD_EXE_TIME +++ b/W/.BUILD_EXE_TIME @@ -314,3 +314,15 @@ 1427815136 END 1.636 : mardi 31 mars 2015, 17:18:56 (UTC+0200) 1427853312 BEGIN 1.637 : mercredi 1 avril 2015, 03:55:12 (UTC+0200) 1427854440 END 1.637 : mercredi 1 avril 2015, 04:14:00 (UTC+0200) +1431218601 BEGIN 1.641 : dimanche 10 mai 2015, 02:43:21 (UTC+0200) +1431262946 END 1.641 : dimanche 10 mai 2015, 15:02:26 (UTC+0200) +1431414203 BEGIN 1.642 : mardi 12 mai 2015, 09:03:23 (UTC+0200) +1432116391 BEGIN 1.642 : mercredi 20 mai 2015, 12:06:31 (UTC+0200) +1432138982 BEGIN 1.642 : mercredi 20 mai 2015, 18:23:02 (UTC+0200) +1432140305 END 1.642 : mercredi 20 mai 2015, 18:45:05 (UTC+0200) +1435274638 BEGIN 1.643 : vendredi 26 juin 2015, 01:23:58 (UTC+0200) +1435275180 END 1.643 : vendredi 26 juin 2015, 01:33:00 (UTC+0200) +1435279579 BEGIN 1.643 : vendredi 26 juin 2015, 02:46:19 (UTC+0200) +1435280203 END 1.643 : vendredi 26 juin 2015, 02:56:43 (UTC+0200) +1437158716 BEGIN 1.644 : vendredi 17 juillet 2015, 20:45:16 (UTC+0200) +1437160124 END 1.644 : vendredi 17 juillet 2015, 21:08:44 (UTC+0200) diff --git a/W/Mail-IMAPClient-3.35/lib/Mail/IMAPClient.pm b/W/Mail-IMAPClient-3.35/lib/Mail/IMAPClient.pm index 6e77c85..5681f8a 100644 --- a/W/Mail-IMAPClient-3.35/lib/Mail/IMAPClient.pm +++ b/W/Mail-IMAPClient-3.35/lib/Mail/IMAPClient.pm @@ -2148,7 +2148,7 @@ sub fetch_hash { if ( $words[0] eq 'ALL' ) { $msgs = shift @words; } - elsif ( $words[0] =~ s/^([,:\d]+)\s*// ) { + elsif ( $words[0] =~ s/^([,:\d\*]+)\s*// ) { $msgs = $1; shift @words if $words[0] eq ""; } diff --git a/W/Mail-IMAPClient-3.35/lib/Mail/IMAPClient.pm-3.35 b/W/Mail-IMAPClient-3.35/lib/Mail/IMAPClient.pm-3.35 new file mode 100644 index 0000000..6e77c85 --- /dev/null +++ b/W/Mail-IMAPClient-3.35/lib/Mail/IMAPClient.pm-3.35 @@ -0,0 +1,3482 @@ + +# _{name} methods are undocumented and meant to be private. + +require 5.008_001; + +use strict; +use warnings; + +package Mail::IMAPClient; +our $VERSION = '3.35'; + +use Mail::IMAPClient::MessageSet; + +use IO::Socket qw(:crlf SOL_SOCKET SO_KEEPALIVE); +use IO::Select (); +use Carp qw(carp); #local $SIG{__WARN__} = \&Carp::cluck; #DEBUG + +use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); +use Errno qw(EAGAIN EBADF ECONNRESET EPIPE); +use List::Util qw(first min max sum); +use MIME::Base64 qw(encode_base64 decode_base64); +use File::Spec (); + +use constant APPEND_BUFFER_SIZE => 1024 * 1024; + +use constant { + Unconnected => 0, + Connected => 1, # connected; not logged in + Authenticated => 2, # logged in; no mailbox selected + Selected => 3, # mailbox selected +}; + +use constant { + INDEX => 0, # Array index for output line number + TYPE => 1, # Array index for line type (OUTPUT, INPUT, or LITERAL) + DATA => 2, # Array index for output line data +}; + +my %SEARCH_KEYS = map { ( $_ => 1 ) } qw( + ALL ANSWERED BCC BEFORE BODY CC DELETED DRAFT FLAGGED + FROM HEADER KEYWORD LARGER NEW NOT OLD ON OR RECENT + SEEN SENTBEFORE SENTON SENTSINCE SINCE SMALLER SUBJECT + TEXT TO UID UNANSWERED UNDELETED UNDRAFT UNFLAGGED + UNKEYWORD UNSEEN); + +# modules require(d) during runtime when applicable +my %Load_Module = ( + "Compress-Zlib" => "Compress::Zlib", + "INET" => "IO::Socket::INET", + "SSL" => "IO::Socket::SSL", + "UNIX" => "IO::Socket::UNIX", + "BodyStructure" => "Mail::IMAPClient::BodyStructure", + "Envelope" => "Mail::IMAPClient::BodyStructure::Envelope", + "Thread" => "Mail::IMAPClient::Thread", +); + +sub _load_module { + my $self = shift; + my $modkey = shift; + my $module = $Load_Module{$modkey} || $modkey; + + my $err = do { + local ($@); + eval "require $module"; + $@; + }; + if ($err) { + $self->LastError("Unable to load '$module': $err"); + return undef; + } + return $module; +} + +sub _debug { + my $self = shift; + return unless $self->Debug; + + my $text = join '', @_; + $text =~ s/$CRLF/\n /og; + $text =~ s/\s*$/\n/; + + #use POSIX (); $text = POSIX::strftime("%F %T ", localtime).$text; #DEBUG + my $fh = $self->{Debug_fh} || \*STDERR; + print $fh $text; +} + +BEGIN { + + # set-up accessors + foreach my $datum ( + qw(Authcallback Authmechanism Authuser Buffer Count Compress + Debug Debug_fh Domain Folder Ignoresizeerrors Keepalive + Maxappendstringlength Maxcommandlength Maxtemperrors + Password Peek Port Prewritemethod Proxy Ranges Readmethod + Readmoremethod Reconnectretry Server Showcredentials + Socketargs Ssl Starttls Supportedflags Timeout Uid User) + ) + { + no strict 'refs'; + *$datum = sub { + @_ > 1 ? ( $_[0]->{$datum} = $_[1] ) : $_[0]->{$datum}; + }; + } +} + +sub LastError { + my $self = shift; + @_ or return $self->{LastError}; + my $err = shift; + + # allow LastError to be reset with undef + if ( defined $err ) { + $err =~ s/$CRLF$//og; + local ($!); # old versions of Carp could reset $! + $self->_debug( Carp::longmess("ERROR: $err") ); + + # hopefully this is rare... + if ( $err eq "NO not connected" ) { + my $lerr = $self->{LastError} || ""; + my $emsg = "Trying command when NOT connected!"; + $emsg .= " LastError was: $lerr" if $lerr; + Carp::cluck($emsg); + } + } + + # 2.x API support requires setting $@ + $@ = $self->{LastError} = $err; +} + +sub Fast_io(;$) { + my ( $self, $use ) = @_; + defined $use + or return $self->{Fast_io}; + + my $socket = $self->{Socket} + or return undef; + + local ( $@, $! ); # avoid stomping on globals + unless ($use) { + eval { fcntl( $socket, F_SETFL, delete $self->{_fcntl} ) } + if exists $self->{_fcntl}; + $self->{Fast_io} = 0; + return undef; + } + + my $fcntl = eval { fcntl( $socket, F_GETFL, 0 ) }; + if ($@) { + $self->{Fast_io} = 0; + $self->_debug("not using Fast_IO; not available on this platform") + unless $self->{_fastio_warning_}++; + return undef; + } + + $self->{Fast_io} = 1; + my $newflags = $self->{_fcntl} = $fcntl; + $newflags |= O_NONBLOCK; + fcntl( $socket, F_SETFL, $newflags ); +} + +# removed +sub EnableServerResponseInLiteral { undef } + +sub Wrap { shift->Clear(@_) } + +# The following class method is for creating valid dates in appended msgs: +my @dow = qw(Sun Mon Tue Wed Thu Fri Sat); +my @mnt = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); + +sub Rfc822_date { + my $class = shift; + my $date = $class =~ /^\d+$/ ? $class : shift; # method or function? + my @date = gmtime($date); + + #Date: Fri, 09 Jul 1999 13:10:55 -0000 + sprintf( + "%s, %02d %s %04d %02d:%02d:%02d -%04d", + $dow[ $date[6] ], + $date[3], + $mnt[ $date[4] ], + $date[5] + 1900, + $date[2], $date[1], $date[0], $date[8] + ); +} + +# The following methods create valid dates for use in IMAP search strings +# - provide Rfc2060* methods/functions for backwards compatibility +sub Rfc2060_date { + $_[0] =~ /^\d+$/ ? Rfc3501_date(@_) : shift->Rfc3501_date(@_); +} + +sub Rfc3501_date { + my $class = shift; + my $stamp = $class =~ /^\d+$/ ? $class : shift; + my @date = gmtime($stamp); + + # 11-Jan-2000 + sprintf( "%02d-%s-%04d", $date[3], $mnt[ $date[4] ], $date[5] + 1900 ); +} + +sub Rfc2060_datetime($;$) { + $_[0] =~ /^\d+$/ ? Rfc3501_datetime(@_) : shift->Rfc3501_datetime(@_); +} + +sub Rfc3501_datetime($;$) { + my $class = shift; + my $stamp = $class =~ /^\d+$/ ? $class : shift; + my $zone = shift || '+0000'; + my @date = gmtime($stamp); + + # 11-Jan-2000 04:04:04 +0000 + sprintf( + "%02d-%s-%04d %02d:%02d:%02d %s", + $date[3], + $mnt[ $date[4] ], + $date[5] + 1900, + $date[2], $date[1], $date[0], $zone + ); +} + +# Change CRLF into \n +sub Strip_cr { + my $class = shift; + if ( !ref $_[0] && @_ == 1 ) { + ( my $string = $_[0] ) =~ s/$CRLF/\n/og; + return $string; + } + + return wantarray + ? map { s/$CRLF/\n/og; $_ } ( ref $_[0] ? @{ $_[0] } : @_ ) + : [ map { s/$CRLF/\n/og; $_ } ( ref $_[0] ? @{ $_[0] } : @_ ) ]; +} + +# The following defines a special method to deal with the Clear parameter: +sub Clear { + my ( $self, $clear ) = @_; + defined $clear or return $self->{Clear}; + + my $oldclear = $self->{Clear}; + $self->{Clear} = $clear; + + my @keys = reverse $self->_trans_index; + + for ( my $i = $clear ; $i < @keys ; $i++ ) { + delete $self->{History}{ $keys[$i] }; + } + + return $oldclear; +} + +# read-only access to the transaction number +sub Transaction { shift->Count } + +# remove doubles from list +sub _remove_doubles(@) { + my %seen; + grep { !$seen{ $_->{name} }++ } @_; +} + +# the constructor: +sub new { + my $class = shift; + my $self = { + LastError => "", + Uid => 1, + Count => 0, + Clear => 2, + Keepalive => 0, + Maxappendstringlength => 1024**2, + Maxcommandlength => 1000, + Maxtemperrors => undef, + State => Unconnected, + Authmechanism => 'LOGIN', + Timeout => 600, + History => {}, + }; + while (@_) { + my $k = ucfirst lc shift; + my $v = shift; + $self->{$k} = $v if defined $v; + } + bless $self, ref($class) || $class; + + # Fast_io is enabled by default when not given a socket + unless ( exists $self->{Fast_io} || $self->{Socket} || $self->{Rawsocket} ) + { + $self->{Fast_io} = 1; + } + + if ( my $sup = $self->{Supportedflags} ) { # unpack into case-less HASH + my %sup = map { m/^\\?(\S+)/ ? lc $1 : () } @$sup; + $self->{Supportedflags} = \%sup; + } + + $self->{Debug_fh} ||= \*STDERR; + CORE::select( ( select( $self->{Debug_fh} ), $|++ )[0] ); + + if ( $self->Debug ) { + $self->_debug( "Started at " . localtime() ); + $self->_debug("Using Mail::IMAPClient version $VERSION on perl $]"); + } + + # BUG? return undef on Socket() failure? + $self->Socket( $self->{Socket} ) + if $self->{Socket}; + + if ( $self->{Rawsocket} ) { + my $sock = delete $self->{Rawsocket}; + + # Ignore Rawsocket if Socket is set. BUG? should we carp/croak? + $self->RawSocket($sock) unless $self->{Socket}; + } + + if ( !$self->{Socket} && $self->{Server} ) { + $self->connect or return undef; + } + return $self; +} + +sub connect(@) { + my $self = shift; + + # BUG? We should restrict which keys can be passed/set here. + %$self = ( %$self, @_ ) if @_; + + my @sockargs = $self->Timeout ? ( Timeout => $self->Timeout ) : (); + push( @sockargs, $self->Debug ? ( Debug => $self->Debug ) : () ); + + # give caller control of IO::Socket::... args to new if desired + if ( $self->Socketargs and ref $self->Socketargs eq "ARRAY" ) { + push( @sockargs, @{ $self->Socketargs } ); + } + + my $server = $self->Server; + my $port = $self->Port || $self->Port( $self->Ssl ? "993" : "143" ); + my ( $ioclass, $sock ); + + if ( File::Spec->file_name_is_absolute($server) ) { + $ioclass = $self->_load_module("UNIX"); + unshift( @sockargs, Peer => $server ); + } + else { + unshift( + @sockargs, + PeerAddr => $server, + PeerPort => $port, + Proto => "tcp", + ); + + # extra control of SSL args is supported + if ( $self->Ssl ) { + $ioclass = $self->_load_module("SSL"); + push( @sockargs, @{ $self->Ssl } ) if ref $self->Ssl eq "ARRAY"; + } + else { + $ioclass = $self->_load_module("INET"); + } + } + + if ($ioclass) { + $self->_debug("Connecting with $ioclass @sockargs"); + $sock = $ioclass->new(@sockargs); + } + + if ($sock) { + $self->_debug( "Connected to $server" . ( $! ? " errno($!)" : "" ) ); + return $self->Socket($sock); + } + else { + my $lasterr = $self->LastError || ""; + $self->LastError("Unable to connect to $server: $lasterr"); + return undef; + } +} + +sub RawSocket(;$) { + 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 ); + + return $sock; +} + +sub Socket($) { + my ( $self, $sock ) = @_; + defined $sock + or return $self->{Socket}; + + $self->RawSocket($sock); + $self->State(Connected); + + setsockopt( $sock, SOL_SOCKET, SO_KEEPALIVE, 1 ) if $self->Keepalive; + + # LastError may be set by _read_line via _get_response + # look for "* (OK|BAD|NO|PREAUTH)" + my $code = $self->_get_response( '*', 'PREAUTH' ) or return undef; + + if ( $code eq 'BYE' || $code eq 'NO' ) { + $self->State(Unconnected); + return undef; + } + elsif ( $code eq 'PREAUTH' ) { + $self->State(Authenticated); + return $self; + } + + if ( $self->Starttls ) { + $self->starttls or return undef; + } + + if ( defined $self->User && defined $self->Password ) { + $self->login or return undef; + } + + return $self->{Socket}; +} + +# RFC2595 section 3.1 +sub starttls { + my ($self) = @_; + + # BUG? RFC requirement checks commented out for now... + #if ( $self->IsUnconnected or $self->IsAuthenticated ) { + # $self->LastError("NO must be connected but not authenticated"); + # return undef; + #} + + # BUG? strict check on capability commented out for now... + #return undef unless $self->has_capability("STARTTLS"); + + $self->_imap_command("STARTTLS") or return undef; + + # MUST discard cached capability info; should re-issue capability command + delete $self->{CAPABILITY}; + + my $ioclass = $self->_load_module("SSL") or return undef; + my $sock = $self->RawSocket; + my $blocking = $sock->blocking; + + # BUG: force blocking for now + $sock->blocking(1); + + # give caller control of args to start_SSL if desired + my @sslargs = + ( $self->Starttls and ref( $self->Starttls ) eq "ARRAY" ) + ? ( @{ $self->Starttls } ) + : ( Timeout => 30 ); + + unless ( $ioclass->start_SSL( $sock, @sslargs ) ) { + $self->LastError( "Unable to start TLS: " . $ioclass->errstr ); + return undef; + } + + # return blocking to previous setting + $sock->blocking($blocking); + + return $self; +} + +# RFC4978 COMPRESS +sub compress { + my ($self) = @_; + + # BUG? strict check on capability commented out for now... + #my $can = $self->has_capability("COMPRESS") + #return undef unless $can and $can eq "DEFLATE"; + + $self->_imap_command("COMPRESS DEFLATE") or return undef; + + my $zcl = $self->_load_module("Compress-Zlib") or return undef; + + # give caller control of args if desired + $self->Compress( + [ + -WindowBits => -$zcl->MAX_WBITS(), + -Level => $zcl->Z_BEST_SPEED() + ] + ) unless ( $self->Compress and ref( $self->Compress ) eq "ARRAY" ); + + my ( $rc, $do, $io ); + + ( $do, $rc ) = Compress::Zlib::deflateInit( @{ $self->Compress } ); + unless ( $rc == $zcl->Z_OK ) { + $self->LastError("deflateInit failed (rc=$rc)"); + return undef; + } + + ( $io, $rc ) = + Compress::Zlib::inflateInit( -WindowBits => -$zcl->MAX_WBITS() ); + unless ( $rc == $zcl->Z_OK ) { + $self->LastError("inflateInit failed (rc=$rc)"); + return undef; + } + + $self->{Prewritemethod} = sub { + my ( $imap, $string ) = @_; + + my ( $rc, $out1, $out2 ); + ( $out1, $rc ) = $do->deflate($string); + ( $out2, $rc ) = $do->flush( $zcl->Z_PARTIAL_FLUSH() ) + unless ( $rc != $zcl->Z_OK ); + + unless ( $rc == $zcl->Z_OK ) { + $self->LastError("deflate/flush failed (rc=$rc)"); + return undef; + } + + return $out1 . $out2; + }; + + # need to retain some state for Readmoremethod/Readmethod calls + my ( $Zbuf, $Ibuf ) = ( "", "" ); + + $self->{Readmoremethod} = sub { + my $self = shift; + return 1 if ( length($Zbuf) || length($Ibuf) ); + $self->__read_more(@_); + }; + + $self->{Readmethod} = sub { + my ( $imap, $fh, $buf, $len, $off ) = @_; + + # get more data, but empty $Ibuf first if any data is left + my ( $lz, $li ) = ( length $Zbuf, length $Ibuf ); + if ( $lz || !$li ) { + my $ret = sysread( $fh, $Zbuf, $len, length $Zbuf ); + $lz = length $Zbuf; + return $ret if ( !$ret && !$lz ); # $ret is undef or 0 + } + + # accumulate inflated data in $Ibuf + if ($lz) { + my ( $tbuf, $rc ) = $io->inflate( \$Zbuf ); + unless ( $rc == $zcl->Z_OK ) { + $self->LastError("inflate failed (rc=$rc)"); + return undef; + } + $Ibuf .= $tbuf; + } + + # pull desired length of data from $Ibuf + my $tbuf = substr( $Ibuf, 0, $len ); + substr( $Ibuf, 0, $len ) = ""; + substr( $$buf, $off ) = $tbuf; + + return length $tbuf; + }; + + return $self; +} + +sub login { + my $self = shift; + my $auth = $self->Authmechanism; + + if ( $auth && $auth ne 'LOGIN' ) { + $self->authenticate( $auth, $self->Authcallback ) + or return undef; + } + else { + my $user = $self->User; + my $passwd = $self->Password; + + return undef unless ( defined($passwd) and defined($user) ); + + $user = ( $user eq "" ) ? qq("") : $self->Quote($user); + $passwd = ( $passwd eq "" ) ? qq("") : $self->Quote($passwd); + + $self->_imap_command("LOGIN $user $passwd") + or return undef; + } + + $self->State(Authenticated); + if ( $self->Compress ) { + $self->compress or return undef; + } + return $self; +} + +sub noop { + my ($self) = @_; + $self->_imap_command("NOOP") ? $self->Results : undef; +} + +sub proxyauth { + my ( $self, $user ) = @_; + $user = ( $user eq "" ) ? qq("") : $self->Quote($user); + $self->_imap_command("PROXYAUTH $user") ? $self->Results : undef; +} + +sub separator { + my ( $self, $target ) = @_; + unless ( defined $target ) { + + # separator is namespace's 1st thing's 1st thing's 2nd thing: + my $ns = $self->namespace or return undef; + if ($ns) { + my $sep = $ns->[0][0][1]; + return $sep if $sep; + } + $target = ''; + } + + return $self->{separators}{$target} + if exists $self->{separators}{$target}; + + my $list = $self->list( undef, $target ) or return undef; + + foreach my $line (@$list) { + my $rec = $self->_list_or_lsub_response_parse($line); + next unless defined $rec->{name}; + $self->{separators}{ $rec->{name} } = $rec->{delim}; + } + return $self->{separators}{$target}; +} + +# BUG? caller gets empty list even if Error +# - returning an array with a single undef value seems even worse though +sub sort { + my ( $self, $crit, @a ) = @_; + + $crit =~ /^\(.*\)$/ # wrap criteria in parens + or $crit = "($crit)"; + + my @hits; + if ( $self->_imap_uid_command( SORT => $crit, @a ) ) { + my @results = $self->History; + foreach (@results) { + chomp; + s/$CR$//; + s/^\*\s+SORT\s+// or next; + push @hits, grep /\d/, split; + } + } + return wantarray ? @hits : \@hits; +} + +sub _list_or_lsub { + my ( $self, $cmd, $reference, $target ) = @_; + defined $reference or $reference = ''; + defined $target or $target = '*'; + length $target or $target = '""'; + + $target eq '*' || $target eq '""' + or $target = $self->Quote($target); + + $self->_imap_command(qq($cmd "$reference" $target)) + or return undef; + + return wantarray ? $self->Escaped_history : $self->Escaped_results; +} + +sub list { shift->_list_or_lsub( "LIST", @_ ) } +sub lsub { shift->_list_or_lsub( "LSUB", @_ ) } + +# deprecated 3.34 +sub xlist { + my ($self) = @_; + return undef unless $self->has_capability("XLIST"); + shift->_list_or_lsub( "XLIST", @_ ); +} + +sub _folders_or_subscribed { + my ( $self, $method, $what ) = @_; + my @folders; + + # do BLOCK allowing use of "last if undef/error" and avoiding dup code + do { + { + my @list; + if ($what) { + my $sep = $self->separator($what) || $self->separator(undef); + last unless defined $sep; + + my $whatsub = $what =~ m/\Q${sep}\E$/ ? "$what*" : "$what$sep*"; + + my $tref = $self->$method( undef, $whatsub ) or last; + shift @$tref; # remove command + push @list, @$tref; + + # BUG?: this behavior has been around since 2.x, why? + my $cansel = $self->selectable($what); + last unless defined $cansel; + if ($cansel) { + $tref = $self->$method( undef, $what ) or last; + shift @$tref; # remove command + push @list, @$tref; + } + } + else { + my $tref = $self->$method( undef, undef ) or last; + shift @$tref; # remove command + push @list, @$tref; + } + + foreach my $resp (@list) { + my $rec = $self->_list_or_lsub_response_parse($resp); + next unless defined $rec->{name}; + push @folders, $rec; + } + } + }; + + my @clean = _remove_doubles @folders; + return wantarray ? @clean : \@clean; +} + +sub folders { + my ( $self, $what ) = @_; + + my @folders = + map( $_->{name}, $self->_folders_or_subscribed( "list", $what ) ); + return wantarray ? @folders : \@folders; +} + +sub folders_hash { + my ( $self, $what ) = @_; + + my @folders_hash = $self->_folders_or_subscribed( "list", $what ); + return wantarray ? @folders_hash : \@folders_hash; +} + +# deprecated 3.34 +sub xlist_folders { + my ($self) = @_; + my $xlist = $self->xlist; + return undef unless defined $xlist; + + my %xlist; + my $xlist_re = qr/\A\\(Inbox|AllMail|Trash|Drafts|Sent|Spam|Starred)\Z/; + + for my $resp (@$xlist) { + my $rec = $self->_list_or_lsub_response_parse($resp); + next unless defined $rec->{name}; + for my $attr ( @{ $rec->{attrs} } ) { + $xlist{$1} = $rec->{name} if ( $attr =~ $xlist_re ); + } + } + + return wantarray ? %xlist : \%xlist; +} + +sub subscribed { + my ( $self, $what ) = @_; + my @folders = + map( $_->{name}, $self->_folders_or_subscribed( "lsub", $what ) ); + return wantarray ? @folders : \@folders; +} + +sub deleteacl { + my ( $self, $target, $user ) = @_; + $target = $self->Quote($target); + $user = ( $user eq "" ) ? qq("") : $self->Quote($user); + + $self->_imap_command(qq(DELETEACL $target $user)) + or return undef; + + return wantarray ? $self->History : $self->Results; +} + +sub setacl { + my ( $self, $target, $user, $acl ) = @_; + $target ||= $self->Folder; + $target = $self->Quote($target); + + $user ||= $self->User; + $user = ( $user eq "" ) ? qq("") : $self->Quote($user); + $acl = ( $acl eq "" ) ? qq("") : $self->Quote($acl); + + $self->_imap_command(qq(SETACL $target $user $acl)) + or return undef; + + return wantarray ? $self->History : $self->Results; +} + +sub getacl { + my ( $self, $target ) = @_; + defined $target or $target = $self->Folder; + my $mtarget = $self->Quote($target); + $self->_imap_command(qq(GETACL $mtarget)) + or return undef; + + my @history = $self->History; + my $hash; + for ( my $x = 0 ; $x < @history ; $x++ ) { + next if $history[$x] !~ /^\* ACL/; + + my $perm = + $history[$x] =~ /^\* ACL $/ + ? $history[ ++$x ] . $history[ ++$x ] + : $history[$x]; + + $perm =~ s/\s?$CRLF$//o; + until ( $perm =~ /\Q$target\E"?$/ || !$perm ) { + $perm =~ s/\s([^\s]+)\s?$// or last; + my $p = $1; + $perm =~ s/\s([^\s]+)\s?$// or last; + my $u = $1; + $hash->{$u} = $p; + $self->_debug("Permissions: $u => $p"); + } + } + return $hash; +} + +sub listrights { + my ( $self, $target, $user ) = @_; + $target ||= $self->Folder; + $target = $self->Quote($target); + + $user ||= $self->User; + $user = ( $user eq "" ) ? qq("") : $self->Quote($user); + + $self->_imap_command(qq(LISTRIGHTS $target $user)) + or return undef; + + my $resp = first { /^\* LISTRIGHTS/ } $self->History; + my @rights = split /\s/, $resp; + my $rights = join '', @rights[ 4 .. $#rights ]; + $rights =~ s/"//g; + return wantarray ? split( //, $rights ) : $rights; +} + +sub select { + my ( $self, $target ) = @_; + defined $target or return undef; + + my $qqtarget = $self->Quote($target); + my $old = $self->Folder; + + $self->_imap_command("SELECT $qqtarget") + or return undef; + + $self->State(Selected); + $self->Folder($target); + return $old || $self; # ??$self?? +} + +sub message_string { + my ( $self, $msg ) = @_; + + return undef unless defined $self->imap4rev1; + my $peek = $self->Peek ? '.PEEK' : ''; + my $cmd = $self->imap4rev1 ? "BODY$peek\[]" : "RFC822$peek"; + + my $string; + $self->message_to_file( \$string, $msg ); + + unless ( $self->Ignoresizeerrors ) { # Check size with expected size + my $expected_size = $self->size($msg); + return undef unless defined $expected_size; + + # RFC822.SIZE may be wrong, see RFC2683 3.4.5 "RFC822.SIZE" + if ( length($string) != $expected_size ) { + $self->LastError( "message_string() " + . "expected $expected_size bytes but received " + . length($string) + . " you may need the IgnoreSizeErrors option" ); + return undef; + } + } + + return $string; +} + +sub bodypart_string { + my ( $self, $msg, $partno, $bytes, $offset ) = @_; + + unless ( $self->imap4rev1 ) { + $self->LastError( "Unable to get body part; server " + . $self->Server + . " does not support IMAP4REV1" ) + unless $self->LastError; + return undef; + } + + $offset ||= 0; + my $cmd = "BODY" + . ( $self->Peek ? '.PEEK' : '' ) + . "[$partno]" + . ( $bytes ? "<$offset.$bytes>" : '' ); + + $self->fetch( $msg, $cmd ) + or return undef; + + $self->_transaction_literals; +} + +# message_to_file( $self, $file, @msgs ) +sub message_to_file { + my ( $self, $file, @msgs ) = @_; + + # $file can be a name or a scalar reference (for in memory file) + # avoid IO::File bug handling scalar refs in perl <= 5.8.8? + # - buggy: $fh = IO::File->new( $file, 'r' ) + my $fh; + if ( ref $file and ref $file ne "SCALAR" ) { + $fh = $file; + } + else { + $$file = "" if ( ref $file eq "SCALAR" and !defined $$file ); + local ($!); + open( $fh, ">>", $file ); + unless ( defined($fh) ) { + $self->LastError("Unable to open file '$file': $!"); + return undef; + } + } + + binmode($fh); + + unless (@msgs) { + $self->LastError("message_to_file: NO messages specified!"); + return undef; + } + + my $peek = $self->Peek ? '.PEEK' : ''; + $peek = sprintf( $self->imap4rev1 ? "BODY%s\[]" : "RFC822%s", $peek ); + + my @args = ( join( ",", @msgs ), $peek ); + + return $self->_imap_uid_command( { outref => $fh }, "FETCH" => @args ) + ? $self + : undef; +} + +sub message_uid { + my ( $self, $msg ) = @_; + + my $ref = $self->fetch( $msg, "UID" ) or return undef; + foreach (@$ref) { + return $1 if m/\(UID\s+(\d+)\s*\)$CR?$/o; + } + return undef; +} + +# cleaned up and simplified but see TODO in code... +sub migrate { + my ( $self, $peer, $msgs, $folder ) = @_; + + unless ( $peer and $peer->IsConnected ) { + $self->LastError( ( $peer ? "Invalid" : "Unconnected" ) + . " target " + . ref($self) + . " object in migrate()" + . ( $peer ? ( ": " . $peer->LastError ) : "" ) ); + return undef; + } + + # sanity check to see if $self is same object as $peer + if ( $self eq $peer ) { + $self->LastError("dest must not be the same object as self"); + return undef; + } + + $folder = $self->Folder unless ( defined $folder ); + unless ($folder) { + $self->LastError("No folder selected on source mailbox."); + return undef; + } + + unless ( $peer->exists($folder) or $peer->create($folder) ) { + $self->LastError( "Create folder '$folder' on target host failed: " + . $peer->LastError ); + return undef; + } + + if ( !defined $msgs or uc($msgs) eq "ALL" ) { + $msgs = $self->search("ALL") or return undef; + } + + # message size and (internal) date + my @headers = qw(RFC822.SIZE INTERNALDATE FLAGS); + my $range = $self->Range($msgs); + + $self->_debug("Messages to migrate from '$folder': $range"); + + foreach my $mid ( $range->unfold ) { + + # fetch size internaldate and flags of original message + # - TODO: add flags here... + my $minfo = $self->fetch_hash( $mid, @headers ) + or return undef; + + my ( $size, $date ) = @{ $minfo->{$mid} }{@headers}; + return undef unless ( defined $size and defined $date ); + + $self->_debug("Copy message $mid (sz=$size,dt=$date) from '$folder'"); + + my @flags = grep !/\\Recent/i, $self->flags($mid); + my $flags = join ' ', $peer->supported_flags(@flags); + + # TODO: - use File::Temp tempfile if $msg > bufferSize? + # read message to $msg + my $msg; + $self->message_to_file( \$msg, $mid ) + or return undef; + + my $newid = $peer->append_file( $folder, \$msg, undef, $flags, $date ); + + unless ( defined $newid ) { + $self->LastError( + "Append to '$folder' on target failed: " . $peer->LastError ); + return undef; + } + + $self->_debug("Copied UID $mid in '$folder' to target UID $newid"); + } + + return $self; +} + +# Optimization of wait time between syswrite calls only runs if syscalls +# run too fast and fill the buffer causing "EAGAIN: Resource Temp. Unavail" +# errors. The premise is that $maxwrite will be approx. the same as the +# smallest buffer between the sending and receiving side. Waiting time +# between syscalls should ideally be exactly as long as it takes the +# receiving side to empty that buffer, minus a little bit to prevent it +# from emptying completely and wasting time in the select call. + +sub _optimal_sleep($$$) { + my ( $self, $maxwrite, $waittime, $last5writes ) = @_; + + push @$last5writes, $waittime; + shift @$last5writes if @$last5writes > 5; + + my $bufferavail = ( sum @$last5writes ) / @$last5writes; + + if ( $bufferavail < .4 * $maxwrite ) { + + # Buffer is staying pretty full; we should increase the wait + # period to reduce transmission overhead/number of packets sent + $waittime *= 1.3; + } + elsif ( $bufferavail > .9 * $maxwrite ) { + + # Buffer is nearly or totally empty; we're wasting time in select + # call that could be used to send data, so reduce the wait period + $waittime *= .5; + } + + CORE::select( undef, undef, undef, $waittime ); + $waittime; +} + +sub body_string { + my ( $self, $msg ) = @_; + my $ref = + $self->fetch( $msg, "BODY" . ( $self->Peek ? ".PEEK" : "" ) . "[TEXT]" ) + or return undef; + + my $string = join '', map { $_->[DATA] } + grep { $self->_is_literal($_) } @$ref; + + return $string + if $string; + + my $head; + while ( $head = shift @$ref ) { + $self->_debug("body_string: head = '$head'"); + + last + if $head =~ + /(?:.*FETCH .*\(.*BODY\[TEXT\])|(?:^\d+ BAD )|(?:^\d NO )/i; + } + + unless (@$ref) { + $self->LastError( + "Unable to parse server response from " . $self->LastIMAPCommand ); + return undef; + } + + my $popped; + $popped = pop @$ref + until ( $popped && $popped =~ /^\)$CRLF$/o ) + || !grep /^\)$CRLF$/o, @$ref; + + if ( $head =~ /BODY\[TEXT\]\s*$/i ) { # Next line is a literal + $string .= shift @$ref while @$ref; + $self->_debug("String is now $string") + if $self->Debug; + } + + $string; +} + +sub examine { + my ( $self, $target ) = @_; + defined $target or return undef; + + $self->_imap_command( 'EXAMINE ' . $self->Quote($target) ) + or return undef; + + my $old = $self->Folder; + $self->Folder($target); + $self->State(Selected); + $old || $self; +} + +sub idle { + my $self = shift; + my $good = '+'; + my $count = $self->Count + 1; + $self->_imap_command( "IDLE", $good ) ? $count : undef; +} + +sub idle_data { + my $self = shift; + my $timeout = scalar(@_) ? shift : 0; + my $socket = $self->Socket; + + # current index in Results array + my $trans_c1 = $self->_next_index; + + # look for all untagged responses + my ( $rc, $ret ); + + do { + $ret = + $self->_read_more( { error_on_timeout => 0 }, $socket, $timeout ); + + # set rc on first pass or on errors + $rc = $ret if ( !defined($rc) or $ret < 0 ); + + # not using /\S+/ because that can match 0 in "* 0 RECENT" + # leading the library to act as if things failed + if ( $ret > 0 ) { + $self->_get_response( '*', qr/(?!BAD|BYE|NO)(?:\d+\s+\w+|\S+)/ ) + or return undef; + $timeout = 0; # check for more data without blocking! + } + } while $ret > 0; + + # select returns -1 on errors + return undef if $rc < 0; + + my $trans_c2 = $self->_next_index; + + # if current index in Results array has changed return data + my @res; + if ( $trans_c1 < $trans_c2 ) { + @res = $self->Results; + @res = @res[ $trans_c1 .. ( $trans_c2 - 1 ) ]; + } + return wantarray ? @res : \@res; +} + +sub done { + my $self = shift; + my $count = shift || $self->Count; + $self->_imap_command( { addtag => 0, tag => $count }, "DONE" ) + or return undef; + return $self->Results; +} + +# tag_and_run( $self, $string, $good ) +sub tag_and_run { + my $self = shift; + $self->_imap_command(@_) or return undef; + return $self->Results; +} + +sub reconnect { + my $self = shift; + + if ( $self->IsAuthenticated ) { + $self->_debug("reconnect called but already authenticated"); + return 1; + } + + # safeguard from deep recursion via connect + if ( $self->{_doing_reconnect} ) { + $self->_debug("recursive call to reconnect, returning 0\n"); + $self->LastError("unexpected reconnect recursion") + unless $self->LastError; + return 0; + } + + my $einfo = $self->LastError || ""; + $self->_debug( "reconnecting to ", $self->Server, ", last error: $einfo" ); + $self->{_doing_reconnect} = 1; + + # reconnect and select appropriate folder + my $ret; + if ( $self->connect ) { + $ret = 1; + if ( defined $self->Folder ) { + $ret = defined( $self->select( $self->Folder ) ) ? 1 : undef; + } + } + + delete $self->{_doing_reconnect}; + return $ret ? 1 : $ret; +} + +# wrapper for _imap_command_do to enable retrying on lost connections +sub _imap_command { + my $self = shift; + + my $tries = 0; + my $retry = $self->Reconnectretry || 0; + my ( $rc, @err ); + + # LastError (if set) will be overwritten masking any earlier errors + while ( $tries++ <= $retry ) { + + # do command on the first try or if Connected (reconnect ongoing) + if ( $tries == 1 or $self->IsConnected ) { + $rc = $self->_imap_command_do(@_); + push( @err, $self->LastError ) if $self->LastError; + } + + if ( !defined($rc) and $retry and $self->IsUnconnected ) { + last + unless ( + $! == EPIPE + or $! == ECONNRESET + or $self->LastError =~ /(?:error\(.*?\)|timeout) waiting\b/ + or $self->LastError =~ /(?:socket closed|\* BYE)\b/ + + # BUG? reconnect if caller ignored/missed earlier errors? + # or $self->LastError =~ /NO not connected/ + ); + my $ret = $self->reconnect; + if ($ret) { + $self->_debug("reconnect success($ret) on try #$tries/$retry"); + } + elsif ( defined $ret and $ret == 0 ) { # escaping recursion + return undef; + } + else { + $self->_debug("reconnect failure on try #$tries/$retry"); + push( @err, $self->LastError ) if $self->LastError; + } + } + else { + last; + } + } + + unless ($rc) { + my ( %seen, @keep, @info ); + + foreach my $str (@err) { + my ( $sz, $len ) = ( 96, length($str) ); + $str =~ s/$CR?$LF$/\\n/omg; + if ( !$self->Debug and $len > $sz * 2 ) { + my $beg = substr( $str, 0, $sz ); + my $end = substr( $str, -$sz, $sz ); + $str = $beg . "..." . $end; + } + next if $seen{$str}++; + push( @keep, $str ); + } + foreach my $msg (@keep) { + push( @info, $msg . ( $seen{$msg} > 1 ? " ($seen{$msg}x)" : "" ) ); + } + $self->LastError( join( "; ", @info ) ); + } + + return $rc; +} + +# _imap_command_do runs a command, inserting a tag and CRLF as requested +# options: +# addcrlf => 0|1 - suppress adding CRLF to $string +# addtag => 0|1 - suppress adding $tag to $string +# tag => $tag - use this $tag instead of incrementing $self->Count +# outref => ... - see _get_response() +sub _imap_command_do { + my $self = shift; + my $opt = ref( $_[0] ) eq "HASH" ? shift : {}; + my $string = shift or return undef; + my $good = shift; + + my @gropt = ( $opt->{outref} ? { outref => $opt->{outref} } : () ); + + $opt->{addcrlf} = 1 unless exists $opt->{addcrlf}; + $opt->{addtag} = 1 unless exists $opt->{addtag}; + + # reset error in case the last error was non-fatal but never cleared + if ( $self->LastError ) { + + #DEBUG $self->_debug( "Reset LastError: " . $self->LastError ); + $self->LastError(undef); + } + + my $clear = $self->Clear; + $self->Clear($clear) + if $self->Count >= $clear && $clear > 0; + + my $count = $self->Count( $self->Count + 1 ); + my $tag = $opt->{tag} || $count; + $string = "$tag $string" if $opt->{addtag}; + + # for APPEND (append_string) only log first line of command + my $logstr = ( $string =~ /^($tag\s+APPEND\s+.*?)$CR?$LF/ ) ? $1 : $string; + + # BUG? use $self->_next_index($tag) ? or 0 ??? + # $self->_record($tag, [$self->_next_index($tag), "INPUT", $logstr] ); + $self->_record( $count, [ 0, "INPUT", $logstr ] ); + + # $suppress (adding CRLF) set to 0 if $opt->{addcrlf} is TRUE + unless ( $self->_send_line( $string, $opt->{addcrlf} ? 0 : 1 ) ) { + $self->LastError( "Error sending '$logstr': " . $self->LastError ); + return undef; + } + + # look for " (OK|BAD|NO|$good)" (or "+..." if $good is '+') + my $code = $self->_get_response( @gropt, $tag, $good ) or return undef; + + if ( $code eq 'OK' ) { + return $self; + } + elsif ( $good and $code eq $good ) { + return $self; + } + else { + return undef; + } +} + +sub _response_code_sub { + my ( $self, $tag, $good ) = @_; + + # tag/good can be a ref (compiled regex) otherwise quote it + my $qtag = ref($tag) ? $tag : defined($tag) ? quotemeta($tag) : undef; + my $qgood = ref($good) ? $good : defined($good) ? quotemeta($good) : undef; + + # using closure, a variable alias, and sub returns on first match + # - $_[0] is $o->[DATA] + # - returns list ( $code, $byemsg ) + my $getcodesub = sub { + if ( defined $qgood ) { + if ( $good eq '+' and $_[0] =~ /^$qgood/ ) { + return ($good); + } + if ( defined $qtag and $_[0] =~ /^$qtag\s+($qgood)/i ) { + return ( ref($qgood) ? $1 : uc($1) ); + } + } + if ( defined $qtag ) { + if ( $tag eq '+' and $_[0] =~ /^$qtag/ ) { + return ($tag); + } + if ( $_[0] =~ /^$qtag\s+(OK|BAD|NO)\b/i ) { + my $code = uc($1); + $self->LastError( $_[0] ) unless ( $code eq 'OK' ); + return ($code); + } + } + if ( $_[0] =~ /^\*\s+(BYE)\b/i ) { + return ( uc($1), $_[0] ); # ( 'BYE', $byemsg ) + } + return (undef); + }; + + return $getcodesub; +} + +# _get_response get IMAP response optionally send data somewhere +# options: +# outref => GLOB|CODE - reference to send output to (see _read_line) +sub _get_response { + my $self = shift; + my $opt = ref( $_[0] ) eq "HASH" ? shift : {}; + my $tag = shift; + my $good = shift; + + my $outref = $opt->{outref}; + my @readopt = defined($outref) ? ($outref) : (); + my $getcode = $self->_response_code_sub( $tag, $good ); + + my ( $count, $out, $code, $byemsg ) = ( $self->Count, [], undef, undef ); + until ( defined $code ) { + my $output = $self->_read_line(@readopt) or return undef; + $out = $output; # keep last response just in case + + # not using last on first match? paranoia or right thing? + # only uc() when match is not on case where $tag|$good is a ref() + foreach my $o (@$output) { + $self->_record( $count, $o ); + $self->_is_output($o) or next; + my ( $tcode, $tbyemsg ) = $getcode->( $o->[DATA] ); + $code = $tcode if ( defined $tcode ); + $byemsg = $tbyemsg if ( defined $tbyemsg ); + } + } + + if ( defined $code ) { + $code =~ s/$CR?$LF?$//o; + $code = uc($code) unless ( $good and $code eq $good ); + + # RFC 3501 7.1.5: $code on successful LOGOUT is OK not BYE + # sometimes we may fail to wait long enough to read a tagged + # OK so don't be strict about setting an error on LOGOUT! + if ( $code eq 'BYE' ) { + $self->State(Unconnected); + if ($byemsg) { + $self->LastError($byemsg) + unless ( $good and $code eq $good ); + } + } + } + elsif ( !$self->LastError ) { + my $info = "unexpected response: " . join( " ", @$out ); + $self->LastError($info); + } + + return $code; +} + +sub _imap_uid_command { + my $self = shift; + my @opt = ref( $_[0] ) eq "HASH" ? (shift) : (); + my $cmd = shift; + + my $args = @_ ? join( " ", '', @_ ) : ''; + my $uid = $self->Uid ? 'UID ' : ''; + $self->_imap_command( @opt, "$uid$cmd$args" ); +} + +sub run { + my $self = shift; + my $string = shift or return undef; + + my $tag = $string =~ /^(\S+) / ? $1 : undef; + unless ($tag) { + $self->LastError("No tag found in string passed to run(): $string"); + return undef; + } + + $self->_imap_command( { addtag => 0, addcrlf => 0, tag => $tag }, $string ) + or return undef; + + $self->{History}{$tag} = $self->{History}{ $self->Count } + unless $tag eq $self->Count; + + return $self->Results; +} + +# _record saves the conversation into the History structure: +sub _record { + my ( $self, $count, $array ) = @_; + if ( $array->[DATA] =~ /^\d+ LOGIN/i && !$self->Showcredentials ) { + $array->[DATA] =~ s/LOGIN.*/LOGIN XXXXXXXX XXXXXXXX/i; + } + + push @{ $self->{History}{$count} }, $array; +} + +# _send_line handles literal data and supports the Prewritemethod +sub _send_line { + my ( $self, $string, $suppress ) = @_; + + $string =~ s/$CR?$LF?$/$CRLF/o + unless $suppress; + + # handle case where string contains a literal + if ( $string =~ s/^([^$LF\{]*\{\d+\}$CRLF)(?=.)//o ) { + my $first = $1; + $self->_debug("Sending literal: $first\tthen: $string"); + $self->_send_line($first) or return undef; + + # look for "+..." + my $code = $self->_get_response('+') or return undef; + return undef unless $code eq '+'; + } + + # non-literal part continues... + unless ( $self->IsConnected ) { + $self->LastError("NO not connected"); + return undef; + } + + if ( my $prew = $self->Prewritemethod ) { + $string = $prew->( $self, $string ); + } + + $self->_debug("Sending: $string"); + $self->_send_bytes( \$string ); +} + +sub _send_bytes($) { + my ( $self, $byteref ) = @_; + my ( $total, $temperrs, $maxwrite ) = ( 0, 0, 0 ); + my $waittime = .02; + my @previous_writes; + + my $maxagain = $self->Maxtemperrors; + undef $maxagain if $maxagain and lc($maxagain) eq 'unlimited'; + + local $SIG{PIPE} = 'IGNORE'; # handle SIGPIPE as normal error + + my $socket = $self->Socket; + while ( $total < length $$byteref ) { + my $written = + syswrite( $socket, $$byteref, length($$byteref) - $total, $total ); + + if ( defined $written ) { + $temperrs = 0; + $total += $written; + next; + } + + if ( $! == EAGAIN ) { + if ( defined $maxagain && $temperrs++ > $maxagain ) { + $self->LastError("Persistent error '$!'"); + return undef; + } + + $waittime = + $self->_optimal_sleep( $maxwrite, $waittime, \@previous_writes ); + next; + } + + # Unconnected might be apropos for more than just these? + my $emsg = $! ? "$!" : "no error caught"; + $self->State(Unconnected) + if ( $! == EPIPE or $! == ECONNRESET or $! == EBADF ); + $self->LastError("Write failed '$emsg'"); + + return undef; # no luck + } + + $self->_debug("Sent $total bytes"); + return $total; +} + +# _read_line: read one line from the socket +# +# $output = $self->_read_line($literal_callback) +# literal_callback is optional, but if supplied it must be either +# be a filehandle, coderef, or undef. +# +# Returns a reference to an array of arrays, i.e.: +# $output = [ +# [ $index, 'OUTPUT|LITERAL', $output_line ], +# [ $index, 'OUTPUT|LITERAL', $output_line ], +# ... +# \]; + +# BUG?: make memory more efficient +sub _read_line { + my ( $self, $literal_callback ) = @_; + + my $socket = $self->Socket; + unless ( $self->IsConnected && $socket ) { + $self->LastError("NO not connected"); + return undef; + } + + my $iBuffer = ""; + my $oBuffer = []; + my $index = $self->_next_index; + my $timeout = $self->Timeout; + my $readlen = $self->Buffer || 4096; + my $transno = $self->Transaction; + + my $literal_cbtype = ""; + if ($literal_callback) { + if ( UNIVERSAL::isa( $literal_callback, "GLOB" ) ) { + $literal_cbtype = "GLOB"; + } + elsif ( UNIVERSAL::isa( $literal_callback, "CODE" ) ) { + $literal_cbtype = "CODE"; + } + else { + $self->LastError( "'$literal_callback' is an " + . "invalid callback; must be a filehandle or CODE" ); + return undef; + } + } + + my $temperrs = 0; + my $maxagain = $self->Maxtemperrors; + undef $maxagain if $maxagain and lc($maxagain) eq 'unlimited'; + + until ( + @$oBuffer # there's stuff in output buffer: + && $oBuffer->[-1][TYPE] eq 'OUTPUT' # that thing is an output line: + && $oBuffer->[-1][DATA] =~ + /$CR?$LF$/o # the last thing there has cr-lf: + && !length $iBuffer # and the input buffer has been MT'ed: + ) + { + + if ($timeout) { + my $rc = $self->_read_more( $socket, $timeout ); + return undef unless ( $rc > 0 ); + } + + my $emsg; + my $ret = + $self->_sysread( $socket, \$iBuffer, $readlen, length $iBuffer ); + + if ($timeout) { + if ( defined $ret ) { + $temperrs = 0; + } + else { + $emsg = "error while reading data from server: $!"; + if ( $! == ECONNRESET ) { + $self->State(Unconnected); + } + elsif ( $! == EAGAIN ) { + if ( defined $maxagain && $temperrs++ >= $maxagain ) { + $emsg .= " ($temperrs)"; + } + else { + next; # try again + } + } + } + } + + if ( defined $ret && $ret == 0 ) { # Caught EOF... + $emsg = "socket closed while reading data from server"; + $self->State(Unconnected); + } + + # save errors and return + if ($emsg) { + $self->LastError($emsg); + $self->_record( + $transno, + [ + $self->_next_index($transno), "ERROR", "$transno * NO $emsg" + ] + ); + return undef; + } + + while ( $iBuffer =~ s/^(.*?$CR?$LF)//o ) # consume line + { + my $current_line = $1; + if ( $current_line !~ s/\{(\d+)\}$CR?$LF$//o ) { + push @$oBuffer, [ $index++, 'OUTPUT', $current_line ]; + next; + } + + push @$oBuffer, [ $index++, 'OUTPUT', $current_line ]; + + ## handle LITERAL + # BLAH BLAH {nnn}$CRLF + # [nnn bytes of literally transmitted stuff] + # [part of line that follows literal data]$CRLF + + my $expected_size = $1; + + $self->_debug( "LITERAL: received literal in line " + . "$current_line of length $expected_size; attempting to " + . "retrieve from the " + . length($iBuffer) + . " bytes in: $iBuffer" ); + + my $litstring; + if ( length $iBuffer >= $expected_size ) { + + # already received all data + $litstring = substr $iBuffer, 0, $expected_size, ''; + } + else { # literal data still to arrive + $litstring = $iBuffer; + $iBuffer = ''; + + my $litreadb = length($litstring); + my $temperrs = 0; + my $maxagain = $self->Maxtemperrors; + undef $maxagain if $maxagain and lc($maxagain) eq 'unlimited'; + + while ( $expected_size > $litreadb ) { + if ($timeout) { + my $rc = $self->_read_more( $socket, $timeout ); + return undef unless ( $rc > 0 ); + } + else { # 25 ms before retry + CORE::select( undef, undef, undef, 0.025 ); + } + + # $litstring is emptied when $literal_cbtype is GLOB + my $ret = + $self->_sysread( $socket, \$litstring, + $expected_size - $litreadb, + length($litstring) ); + + if ($timeout) { + if ( defined $ret ) { + $temperrs = 0; + } + else { + $emsg = "error while reading data from server: $!"; + if ( $! == ECONNRESET ) { + $self->State(Unconnected); + } + elsif ( $! == EAGAIN ) { + if ( defined $maxagain + && $temperrs++ >= $maxagain ) + { + $emsg .= " ($temperrs)"; + } + else { + undef $emsg; + next; # try again + } + } + } + } + + # EOF: note IO::Socket::SSL does not support eof() + if ( defined $ret and $ret == 0 ) { + $emsg = "socket closed while reading data from server"; + $self->State(Unconnected); + } + elsif ( defined $ret and $ret > 0 ) { + $litreadb += $ret; + + # conserve memory when using literal_callback GLOB + if ( $literal_cbtype eq "GLOB" ) { + print $literal_callback $litstring; + $litstring = "" unless ($emsg); + } + } + + $self->_debug( "Received ret=" + . ( defined($ret) ? $ret : "" ) + . " $litreadb of $expected_size" ); + + # save errors and return + if ($emsg) { + $self->LastError($emsg); + $self->_record( + $transno, + [ + $self->_next_index($transno), "ERROR", + "$transno * NO $emsg" + ] + ); + $litstring = "" unless defined $litstring; + $self->_debug( "ERROR while processing LITERAL, " + . " buffer=\n" + . $litstring + . "\n" ); + return undef; + } + } + } + + if ( defined $litstring ) { + if ( $literal_cbtype eq "GLOB" ) { + print $literal_callback $litstring; + } + elsif ( $literal_cbtype eq "CODE" ) { + $literal_callback->($litstring); + } + } + + push @$oBuffer, [ $index++, 'LITERAL', $litstring ] + if ( $literal_cbtype ne "GLOB" ); + } + } + + $self->_debug( "Read: " . join "", map { "\t" . $_->[DATA] } @$oBuffer ) + if ( $self->Debug ); + + @$oBuffer ? $oBuffer : undef; +} + +sub _sysread { + my ( $self, $fh, $buf, $len, $off ) = @_; + my $rm = $self->Readmethod; + $rm ? $rm->(@_) : sysread( $fh, $$buf, $len, $off ); +} + +sub _read_more { + my $self = shift; + my $rm = $self->Readmoremethod; + $rm ? $rm->( $self, @_ ) : $self->__read_more(@_); +} + +sub __read_more { + my $self = shift; + my $opt = ref( $_[0] ) eq "HASH" ? shift : {}; + my ( $socket, $timeout ) = @_; + + # IO::Socket::SSL buffers some data internally, so there might be some + # data available from the previous sysread of which the file-handle + # (used by select()) doesn't know of. + return 1 if $socket->isa("IO::Socket::SSL") && $socket->pending; + + my $rvec = ''; + vec( $rvec, fileno($socket), 1 ) = 1; + + my $rc = CORE::select( $rvec, undef, $rvec, $timeout ); + + # fast track success + return $rc if $rc > 0; + + # by default set an error on timeout + my $err_on_timeout = + exists $opt->{error_on_timeout} ? $opt->{error_on_timeout} : 1; + + # $rc is 0 then we timed out + return $rc if !$rc and !$err_on_timeout; + + # set the appropriate error and return + my $transno = $self->Transaction; + my $msg = + ( $rc ? "error($rc)" : "timeout" ) + . " waiting ${timeout}s for data from server" + . ( $! ? ": $!" : "" ); + $self->LastError($msg); + $self->_record( $transno, + [ $self->_next_index($transno), "ERROR", "$transno * NO $msg" ] ); + $self->_disconnect; # BUG: can not handle timeouts gracefully + return $rc; +} + +sub _trans_index() { + sort { $a <=> $b } keys %{ $_[0]->{History} }; +} + +# all default to last transaction +sub _transaction(;$) { + @{ $_[0]->{History}{ $_[1] || $_[0]->Transaction } || [] }; +} + +sub _trans_data(;$) { + map { $_->[DATA] } $_[0]->_transaction( $_[1] ); +} + +sub _escaped_trans_data(;$) { + my ( $self, $trans ) = @_; + my @a; + my $prevwasliteral = 0; + foreach my $line ( $self->_transaction($trans) ) { + next unless defined $line; + + my $data = $line->[DATA]; + + # literal is appended to previous data + if ( $self->_is_literal($line) ) { + $data = $self->Escape($data); + $a[-1] .= qq("$data"); + $prevwasliteral = 1; + } + else { + if ($prevwasliteral) { + $a[-1] .= $data; + } + else { + push( @a, $data ); + } + $prevwasliteral = 0; + } + } + + return wantarray ? @a : \@a; +} + +sub Report { + my $self = shift; + map { $self->_trans_data($_) } $self->_trans_index; +} + +sub LastIMAPCommand(;$) { + my ( $self, $trans ) = @_; + my $msg = ( $self->_transaction($trans) )[0]; + $msg ? $msg->[DATA] : undef; +} + +sub History(;$) { + my ( $self, $trans ) = @_; + my ( $cmd, @a ) = $self->_trans_data($trans); + return wantarray ? @a : \@a; +} + +sub Results(;$) { + my ( $self, $trans ) = @_; + my @a = $self->_trans_data($trans); + return wantarray ? @a : \@a; +} + +sub _transaction_literals() { + my $self = shift; + join '', map { $_->[DATA] } + grep { $self->_is_literal($_) } $self->_transaction; +} + +sub Escaped_history { + my ( $self, $trans ) = @_; + my ( $cmd, @a ) = $self->_escaped_trans_data($trans); + return wantarray ? @a : \@a; +} + +sub Escaped_results { + my ( $self, $trans ) = @_; + my @a = $self->_escaped_trans_data($trans); + return wantarray ? @a : \@a; +} + +sub Escape { + my $data = $_[1]; + $data =~ s/([\\\"])/\\$1/og; + return $data; +} + +sub Unescape { + my $data = $_[1]; + $data =~ s/\\([\\\"])/$1/og; + return $data; +} + +sub logout { + my $self = shift; + my $rc = $self->_imap_command( "LOGOUT", "BYE" ); + $self->_disconnect; + return $rc; +} + +sub _disconnect { + my $self = shift; + + delete $self->{CAPABILITY}; + delete $self->{_IMAP4REV1}; + $self->State(Unconnected); + if ( my $sock = delete $self->{Socket} ) { + local ($@); + eval { $sock->close }; + } + return $self; +} + +# LIST/XLIST/LSUB Response +# Contents: name attributes, hierarchy delimiter, name +# Example: * LIST (\Noselect) "/" ~/Mail/foo +# NOTE: liberal matching as folder name data may be Escape()d +sub _list_or_lsub_response_parse { + my ( $self, $resp ) = @_; + + return undef unless defined $resp; + my %info; + + $resp =~ s/\015?\012$//; + if ( + $resp =~ / ^\* \s+ (?:LIST|XLIST|LSUB) \s+ # * LIST|XLIST|LSUB + \( ([^\)]*) \) \s+ # (attrs) + (?: \" ([^"]*) \" | NIL ) \s # "delimiter" or NIL + (?:\s*\" (.*) \" | (.*) ) # "name" or name + /ix + ) + { + @info{qw(attrs delim name)} = + ( [ split( / /, $1 ) ], $2, defined($3) ? $self->Unescape($3) : $4 ); + } + return wantarray ? %info : \%info; +} + +sub exists { + my ( $self, $folder ) = @_; + $self->status($folder) ? $self : undef; +} + +# Updated to handle embedded literal strings +sub get_bodystructure { + my ( $self, $msg ) = @_; + + my $class = $self->_load_module("BodyStructure") or return undef; + + my $out = $self->fetch( $msg, "BODYSTRUCTURE" ) or return undef; + + my $bs = ""; + my $output = first { /BODYSTRUCTURE\s+\(/i } @$out; + + unless ( $output =~ /$CRLF$/o ) { + $output = ''; + $self->_debug("get_bodystructure: reassembling original response"); + my $started = 0; + foreach my $o ( $self->_transaction ) { + next unless $self->_is_output_or_literal($o); + $started++ if $o->[DATA] =~ /BODYSTRUCTURE \(/i; + $started or next; + + if ( length($output) && $self->_is_literal($o) ) { + my $data = $o->[DATA]; + $data =~ s/"/\\"/g; + $data =~ s/\(/\\\(/g; + $data =~ s/\)/\\\)/g; + $output .= qq("$data"); + } + else { + $output .= $o->[DATA]; + } + } + $self->_debug("get_bodystructure: reassembled output=$output"); + } + + { + local ($@); + $bs = eval { $class->new($output) }; + } + + $self->_debug( + "get_bodystructure: msg $msg returns: " . ( $bs || "UNDEF" ) ); + $bs; +} + +# Updated to handle embedded literal strings +sub get_envelope { + my ( $self, $msg ) = @_; + + # Envelope class is defined within BodyStructure + my $class = $self->_load_module("BodyStructure") or return undef; + $class .= "::Envelope"; + + my $out = $self->fetch( $msg, 'ENVELOPE' ) or return undef; + + my $bs = ""; + my $output = first { /ENVELOPE \(/i } @$out; + + unless ( $output =~ /$CRLF$/o ) { + $output = ''; + $self->_debug("get_envelope: reassembling original response"); + my $started = 0; + foreach my $o ( $self->_transaction ) { + next unless $self->_is_output_or_literal($o); + $started++ if $o->[DATA] =~ /ENVELOPE \(/i; + $started or next; + + if ( length($output) && $self->_is_literal($o) ) { + my $data = $o->[DATA]; + $data =~ s/"/\\"/g; + $data =~ s/\(/\\\(/g; + $data =~ s/\)/\\\)/g; + $output .= qq("$data"); + } + else { + $output .= $o->[DATA]; + } + } + $self->_debug("get_envelope: reassembled output=$output"); + } + + { + local ($@); + $bs = eval { $class->new($output) }; + } + + $self->_debug( "get_envelope: msg $msg returns: " . ( $bs || "UNDEF" ) ); + $bs; +} + +# fetch( [{option},] [$seq_set|ALL], @msg_data_items ) +# options: +# escaped => 0|1 # return Results or Escaped_results +sub fetch { + my $self = shift; + my $opt = ref( $_[0] ) eq "HASH" ? shift : {}; + my $what = shift || "ALL"; + + my $take = $what; + if ( $what eq 'ALL' ) { + my $msgs = $self->messages or return undef; + $take = $self->Range($msgs); + } + elsif ( ref $what || $what =~ /^[,:\d]+\w*$/ ) { + $take = $self->Range($what); + } + + my ( @data, $cmd ); + my ( $seq_set, @fetch_att ) = $self->_split_sequence( $take, "FETCH", @_ ); + + for ( my $x = 0 ; $x <= $#$seq_set ; $x++ ) { + my $seq = $seq_set->[$x]; + $self->_imap_uid_command( FETCH => $seq, @fetch_att, @_ ) + or return undef; + my $res = $opt->{escaped} ? $self->Escaped_results : $self->Results; + + # only keep last command and last response (* OK ...) + $cmd = shift(@$res); + pop(@$res) if ( $x != $#{$seq_set} ); + push( @data, @$res ); + } + + if ( $cmd and !wantarray ) { + $cmd =~ s/^(\d+\s+.*?FETCH\s+)\S+(\s*)/$1$take$2/; + unshift( @data, $cmd ); + } + + #wantarray ? $self->History : $self->Results; + return wantarray ? @data : \@data; +} + +# Some servers have a maximum command length. If Maxcommandlength is +# set, split a sequence to fit within the length restriction. +sub _split_sequence { + my ( $self, $take, @args ) = @_; + + # split take => sequence-set and (optional) fetch-att + my ( $seq, @att ) = split( / /, $take, 2 ); + + # use the entire sequence unless Maxcommandlength is set + my @seqs; + my $maxl = $self->Maxcommandlength; + if ($maxl) { + + # estimate command length, the sum of the lengths of: + # tag, command, fetch-att + $CRLF + push @args, $self->Transaction, $self->Uid ? "UID" : (), "\015\012"; + + # do not split on anything smaller than 64 chars + my $clen = length join( " ", @att, @args ); + my $diff = $maxl - $clen; + my $most = $diff > 64 ? $diff : 64; + + @seqs = ( $seq =~ m/(.{1,$most})(?:,|$)/g ) if defined $seq; + $self->_debug( "split_sequence: length($maxl-$clen) parts: ", + $#seqs + 1 ) + if ( $#seqs != 0 ); + } + else { + push( @seqs, $seq ) if defined $seq; + } + return \@seqs, @att; +} + +# fetch_hash( [$seq_set|ALL], @msg_data_items, [\%msg_by_ids] ) +# - TODO: make more efficient use of memory on large fetch results +sub fetch_hash { + my $self = shift; + my $uids = ref $_[-1] ? pop @_ : {}; + my @words = @_; + + # take an optional leading list of messages argument or default to + # ALL let fetch turn that list of messages into a msgref as needed + # fetch has similar logic for dealing with message list + my $msgs = 'ALL'; + if ( $words[0] ) { + if ( ref $words[0] ) { + $msgs = shift @words; + } + elsif ( $#words > 0 ) { + if ( $words[0] eq 'ALL' ) { + $msgs = shift @words; + } + elsif ( $words[0] =~ s/^([,:\d]+)\s*// ) { + $msgs = $1; + shift @words if $words[0] eq ""; + } + } + } + + # message list (if any) is now removed from @words + my $what = join( " ", @words ); + + # RFC 3501: + # fetch = "FETCH" SP sequence-set SP ("ALL" / "FULL" / "FAST" / + # fetch-att / "(" fetch-att *(SP fetch-att) ")") + my %macro = ( + "ALL" => [qw(FLAGS INTERNALDATE RFC822.SIZE ENVELOPE)], + "FULL" => [qw(FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODY)], + "FAST" => [qw(FLAGS INTERNALDATE RFC822.SIZE)], + ); + + if ( $macro{$what} ) { + @words = @{ $macro{$what} }; + } + else { + $what = "($what)"; + my @twords; + foreach my $word (@words) { + $word = uc($word); + + # server response to BODY[]<10.20> is a field named BODY[]<10> + if ( $word =~ /^BODY/ ) { + $word =~ s/<(\d+)\.\d+>$/<$1>/; + + # server response to BODY.PEEK[] is a field named BODY[] + # BUG? allow for BODY.PEEK in response (historical behavior) + if ( $word =~ /^BODY\.PEEK/ ) { + push( @twords, $word ); + $word =~ s/^BODY\.PEEK/BODY/; + } + } + unshift( @twords, $word ); + } + @words = @twords; + } + + my %words = map { $_ => 1 } @words; + + my $output = $self->fetch( $msgs, $what ) + or return undef; + + while ( my $l = shift @$output ) { + next if $l !~ m/^\*\s(\d+)\sFETCH\s\(/g; + my ( $mid, $entry ) = ( $1, {} ); + my ( $key, $value ); + ATTR: + while ( $l and $l !~ m/\G\s*\)\s*$/gc ) { + if ( $l =~ m/\G\s*([^\s\[]+(?:\[[^\]]*\])?(?:<[^>]*>)?)\s*/gc ) { + $key = uc($1); + } + elsif ( !defined $key ) { + + # some kind of malformed response + $self->LastError("Invalid item name in FETCH response: $l"); + return undef; + } + if ( $l =~ m/\G\s*$/gc ) { + $value = shift @$output; + $entry->{$key} = $value; + $l = shift @$output; + next ATTR; + } + elsif ( $l =~ m/\G(?:"(.*?)(?:(?{$key} = $value; + next ATTR; + } + elsif ( $l =~ m/\G\(/gc ) { + my $depth = 1; + $value = ""; + while ( $l =~ m/\G(\(|\)|[^()]+)/gc ) { + my $stuff = $1; + if ( $stuff eq "(" ) { + $depth++; + $value .= "("; + } + elsif ( $stuff eq ")" ) { + $depth--; + if ( $depth == 0 ) { + $entry->{$key} = $value; + next ATTR; + } + $value .= ")"; + } + else { + $value .= $stuff; + } + + # consume literal data if any + if ( $l =~ m/\G\s*$/gc and scalar(@$output) ) { + my $elit = $self->Escape( shift @$output ); + $l = shift @$output; + $value .= ( length($value) ? " " : "" ) . qq{"$elit"}; + } + } + $l =~ m/\G\s*/gc; + } + else { + $self->LastError("Invalid item value in FETCH response: $l"); + return undef; + } + } + + if ( $self->Uid ) { + $uids->{ $entry->{UID} } = $entry; + } + else { + $uids->{$mid} = $entry; + } + + # remove things not asked for (i.e. UID/$mid) + for my $word ( keys %$entry ) { + next if ( exists $words{$word} ); + delete $entry->{$word}; + } + } + + return wantarray ? %$uids : $uids; +} + +sub store { + my ( $self, @a ) = @_; + $self->_imap_uid_command( STORE => @a ) + or return undef; + return wantarray ? $self->History : $self->Results; +} + +sub _imap_folder_command($$@) { + my ( $self, $command ) = ( shift, shift ); + my $folder = $self->Quote(shift); + + $self->_imap_command( join ' ', $command, $folder, @_ ) + or return undef; + + return wantarray ? $self->History : $self->Results; +} + +sub subscribe($) { shift->_imap_folder_command( SUBSCRIBE => @_ ) } +sub unsubscribe($) { shift->_imap_folder_command( UNSUBSCRIBE => @_ ) } +sub create($) { shift->_imap_folder_command( CREATE => @_ ) } + +sub delete($) { + my $self = shift; + $self->_imap_folder_command( DELETE => @_ ) or return undef; + $self->Folder(undef); + return wantarray ? $self->History : $self->Results; +} + +# rfc2086 +sub myrights($) { $_[0]->_imap_folder_command( MYRIGHTS => $_[1] ) } + +sub close { + my $self = shift; + $self->_imap_command('CLOSE') + or return undef; + return wantarray ? $self->History : $self->Results; +} + +sub expunge { + my ( $self, $folder ) = @_; + + return undef unless ( defined $folder or defined $self->Folder ); + + my $old = defined $self->Folder ? $self->Folder : ''; + + if ( !defined($folder) || $folder eq $old ) { + $self->_imap_command('EXPUNGE') + or return undef; + } + else { + $self->select($folder) or return undef; + my $succ = $self->_imap_command('EXPUNGE'); + + # if $old eq '' IMAP4 select should close $folder without EXPUNGE + return undef unless ( $self->select($old) and $succ ); + } + + return wantarray ? $self->History : $self->Results; +} + +sub uidexpunge { + my ( $self, $msgspec ) = ( shift, shift ); + + return undef unless $self->has_capability("UIDPLUS"); + + my $msg = + UNIVERSAL::isa( $msgspec, 'Mail::IMAPClient::MessageSet' ) + ? $msgspec + : $self->Range($msgspec); + + $msg->cat(@_) if @_; + + if ( $self->Uid ) { + $self->_imap_command("UID EXPUNGE $msg") + or return undef; + } + else { + $self->LastError("Uid must be enabled for uidexpunge"); + return undef; + } + + return wantarray ? $self->History : $self->Results; +} + +sub rename { + my ( $self, $from, $to ) = @_; + + $from = ( $from eq "" ) ? qq("") : $self->Quote($from); + $to = ( $to eq "" ) ? qq("") : $self->Quote($to); + + $self->_imap_command(qq(RENAME $from $to)) ? $self : undef; +} + +sub status { + my ( $self, $folder ) = ( shift, shift ); + defined $folder or return undef; + + my $which = @_ ? join( " ", @_ ) : 'MESSAGES'; + + my $box = $self->Quote($folder); + $self->_imap_command("STATUS $box ($which)") + or return undef; + + return wantarray ? $self->History : $self->Results; +} + +sub flags { + my ( $self, $msgspec ) = ( shift, shift ); + my $msg = + UNIVERSAL::isa( $msgspec, 'Mail::IMAPClient::MessageSet' ) + ? $msgspec + : $self->Range($msgspec); + + $msg->cat(@_) if @_; + + # Send command + my $ref = $self->fetch( $msg, "FLAGS" ) or return undef; + + my $u_f = $self->Uid; + my $flagset = {}; + + # Parse results, setting entry in result hash for each line + foreach my $line (@$ref) { + $self->_debug("flags: line = '$line'"); + if ( + $line =~ /\* \s+ (\d+) \s+ FETCH \s+ # * nnn FETCH + \( + (?:\s* UID \s+ (\d+) \s* )? # optional: UID nnn + FLAGS \s* \( (.*?) \) \s* # FLAGS (\Flag1 \Flag2) + (?:\s* UID \s+ (\d+) \s* )? # optional: UID nnn + \) + /x + ) + { + my $mailid = $u_f ? ( $2 || $4 ) : $1; + $flagset->{$mailid} = [ split " ", $3 ]; + } + } + + # Or did he want a hash from msgid to flag array? + return $flagset + if ref $msgspec; + + # or did the guy want just one response? Return it if so + my $flagsref = $flagset->{$msgspec}; + return wantarray ? @$flagsref : $flagsref; +} + +# reduce a list, stripping undeclared flags. Flags with or without +# leading backslash. +sub supported_flags(@) { + my $self = shift; + my $sup = $self->Supportedflags + or return @_; + + return map { $sup->($_) } @_ + if ref $sup eq 'CODE'; + + grep { $sup->{ /^\\(\S+)/ ? lc $1 : () } } @_; +} + +sub parse_headers { + my ( $self, $msgspec, @fields ) = @_; + my $fields = join ' ', @fields; + my $msg = ref $msgspec eq 'ARRAY' ? $self->Range($msgspec) : $msgspec; + my $peek = !defined $self->Peek || $self->Peek ? '.PEEK' : ''; + + my $string = "$msg BODY$peek" + . ( $fields eq 'ALL' ? '[HEADER]' : "[HEADER.FIELDS ($fields)]" ); + + my $raw = $self->fetch($string) or return undef; + my $cmd = shift @$raw; + + my %headers; # message ids to headers + my $h; # fields for current msgid + my $field; # previous field name, for unfolding + my %fieldmap = map { ( lc($_) => $_ ) } @fields; + my $msgid; + + # BUG: parsing this way is prone to be buggy but works most of the time + # some example responses: + # * OK Message 1 no longer exists + # * 1 FETCH (UID 26535 BODY[HEADER] "") + # * 5 FETCH (UID 30699 BODY[HEADER] {1711} + # header: value... + foreach my $header ( map { split /$CR?$LF/o } @$raw ) { + + # Windows2003/Maillennium/others? have UID after headers + if ( + $header =~ s/^\* \s+ (\d+) \s+ FETCH \s+ + \( (.*?) BODY\[HEADER (?:\.FIELDS)? .*? \]\s*//ix + ) + { # start new message header + ( $msgid, my $msgattrs ) = ( $1, $2 ); + $h = {}; + if ( $self->Uid ) # undef when win2003 + { + $msgid = $msgattrs =~ m/\b UID \s+ (\d+)/x ? $1 : undef; + } + $headers{$msgid} = $h if $msgid; + } + $header =~ /\S/ or next; # skip empty lines. + + # ( for vi + if ( $header =~ /^\)/ ) { # end of this message + undef $h; # inbetween headers + next; + } + elsif ( !$msgid && $header =~ /^\s*UID\s+(\d+).*\)$/ ) { + $headers{$1} = $h; # found UID win2003/Maillennium + + undef $h; + next; + } + + unless ( defined $h ) { + $self->_debug("found data between fetch headers: $header"); + next; + } + + if ( $header and $header =~ s/^(\S+)\:\s*// ) { + $field = $fieldmap{ lc $1 } || $1; + push @{ $h->{$field} }, $header; + } + elsif ( $field and ref $h->{$field} eq 'ARRAY' ) { # folded header + $h->{$field}[-1] .= $header; + } + else { + + # show data if it is not like '"")' or '{123}' + $self->_debug("non-header data between fetch headers: $header") + if ( $header !~ /^(?:\s*\"\"\)|\{\d+\})$CR?$LF$/o ); + } + } + + # if we asked for one message, just return its hash, + # otherwise, return hash of numbers => header hash + ref $msgspec eq 'ARRAY' ? \%headers : $headers{$msgspec}; +} + +sub subject { $_[0]->get_header( $_[1], "Subject" ) } +sub date { $_[0]->get_header( $_[1], "Date" ) } +sub rfc822_header { shift->get_header(@_) } + +sub get_header { + my ( $self, $msg, $field ) = @_; + my $headers = $self->parse_headers( $msg, $field ); + $headers ? $headers->{$field}[0] : undef; +} + +sub recent_count { + my ( $self, $folder ) = ( shift, shift ); + + $self->status( $folder, 'RECENT' ) + or return undef; + + my $r = + first { s/\*\s+STATUS\s+.*\(RECENT\s+(\d+)\s*\)/$1/ } $self->History; + chomp $r; + $r; +} + +sub message_count { + my $self = shift; + my $folder = shift || $self->Folder; + + $self->status( $folder, 'MESSAGES' ) + or return undef; + + foreach my $result ( $self->Results ) { + return $1 if $result =~ /\(MESSAGES\s+(\d+)\s*\)/i; + } + + undef; +} + +sub recent() { shift->search('recent') } +sub seen() { shift->search('seen') } +sub unseen() { shift->search('unseen') } +sub messages() { shift->search('ALL') } + +sub sentbefore($$) { shift->_search_date( sentbefore => @_ ) } +sub sentsince($$) { shift->_search_date( sentsince => @_ ) } +sub senton($$) { shift->_search_date( senton => @_ ) } +sub since($$) { shift->_search_date( since => @_ ) } +sub before($$) { shift->_search_date( before => @_ ) } +sub on($$) { shift->_search_date( on => @_ ) } + +sub _search_date($$$) { + my ( $self, $how, $time ) = @_; + my $imapdate; + + if ( $time =~ /\d\d-\D\D\D-\d\d\d\d/ ) { + $imapdate = $time; + } + elsif ( $time =~ /^\d+$/ ) { + my @ltime = localtime $time; + $imapdate = sprintf( "%2.2d-%s-%4.4d", + $ltime[3], + $mnt[ $ltime[4] ], + $ltime[5] + 1900 ); + } + else { + $self->LastError("Invalid date format supplied for '$how': $time"); + return undef; + } + + $self->_imap_uid_command( SEARCH => $how, $imapdate ) + or return undef; + + my @hits; + foreach ( $self->History ) { + chomp; + s/$CR?$LF$//o; + s/^\*\s+SEARCH\s+//i or next; + push @hits, grep /\d/, split; + } + $self->_debug("Hits are: @hits"); + return wantarray ? @hits : \@hits; +} + +sub or { + my ( $self, @what ) = @_; + if ( @what < 2 ) { + $self->LastError("Invalid number of arguments passed to or()"); + return undef; + } + + my $or = + "OR " . $self->Quote( shift @what ) . " " . $self->Quote( shift @what ); + + $or = "OR $or " . $self->Quote($_) for @what; + + $self->_imap_uid_command( SEARCH => $or ) + or return undef; + + my @hits; + foreach ( $self->History ) { + chomp; + s/$CR?$LF$//o; + s/^\*\s+SEARCH\s+//i or next; + push @hits, grep /\d/, split; + } + $self->_debug("Hits are now: @hits"); + + return wantarray ? @hits : \@hits; +} + +sub disconnect { shift->logout } + +sub _quote_search { + my ( $self, @args ) = @_; + my @ret; + foreach my $v (@args) { + if ( ref($v) eq "SCALAR" ) { + push( @ret, $$v ); + } + elsif ( exists $SEARCH_KEYS{ uc($v) } ) { + push( @ret, $v ); + } + elsif ( @args == 1 ) { + push( @ret, $v ); # <3.17 compat: caller responsible for quoting + } + else { + push( @ret, $self->Quote($v) ); + } + } + return @ret; +} + +sub search { + my ( $self, @args ) = @_; + + @args = $self->_quote_search(@args); + + $self->_imap_uid_command( SEARCH => @args ) + or return undef; + + my @hits; + foreach ( $self->History ) { + chomp; + s/$CR?$LF$//o; + s/^\*\s+SEARCH\s+(?=.*?\d)// or next; + push @hits, grep /^\d+$/, split; + } + + @hits + or $self->_debug("Search successful but found no matching messages"); + + # return empty list + return + wantarray ? @hits + : !@hits ? \@hits + : $self->Ranges ? $self->Range( \@hits ) + : \@hits; +} + +# returns a Thread data structure +my $thread_parser; + +sub thread { + my $self = shift; + + return undef unless defined $self->has_capability("THREAD=REFERENCES"); + my $algorythm = shift + || ( + $self->has_capability("THREAD=REFERENCES") + ? 'REFERENCES' + : 'ORDEREDSUBJECT' + ); + + my $charset = shift || 'UTF-8'; + my @a = @_ ? @_ : 'ALL'; + + $a[-1] = $self->Quote( $a[-1], 1 ) + if @a > 1 && !exists $SEARCH_KEYS{ uc $a[-1] }; + + $self->_imap_uid_command( THREAD => $algorythm, $charset, @a ) + or return undef; + + unless ($thread_parser) { + return if ( defined($thread_parser) and $thread_parser == 0 ); + + my $class = $self->_load_module("Thread"); + unless ($class) { + $thread_parser = 0; + return undef; + } + $thread_parser = $class->new; + } + + my $thread; + foreach ( $self->History ) { + /^\*\s+THREAD\s+/ or next; + s/$CR?$LF|$LF+/ /og; + $thread = $thread_parser->start($_); + } + + unless ($thread) { + $self->LastError( +"Thread search completed successfully but found no matching messages" + ); + return undef; + } + + $thread; +} + +sub delete_message { + my $self = shift; + my @msgs = map { ref $_ eq 'ARRAY' ? @$_ : split /\,/ } @_; + + $self->store( join( ',', @msgs ), '+FLAGS.SILENT', '(\Deleted)' ) + ? scalar @msgs + : undef; +} + +sub restore_message { + my $self = shift; + my $msgs = join ',', map { ref $_ eq 'ARRAY' ? @$_ : split /\,/ } @_; + + $self->store( $msgs, '-FLAGS', '(\Deleted)' ) or return undef; + scalar grep /^\*\s\d+\sFETCH\s\(.*FLAGS.*(?!\\Deleted)/, $self->Results; +} + +sub uidvalidity { + my ( $self, $folder ) = @_; + $self->status( $folder, "UIDVALIDITY" ) or return undef; + my $line = first { /UIDVALIDITY/i } $self->History; + defined $line && $line =~ /\(UIDVALIDITY\s+([^\)]+)/ ? $1 : undef; +} + +sub uidnext { + my ( $self, $folder ) = @_; + $self->status( $folder, "UIDNEXT" ) or return undef; + my $line = first { /UIDNEXT/i } $self->History; + defined $line && $line =~ /\(UIDNEXT\s+([^\)]+)/ ? $1 : undef; +} + +sub capability { + 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; +} + +# use "" not undef when lookup fails to differentiate imap command +# failure vs lack of capability +sub has_capability { + my ( $self, $which ) = @_; + $self->capability or return undef; + $which ? $self->{CAPABILITY}{ uc $which } : ""; +} + +sub imap4rev1 { + my $self = shift; + return $self->{_IMAP4REV1} if exists $self->{_IMAP4REV1}; + $self->{_IMAP4REV1} = $self->has_capability('IMAP4REV1'); +} + +#??? what a horror! +sub namespace { + + # Returns a nested list as follows: + # [ + # [ + # [ $user_prefix, $user_delim ] (,[$user_prefix2 ,$user_delim ],...), + # ], + # [ + # [ $shared_prefix,$shared_delim] (,[$shared_prefix2,$shared_delim],... ), + # ], + # [ + # [$public_prefix, $public_delim] (,[$public_prefix2,$public_delim],...), + # ], + # ]; + + my $self = shift; + unless ( $self->has_capability("NAMESPACE") ) { + $self->LastError( "NO NAMESPACE not supported by " . $self->Server ) + unless $self->LastError; + return undef; + } + + my $got = $self->_imap_command("NAMESPACE") or return undef; + my @namespaces = map { /^\* NAMESPACE (.*)/ ? $1 : () } $got->Results; + + my $namespace = shift @namespaces; + $namespace =~ s/$CR?$LF$//o; + + my ( $personal, $shared, $public ) = $namespace =~ m# + (NIL|\((?:\([^\)]+\)\s*)+\))\s + (NIL|\((?:\([^\)]+\)\s*)+\))\s + (NIL|\((?:\([^\)]+\)\s*)+\)) + #xi; + + my @ns; + $self->_debug("NAMESPACE: pers=$personal, shared=$shared, pub=$public"); + foreach ( $personal, $shared, $public ) { + uc $_ ne 'NIL' or next; + s/^\((.*)\)$/$1/; + + my @pieces = m#\(([^\)]*)\)#g; + $self->_debug("NAMESPACE pieces: @pieces"); + + push @ns, [ map { [m#"([^"]*)"\s*#g] } @pieces ]; + } + + return wantarray ? @ns : \@ns; +} + +sub internaldate { + my ( $self, $msg ) = @_; + $self->_imap_uid_command( FETCH => $msg, 'INTERNALDATE' ) + or return undef; + my $hist = join '', $self->History; + return $hist =~ /\bINTERNALDATE "([^"]*)"/i ? $1 : undef; +} + +sub is_parent { + my ( $self, $folder ) = ( shift, shift ); + my $list = $self->list( undef, $folder ) or return undef; + + my $attrs; + foreach my $resp (@$list) { + my $rec = $self->_list_or_lsub_response_parse($resp); + next unless defined $rec->{attrs}; + return 0 if $rec->{attrs} =~ /\bNoInferior\b/i; + $attrs = $rec->{attrs}; + } + + if ($attrs) { + return 1 if $attrs =~ /HasChildren/i; + return 0 if $attrs =~ /HasNoChildren/i; + } + else { + $self->_debug( join( "\n\t", "no attrs for '$folder' in:", @$list ) ); + } + + # BUG? This may be overkill for normal use cases... + # flag not supported or not returned for some reason, try via folders() + my $sep = $self->separator($folder) || $self->separator(undef); + return undef unless defined $sep; + + my $lead = $folder . $sep; + my $len = length $lead; + scalar grep { $lead eq substr( $_, 0, $len ) } $self->folders; +} + +sub selectable { + my ( $self, $f ) = @_; + my $info = $self->list( "", $f ) or return undef; + return not( grep /\b\\Noselect\b/i, @$info ); +} + +# append( $self, $folder, $text [, $optmsg] ) +# - conserve memory and use $_[0] to avoid copying $text (it may be huge!) +# - BUG?: should deprecate this method in favor of append_string +sub append { + my $self = shift; + my $folder = shift; + + # $message_string is whatever is left in @_ + $self->append_string( $folder, ( @_ > 1 ? join( $CRLF, @_ ) : $_[0] ) ); +} + +sub _clean_flags { + my ( $self, $flags ) = @_; + $flags =~ s/^\s+//; + $flags =~ s/\s+$//; + $flags = "($flags)" if $flags !~ /^\(.*\)$/; + return $flags; +} + +# RFC 3501: date-day-fixed = (SP DIGIT) / 2DIGIT +sub _clean_date { + my ( $self, $date ) = @_; + $date =~ s/^\s+// if $date !~ /^\s\d/; + $date =~ s/\s+$//; + $date = qq("$date") if $date !~ /^"/; + return $date; +} + +sub _append_command { + my ( $self, $folder, $flags, $date, $length ) = @_; + return join( " ", + "APPEND $folder", + ( $flags ? $flags : () ), + ( $date ? $date : () ), + "{" . $length . "}", + ); +} + +# append_string( $self, $folder, $text, $flags, $date ) +# - conserve memory and use $_[2] to avoid copying $text (it may be huge!) +sub append_string($$$;$$) { + my ( $self, $folder, $flags, $date ) = @_[ 0, 1, 3, 4 ]; + + #my $text = $_[2]; # conserve memory and use $_[2] instead! + my $maxl = $self->Maxappendstringlength; + + # on "large" strings use append_file to conserve memory + if ( $_[2] and $maxl and length( $_[2] ) > $maxl ) { + $self->_debug("append_string: using in memory file"); + return $self->append_file( $folder, \( $_[2] ), undef, $flags, $date ); + } + + my $text = defined( $_[2] ) ? $_[2] : ''; + + $folder = $self->Quote($folder); + $flags = $self->_clean_flags($flags) if ( defined $flags ); + $date = $self->_clean_date($date) if ( defined $date ); + $text =~ s/\r?\n/$CRLF/og; + + my $cmd = $self->_append_command( $folder, $flags, $date, length($text) ); + $cmd .= $CRLF . $text . $CRLF; + + $self->_imap_command( { addcrlf => 0 }, $cmd ) or return undef; + + my $data = join '', $self->Results; + + # look for something like return size or self if no size found: + # OK [APPENDUID ] APPEND completed + my $ret = $data =~ m#\s+(\d+)\]# ? $1 : $self; + + return $ret; +} + +# BUG?: not much/any savings on cygwin perl 5.10 when using in memory file +# BUG?: we do not retry if sending data fails after getting the OK to send +sub append_file { + my ( $self, $folder, $file, $control, $flags, $date ) = @_; + + my @err; + push( @err, "folder not specified" ) + unless ( defined($folder) and $folder ne "" ); + + my $fh; + if ( !defined($file) ) { + push( @err, "file not specified" ); + } + elsif ( ref($file) and ref($file) ne "SCALAR" ) { + $fh = $file; # let the caller pass in their own file handle directly + } + elsif ( !ref($file) and !-f $file ) { + push( @err, "file '$file' not found" ); + } + else { + + # $file can be a name or a scalar reference (for in memory file) + # avoid IO::File bug handling scalar refs in perl <= 5.8.8? + # - buggy: $fh = IO::File->new( $file, 'r' ) + local ($!); + open( $fh, "<", $file ) + or push( @err, "Unable to open file '$file': $!" ); + } + + if (@err) { + $self->LastError( join( ", ", @err ) ); + return undef; + } + + binmode($fh); + + $folder = $self->Quote($folder) if ( defined $folder ); + $flags = $self->_clean_flags($flags) if ( defined $flags ); + + # allow the date to be specified or even use mtime on file + if ($date) { + $date = $self->Rfc3501_datetime( ( stat($fh) )[9] ) if ( $date eq "1" ); + $date = $self->_clean_date($date); + } + + # BUG? seems wasteful to do this always, provide a "fast path" option? + my $length = 0; + { + local $/ = "\n"; # just in case global is not default + while ( my $line = <$fh> ) { # do no read the whole file at once! + $line =~ s/\r?\n$/$CRLF/; + $length += length($line); + } + seek( $fh, 0, 0 ); + } + + my $cmd = $self->_append_command( $folder, $flags, $date, $length ); + my $rc = $self->_imap_command( $cmd, '+' ); + unless ($rc) { + $self->LastError( "Error sending '$cmd': " . $self->LastError ); + return undef; + } + + # Now send the message itself + my ( $buffer, $buflen ) = ( "", 0 ); + until ( !$buflen and eof($fh) ) { + + if ( $buflen < APPEND_BUFFER_SIZE ) { + FILLBUFF: + while ( my $line = <$fh> ) { + $line =~ s/\r?\n$/$CRLF/; + $buffer .= $line; + $buflen = length($buffer); + last FILLBUFF if ( $buflen >= APPEND_BUFFER_SIZE ); + } + } + + # exit loop entirely if we are out of data + last unless $buflen; + + # save anything over desired buffer size for next iteration + my $savebuff = + ( $buflen > APPEND_BUFFER_SIZE ) + ? substr( $buffer, APPEND_BUFFER_SIZE ) + : undef; + + # reduce buffer to desired size + $buffer = substr( $buffer, 0, APPEND_BUFFER_SIZE ); + + my $bytes_written = $self->_send_bytes( \$buffer ); + unless ($bytes_written) { + $self->LastError( "Error appending message: " . $self->LastError ); + return undef; + } + + # retain any saved data and continue loop + $buffer = defined($savebuff) ? $savebuff : ""; + $buflen = length($buffer); + } + + # finish off append + unless ( $self->_send_bytes( \$CRLF ) ) { + $self->LastError( "Error appending CRLF: " . $self->LastError ); + return undef; + } + + # Now for the crucial test: Did the append work or not? + # look for " (OK|BAD|NO)" + my $code = $self->_get_response( $self->Count ) or return undef; + + if ( $code eq 'OK' ) { + my $data = join '', $self->Results; + + # look for something like return size or self if no size found: + # OK [APPENDUID ] APPEND completed + my $ret = $data =~ m#\s+(\d+)\]# ? $1 : $self; + + return $ret; + } + else { + return undef; + } +} + +# BUG? we should retry if "socket closed while..." but do not currently +sub authenticate { + my ( $self, $scheme, $response ) = @_; + $scheme ||= $self->Authmechanism; + $response ||= $self->Authcallback; + my $clear = $self->Clear; + $self->Clear($clear) + if $self->Count >= $clear && $clear > 0; + + if ( !$scheme ) { + $self->LastError("Authmechanism not set"); + return undef; + } + elsif ( $scheme eq 'LOGIN' ) { + $self->LastError("Authmechanism LOGIN is invalid, use login()"); + return undef; + } + + my $string = "AUTHENTICATE $scheme"; + + # use _imap_command for retry mechanism... + $self->_imap_command( $string, '+' ) or return undef; + + my $count = $self->Count; + my $code; + + # look for "+ " or just "+" + foreach my $line ( $self->Results ) { + if ( $line =~ /^\+\s*(.*?)\s*$/ ) { + $code = $1; + last; + } + } + + # BUG? use _load_module for these too? + if ( $scheme eq 'CRAM-MD5' ) { + $response ||= sub { + my ( $code, $client ) = @_; + require Digest::HMAC_MD5; + my $hmac = + Digest::HMAC_MD5::hmac_md5_hex( decode_base64($code), + $client->Password ); + encode_base64( $client->User . " " . $hmac, '' ); + }; + } + elsif ( $scheme eq 'DIGEST-MD5' ) { + $response ||= sub { + my ( $code, $client ) = @_; + require Authen::SASL; + require Digest::MD5; + + my $authname = + defined $client->Authuser ? $client->Authuser : $client->User; + + my $sasl = Authen::SASL->new( + mechanism => 'DIGEST-MD5', + callback => { + user => $client->User, + pass => $client->Password, + authname => $authname + } + ); + + # client_new is an empty function for DIGEST-MD5 + my $conn = $sasl->client_new( 'imap', 'localhost', '' ); + my $answer = $conn->client_step( decode_base64 $code); + + encode_base64( $answer, '' ) + if defined $answer; + }; + } + elsif ( $scheme eq 'PLAIN' ) { # PLAIN SASL + $response ||= sub { + my ( $code, $client ) = @_; + encode_base64( # [authname] user password + join( + chr(0), + defined $client->Proxy + ? ( $client->User, $client->Proxy ) + : ( "", $client->User ), + defined $client->Password ? $client->Password : "", + ), + '' + ); + }; + } + elsif ( $scheme eq 'NTLM' ) { + $response ||= sub { + my ( $code, $client ) = @_; + + require Authen::NTLM; + Authen::NTLM::ntlm_user( $client->User ); + Authen::NTLM::ntlm_password( $client->Password ); + Authen::NTLM::ntlm_domain( $client->Domain ) if $client->Domain; + Authen::NTLM::ntlm($code); + }; + } + + my $resp = $response->( $code, $self ); + unless ( defined($resp) ) { + $self->LastError( "Error getting $scheme data: " . $self->LastError ); + return undef; + } + unless ( $self->_send_line($resp) ) { + $self->LastError( "Error sending $scheme data: " . $self->LastError ); + return undef; + } + + # this code may be a little too custom to try and use _get_response() + # look for "+ " (not just "+") otherwise " (OK|BAD|NO)" + undef $code; + until ($code) { + my $output = $self->_read_line or return undef; + foreach my $o (@$output) { + $self->_record( $count, $o ); + $code = $o->[DATA] =~ /^\+\s+(.*?)\s*$/ ? $1 : undef; + + if ($code) { + unless ( $self->_send_line( $response->( $code, $self ) ) ) { + $self->LastError( + "Error sending $scheme data: " . $self->LastError ); + return undef; + } + undef $code; # clear code as we are not finished yet + } + + if ( $o->[DATA] =~ /^$count\s+(OK|NO|BAD)\b/i ) { + $code = uc($1); + $self->LastError( $o->[DATA] ) unless ( $code eq 'OK' ); + } + elsif ( $o->[DATA] =~ /^\*\s+BYE/ ) { + $self->State(Unconnected); + $self->LastError( $o->[DATA] ); + return undef; + } + } + } + + return undef unless $code eq 'OK'; + + Authen::NTLM::ntlm_reset() + if $scheme eq 'NTLM'; + + $self->State(Authenticated); + return $self; +} + +# UIDPLUS response from a copy: [COPYUID (uidvalidity) (origuid) (newuid)] +sub copy { + my ( $self, $target, @msgs ) = @_; + + my $msgs = + $self->Ranges + ? $self->Range(@msgs) + : join ',', map { ref $_ ? @$_ : $_ } @msgs; + + $self->_imap_uid_command( COPY => $msgs, $self->Quote($target) ) + or return undef; + + my @results = $self->History; + + my @uids; + foreach (@results) { + chomp; + s/$CR?$LF$//o; + s/^.*\[COPYUID\s+\d+\s+[\d:,]+\s+([\d:,]+)\].*/$1/ or next; + push @uids, /(\d+):(\d+)/ ? ( $1 ... $2 ) : ( split /\,/ ); + + } + return @uids ? join( ",", @uids ) : $self; +} + +sub move { + my ( $self, $target, @msgs ) = @_; + + $self->exists($target) + or $self->create($target) && $self->subscribe($target); + + my $uids = + $self->copy( $target, map { ref $_ eq 'ARRAY' ? @$_ : $_ } @msgs ) + or return undef; + + unless ( $self->delete_message(@msgs) ) { + local ($!); # old versions of Carp could reset $! + carp $self->LastError; + } + + return $uids; +} + +sub set_flag { + my ( $self, $flag, @msgs ) = @_; + @msgs = @{ $msgs[0] } if ref $msgs[0] eq 'ARRAY'; + $flag = "\\$flag" + if $flag =~ /^(?:Answered|Flagged|Deleted|Seen|Draft)$/i; + + my $which = $self->Ranges ? $self->Range(@msgs) : join( ',', @msgs ); + return $self->store( $which, '+FLAGS.SILENT', "($flag)" ); +} + +sub see { + my ( $self, @msgs ) = @_; + @msgs = @{ $msgs[0] } if ref $msgs[0] eq 'ARRAY'; + return $self->set_flag( '\\Seen', @msgs ); +} + +sub mark { + my ( $self, @msgs ) = @_; + @msgs = @{ $msgs[0] } if ref $msgs[0] eq 'ARRAY'; + return $self->set_flag( '\\Flagged', @msgs ); +} + +sub unmark { + my ( $self, @msgs ) = @_; + @msgs = @{ $msgs[0] } if ref $msgs[0] eq 'ARRAY'; + return $self->unset_flag( '\\Flagged', @msgs ); +} + +sub unset_flag { + my ( $self, $flag, @msgs ) = @_; + @msgs = @{ $msgs[0] } if ref $msgs[0] eq 'ARRAY'; + + $flag = "\\$flag" + if $flag =~ /^(?:Answered|Flagged|Deleted|Seen|Draft)$/i; + + return $self->store( join( ",", @msgs ), "-FLAGS.SILENT ($flag)" ); +} + +sub deny_seeing { + my ( $self, @msgs ) = @_; + @msgs = @{ $msgs[0] } if ref $msgs[0] eq 'ARRAY'; + return $self->unset_flag( '\\Seen', @msgs ); +} + +sub size { + my ( $self, $msg ) = @_; + my $data = $self->fetch( $msg, "(RFC822.SIZE)" ) or return undef; + + # beware of response like: * NO Cannot open message $msg + my $cmd = shift @$data; + my $err; + foreach my $line (@$data) { + return $1 if ( $line =~ /RFC822\.SIZE\s+(\d+)/ ); + $err = $line if ( $line =~ /\* NO\b/ ); + } + + if ($err) { + my $info = "$err was returned for $cmd"; + $info =~ s/$CR?$LF//og; + $self->LastError($info); + } + elsif ( !$self->LastError ) { + my $info = "no RFC822.SIZE found in: " . join( " ", @$data ); + $self->LastError($info); + } + return undef; +} + +sub getquotaroot { + my ( $self, $what ) = @_; + my $who = $what ? $self->Quote($what) : "INBOX"; + return $self->_imap_command("GETQUOTAROOT $who") ? $self->Results : undef; +} + +# BUG? using user/$User here and INBOX in quota/quota_usage +sub getquota { + my ( $self, $what ) = @_; + my $who = $what ? $self->Quote($what) : "user/" . $self->User; + return $self->_imap_command("GETQUOTA $who") ? $self->Results : undef; +} + +# usage: $self->setquota($quotaroot, storage => 512, ...) +sub setquota(@) { + my ( $self, $what ) = ( shift, shift ); + my $who = $what ? $self->Quote($what) : "user/" . $self->User; + my @limits; + while (@_) { + my ( $k, $v ) = ( $self->Quote( uc( shift @_ ) ), shift @_ ); + push( @limits, "($k $v)" ); + } + my $limits = join( ' ', @limits ); + $self->_imap_command("SETQUOTA $who $limits") ? $self->Results : undef; +} + +sub quota { + my ( $self, $what ) = ( shift, shift || "INBOX" ); + my $tref = $self->getquota($what) or return undef; + shift @$tref; # pop off command + return ( map { /.*STORAGE\s+\d+\s+(\d+).*\n$/ ? $1 : () } @$tref )[0]; +} + +sub quota_usage { + my ( $self, $what ) = ( shift, shift || "INBOX" ); + my $tref = $self->getquota($what) or return undef; + shift @$tref; # pop off command + return ( map { /.*STORAGE\s+(\d+)\s+\d+.*\n$/ ? $1 : () } @$tref )[0]; +} + +# rfc3501: +# atom-specials = "(" / ")" / "{" / SP / CTL / list-wildcards / +# quoted-specials / resp-specials +# list-wildcards = "%" / "*" +# quoted-specials = DQUOTE / "\" +# resp-specials = "]" +# rfc2060: +# CTL ::= +# Paranoia/safety: +# encode strings with "}" / "[" / "]" / non-ascii chars +sub Quote($) { + my ( $self, $name ) = @_; + if ( $name =~ /["\\[:^ascii:][:cntrl:]]/s ) { + return "{" . length($name) . "}" . $CRLF . $name; + } + elsif ( $name =~ /[(){}\s%*\[\]]/s ) { + return qq("$name"); + } + else { + return $name; + } +} + +# legacy behavior: strip double quote around folder name args! +sub Massage($;$) { + my ( $self, $name, $notFolder ) = @_; + $name =~ s/^\"(.*)\"$/$1/s unless $notFolder; + return $self->Quote($name); +} + +sub unseen_count { + my ( $self, $folder ) = ( shift, shift ); + $folder ||= $self->Folder; + $self->status( $folder, 'UNSEEN' ) or return undef; + + my $r = + first { s/\*\s+STATUS\s+.*\(UNSEEN\s+(\d+)\s*\)/$1/ } $self->History; + + $r =~ s/\D//g; + return $r; +} + +sub State($) { + my ( $self, $state ) = @_; + + if ( defined $state ) { + $self->{State} = $state; + + # discard cached capability info after authentication + delete $self->{CAPABILITY} if ( $state == Authenticated ); + } + + return defined( $self->{State} ) ? $self->{State} : Unconnected; +} + +sub Status { shift->State } +sub IsUnconnected { shift->State == Unconnected } +sub IsConnected { shift->State >= Connected } +sub IsAuthenticated { shift->State >= Authenticated } +sub IsSelected { shift->State == Selected } + +# The following private methods all work on an output line array. +# _data returns the data portion of an output array: +sub _data { ref $_[1] && defined $_[1]->[TYPE] ? $_[1]->[DATA] : undef } + +# _index returns the index portion of an output array: +sub _index { ref $_[1] && defined $_[1]->[TYPE] ? $_[1]->[INDEX] : undef } + +# _type returns the type portion of an output array: +sub _type { ref $_[1] && $_[1]->[TYPE] } + +# _is_literal returns true if this is a literal: +sub _is_literal { ref $_[1] && $_[1]->[TYPE] && $_[1]->[TYPE] eq 'LITERAL' } + +# _is_output_or_literal returns true if this is an +# output line (or the literal part of one): + +sub _is_output_or_literal { + ref $_[1] + && defined $_[1]->[TYPE] + && ( $_[1]->[TYPE] eq "OUTPUT" || $_[1]->[TYPE] eq "LITERAL" ); +} + +# _is_output returns true if this is an output line: +sub _is_output { ref $_[1] && $_[1]->[TYPE] && $_[1]->[TYPE] eq "OUTPUT" } + +# _is_input returns true if this is an input line: +sub _is_input { ref $_[1] && $_[1]->[TYPE] && $_[1]->[TYPE] eq "INPUT" } + +# _next_index returns next_index for a transaction; may legitimately +# return 0 when successful. +sub _next_index { my $r = $_[0]->_transaction( $_[1] ); $r } + +sub Range { + my ( $self, $targ ) = ( shift, shift ); + + UNIVERSAL::isa( $targ, 'Mail::IMAPClient::MessageSet' ) + ? $targ->cat(@_) + : Mail::IMAPClient::MessageSet->new( $targ, @_ ); +} + +1; diff --git a/W/TUTORIAL.t2t b/W/TUTORIAL.t2t index adf1814..b41d0a2 100644 --- a/W/TUTORIAL.t2t +++ b/W/TUTORIAL.t2t @@ -1,25 +1,38 @@ - - -% $Id: TUTORIAL.t2t,v 1.3 2014/10/08 08:49:29 gilles Exp gilles $ +% $Id: TUTORIAL.t2t,v 1.5 2015/05/12 07:20:14 gilles Exp gilles $ = Tutorial for imapsync = -== Introduction == +== Background knowledge about emailboxes == Three Internet protocols are used to access almost all email accounts: -POP, IMAP, HTTP. +POP3, IMAP, HTTP. -The oldest one is POP, Post Office Protocol, it allows only -one main box, also called INBOX. -The second protocol is IMAP, Internet Message Access Protocol, which allows -a hierarchy of mailboxes also called folders, it also allows concurrent accesses, +The oldest one still used is POP3, Post Office Protocol. POP3 allows only +one main box called INBOX. With POP3 messages have no flags, no Seen/UnSeen +Forwarded Flagged labels. Messages are often +removed from the POP3 server each time a software client looks into it, +so messages only appear on the client host that fetched them, they are +unavailable from any other system located elsewhere. + + +The second protocol to deal with email messages is IMAP, Internet Message Access Protocol. + IMAP allows a hierarchy of mailboxes also called folders, concurrent accesses, tagging with flags, search by many criterium like date, subject, size etc. -The third protocol is HTTP, HyperText Transfer Protocol, via webmails. -Webmails often offer the same features than imap servers and, -since webmails background is often an imap server, -a parallel access via IMAP. +IMAP protocol presents most of the features POP lacks. +Messages stay on the imap server so any client on the network can access them +at any time from anywhere, the same messages with the same flags. +The third protocol to access email messages is HTTP, HyperText Transfer Protocol. +HTTP is the protocol to surf the web. +Web browsers like Google Chrome, Mozilla Firefox, Internet Explorer, Safari, +are HTTP client softwares. +Webmails often offer the same features than imap servers because +webmails underlying storage systems are often imap servers. +So webmail mailboxes like Gmail, Yahoo, Exchange, Zimbra or Office365 are also accessible via imap. + +The conclusion of this protocol review is that IMAP can be used +to access mailboxes most of the time. Here comes imapsync. Software imapsync is a command line tool to copy, migrate, backup or synchronize IMAP mailboxes. @@ -28,9 +41,9 @@ copy, migrate, backup or synchronize IMAP mailboxes. Command line means imapsync is not graphical, it is textual, you have to type characters on your keyboard. Your fingers will not suffer anyway because -I wrote examples nearly ready to go. +I wrote file examples nearly ready to go. Most of the time you only have to change values -and adapt them to your context. +in those files and adapt them to your context. Do not be afraid, the mouse will not be forsaken. You can still use the mouse to launch an editor, @@ -42,9 +55,9 @@ It is because imapsync is written in the Perl language and thanks to the Perl creators Perl runs everywhere. Outside imapsync life is different; Historically Windows came after Unix and the marvelous designers -of this old time decided it would be very cool +in this old times decided it would be very cool to not share the same syntax for doing the same things. -Thanks guys, great thinking! +Thanks guys, great thinking! To avoid you to learn by headaches a system you do not master I will give all examples in both worlds, Unix and Windows. @@ -82,7 +95,7 @@ is equivalent to and on Windows ``` - imapsync ^ + imapsync.exe ^ --host1 imap.truc.org ^ --user1 foo ^ --password1 secret1 ^ diff --git a/W/build_exe.bat b/W/build_exe.bat index 5904c82..4088fdc 100644 --- a/W/build_exe.bat +++ b/W/build_exe.bat @@ -1,5 +1,5 @@ -REM $Id: build_exe.bat,v 1.27 2015/03/27 23:35:13 gilles Exp gilles $ +REM $Id: build_exe.bat,v 1.28 2015/05/11 01:09:57 gilles Exp gilles $ @ECHO OFF ECHO Building imapsync.exe @@ -29,6 +29,10 @@ perl ^ -mTime::Local ^ -mUnicode::String ^ -mURI::Escape ^ + -mJSON::WebToken ^ + -mLWP::UserAgent ^ + -mHTML::Entities ^ + -mJSON ^ -e '' cd @@ -55,6 +59,10 @@ pp -o imapsync.exe ^ -M File::Copy::Recursive ^ -M IO::Tee ^ -M Unicode::String ^ + -M JSON::WebToken ^ + -M LWP::UserAgent ^ + -M HTML::Entities ^ + -M JSON ^ .\imapsync echo Done building imapsync.exe diff --git a/W/build_mac.sh b/W/build_mac.sh new file mode 100755 index 0000000..a0f832a --- /dev/null +++ b/W/build_mac.sh @@ -0,0 +1,22 @@ +#!/bin/sh + +eval `perl -I $HOME/perl5/lib/perl5 -Mlocal::lib` +export MANPATH=$HOME/perl5/man:$MANPATH + +HOSTNAME=`hostname -s` +ARCH=`uname -m` +KERNEL=`uname -s` +echo "$HOSTNAME $ARCH $KERNEL" + +VERSION=`./imapsync --version` +BIN_NAME=imapsync_bin_Darwin + +pp -o $BIN_NAME \ + -M Mail::IMAPClient -M IO::Socket -M IO::Socket::SSL \ + -M Digest::MD5 -M Digest::HMAC_MD5 -M Term::ReadKey \ + -M Authen::NTLM \ + imapsync + +./imapsync_bin_Darwin +./imapsync_bin_Darwin --tests +./imapsync_bin_Darwin --testslive diff --git a/W/imapsync.1 b/W/imapsync.1 index 6718ef5..272d4d3 100644 --- a/W/imapsync.1 +++ b/W/imapsync.1 @@ -124,7 +124,7 @@ .\" ======================================================================== .\" .IX Title "IMAPSYNC 1" -.TH IMAPSYNC 1 "2015-04-01" "perl v5.14.2" "User Contributed Perl Documentation" +.TH IMAPSYNC 1 "2015-07-17" "perl v5.14.2" "User Contributed Perl Documentation" .\" For nroff, turn off justification. Always turn off hyphenation; it makes .\" way too many mistakes in technical documents. .if n .ad l @@ -135,7 +135,7 @@ Synchronises mailboxes between two imap servers. Good at IMAP migration. More than 52 different IMAP server softwares supported with success, few failures. .PP -$Revision: 1.637 $ +$Revision: 1.644 $ .SH "SYNOPSIS" .IX Header "SYNOPSIS" To synchronize imap account \*(L"foo\*(R" on \*(L"imap.truc.org\*(R" @@ -489,130 +489,7 @@ http://www.catb.org/~esr/faqs/smart\-questions.html and then forget it. .SH "IMAP SERVERS" .IX Header "IMAP SERVERS" -Failure stories reported in the past with the following 6 imap servers. -Maybe last imapsync release can run successfully with them. -Don't hesitate to have a try, It's been a long time since last failure occured, -I will help you and make efforts to switch them to the success list, -that's my job. -.PP -.Vb 9 -\& \- 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). -\& \- (2011) MDaemon 12.0.3 as host2 but MDaemon is supported as host1. -\& MDaemon is simply buggy with the APPEND IMAP command with -\& any IMAP email client. -\& \- Hotmail since hotmail.com does not provide IMAP access -\& \- Outlook.com since outlook.com does not provide IMAP access -.Ve -.PP -Success stories reported with the following 62 imap servers -(software names are in alphabetic order): -.PP -.Vb 10 -\& \- 1und1 H mimap1 84498 [host1] H mibap4 95231 [host1] -\& \- a1.net imap.a1.net IMAP4 Ready [host1] -\& \- Apple Server 10.6 Snow Leopard [host1] -\& \- Archiveopteryx 2.03, 2.04, 2.09, 2.10 [host2], 3.0.0 [host2] -\& (OSL 3.0) http://www.archiveopteryx.org/ -\& \- Atmail 6.x [host1] -\& \- Axigen Mail Server Version 8.0.0 -\& \- 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.3, 2.2.6, 2.2.10, 2.2.12, 2.2.13, -\& 2.3\-alpha (OSI Approved), 2.3.1, 2.3.7, 2.3.16 -\& (http://asg.web.cmu.edu/cyrus/) -\& \- David Tobit V8 (proprietary Message system). -\& \- Deerfield VisNetic MailServer 5.8.6 [host1] (http://www.deerfield.net/products/visnetic\-mailserver/) -\& \- DBMail 1.2.1, 2.0.4, 2.0.9, 2.2rc1 (GPL) (http://www.dbmail.org/). -\& 2.0.7 seems buggy. -\& \- DBOX 2.41 System [host1] (http://www.dbox.handshake.de/). -\& \- 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], 8.5.3 [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 -\& \- FirtClass 9 [host1] Read the FAQ! (http://www.firstclass.com/) -\& \- FTGate (http://www.ftgate.com/) -\& \- Fusemail imap.fusemail.net:143 (https://www.fusemail.com/). -\& \- Gimap (Gmail imap) -\& \- GMX IMAP4 StreamProxy. -\& \- Groupwise IMAP (Novell) 6.x and 7.0. Buggy so see the FAQ. -\& \- hMailServer 5.40\-B1950 [host12], 5.3.3 [host2], 4.4.1 [host1] (see FAQ) -\& \- IceWarp Server 10.4.5 [host1] (http://www.icewarp.com/) -\& \- iPlanet Messaging server 4.15, 5.1, 5.2 -\& \- IMail 7.15 (Ipswitch/Win2003), 8.12, 11.03 [host1] -\& \- Kerio 7.2.0 Patch 1 [host12], Kerio 8 [host1] -\& \- Mail2World IMAP4 Server 2.5 [host1] (http://www.mail2world.com/) -\& \- MailEnable 4.23 [host1] [host2], 4.26 [host1][host2], 5 [host1] -\& \- MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform), -\& 9.6.5 [host1], 12 [host2], 12.0.3 [host1], 12.5.5 [host1], -\& 13.5 [host2], 14.5 [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, 4.1.9\-GA [host1] -\& \- Netscape Mail Server 3.6 (Wintel !) -\& \- Netscape Messaging Server 4.15 Patch 7 -\& \- Office 365 [host1] [host2] -\& \- OpenMail IMAP server B.07.00.k0 (Samsung Contact ?) -\& \- OpenWave -\& \- Oracle Beehive [host1] -\& \- Parallels Plesk Panel 9.x [host2] 11.x [host2] (http://www.parallels.com/) -\& \- Qualcomm Worldmail (NT) -\& \- QQMail IMAP4Server [host1] [host2] https://en.mail.qq.com/ -\& \- RackSpace hoster secure.emailsrvr.com:993 http://www.rackspace.com/ -\& \- 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, 11.4.6 -\& \- Sendmail Mail Store IMAP4rev1 (5.5.6/mstore\-5\-5\-build\-1874 [host1]. -\& \- SmarterMail, Smarter Mail 5.0 Enterprise, Smarter Mail 5.5 [host1], -\& SmarterMail Professional 10.2 [host1], Smarter Mail 11.7 [host1][host2]. -\& \- Softalk Workgroup Mail 7.6.4 [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, 6.3d\-72 [host2] -\& \- 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 -\& \- Yahoo [host1] -\& \- Zarafa 6,40,0,20653 [host1] (http://www.zarafa.com/) -\& \- Zarafa ZCP 7.1.4 IMAP Gateway [host2] -\& \- 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 -.Ve -.PP -Please report to the author any success or bad story with -imapsync and do not forget to mention the \s-1IMAP\s0 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: -.PP -.Vb 2 -\& Host1 software:* OK louloutte Cyrus IMAP4 v1.5.19 server ready -\& Host2 software:* OK Courier\-IMAP ready -.Ve -.PP -You can use option \-\-justconnect to get those lines. -Example: -.PP -.Vb 1 -\& imapsync \-\-host1 imap.troc.org \-\-host2 imap.trac.org \-\-justconnect -.Ve +See http://imapsync.lamiral.info/S/imapservers.shtml .SH "HUGE MIGRATION" .IX Header "HUGE MIGRATION" Pay special attention to options @@ -692,4 +569,4 @@ https://web.archive.org/web/20070202005121/http://www.imap.org/products/showall. .PP Feedback (good or bad) will often be welcome. .PP -\&\f(CW$Id:\fR imapsync,v 1.637 2015/04/01 01:36:37 gilles Exp gilles $ +\&\f(CW$Id:\fR imapsync,v 1.644 2015/07/17 01:22:52 gilles Exp gilles $ diff --git a/W/install_modules.bat b/W/install_modules.bat index 3f541b4..83a0ce3 100644 --- a/W/install_modules.bat +++ b/W/install_modules.bat @@ -1,5 +1,5 @@ -REM $Id: install_modules.bat,v 1.15 2015/03/03 11:23:12 gilles Exp gilles $ +REM $Id: install_modules.bat,v 1.17 2015/05/23 09:40:38 gilles Exp gilles $ @ECHO OFF @@ -33,6 +33,10 @@ FOR %%M in ( ^ Test::Pod ^ Unicode::String ^ URI::Escape ^ + JSON::WebToken ^ + LWP ^ + HTML::Entities ^ + JSON ^ ) DO ECHO Updating %%M ^ & perl -MCPAN -e "install %%M" diff --git a/W/learn/imapclient3xx_skeleton_test b/W/learn/imapclient3xx_skeleton_test old mode 100644 new mode 100755 diff --git a/W/learn/mail2world b/W/learn/mail2world new file mode 100755 index 0000000..c017876 --- /dev/null +++ b/W/learn/mail2world @@ -0,0 +1,43 @@ +#!/usr/bin/perl -w + +use lib '/g/public_html/imapsync/W/Mail-IMAPClient-3.35/lib/' ; +use Mail::IMAPClient ; +use Data::Dumper ; + +$ARGV[3] or die "usage: $0 host user password folder\n" ; + +print "Mail::IMAPClient $Mail::IMAPClient::VERSION\n" ; +$host = $ARGV[0] ; +$user = $ARGV[1] ; +$password = $ARGV[2] ; +$folder = $ARGV[3] ; + +my $imap = Mail::IMAPClient->new(); +$imap->Debug(1); +$imap->Uid( 0 ) ; +$imap->Server( $host ) ; +$imap->connect( ) or die ; +$imap->IsUnconnected( ); +$imap->User( $user ) ; +$imap->Password( $password ) ; +$imap->login( ) or die ; +$imap->Uid( 1 ) ; +$imap->Peek( 1 ) ; +$imap->select( $folder ) or die ; + +print "==== tag_and_run\n" ; +$imap->tag_and_run( 'UID FETCH 1:* ( RFC822.SIZE )' ) ; + +print "==== fetch\n" ; +print $imap->fetch( "1:*", "RFC822.SIZE" ) ; + +print "==== fetch_hash\n" ; +my $hashref = {} ; +$imap->fetch_hash( "1:*", "RFC822.SIZE", $hashref ) ; + +foreach my $m (keys %$hashref) { + print "Msg $m is ", $hashref->{$m}->{'RFC822.SIZE'}, " bytes\n" ; +} +print Data::Dumper->Dump( [ $hashref ] ) ; + +$imap->logout( ) ; diff --git a/W/memo b/W/memo index e8bd5bb..5c4de5a 100644 --- a/W/memo +++ b/W/memo @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: memo,v 1.51 2015/01/19 01:26:51 gilles Exp gilles $ +# $Id: memo,v 1.52 2015/04/25 01:27:47 gilles Exp gilles $ count_nice() { @@ -231,6 +231,7 @@ statistics_VERSION_synthesis() { statistics_VERSION_yearly_runs $yyyy done ) + } @@ -456,6 +457,10 @@ statistics_VERSION_synthesis() { echo -n "$yyyy: " statistics_VERSION_yearly_runs $yyyy done + nb_runs_current_year=`statistics_VERSION_yearly_runs $year_now` + current_day_of_year=`date +%j` + echo; echo -n "$year_now~~" + echo "$nb_runs_current_year/$current_day_of_year*365" | bc ) } diff --git a/W/ml_announce.in b/W/ml_announce.in index 76c45d0..d7b5bb5 100644 --- a/W/ml_announce.in +++ b/W/ml_announce.in @@ -1,4 +1,4 @@ -m4_dnl $Id: ml_announce.in,v 1.8 2014/10/22 11:04:30 gilles Exp gilles $ +m4_dnl $Id: ml_announce.in,v 1.11 2015/04/01 12:29:55 gilles Exp gilles $ m4_dnl m4_define(`M4_imapsync_VERSION',m4_esyscmd(cat VERSION|tr -d '\n'))m4_dnl m4_define(`M4_SECRET_PATH',m4_esyscmd(cat dist/path_last.txt|tr -d '\n'))m4_dnl @@ -8,7 +8,7 @@ Bcc: gilles@lamiral.info Subject: [imapsync update] new imapsync release M4_imapsync_VERSION available To: imapsync_update@lists.lamiral.info -Hello imapsync user, +Dear imapsync user, You're subscribed to the newsletter announcing imapsync new releases (very few traffic) and the way to get them. Send me a note if you @@ -17,19 +17,19 @@ don't want to receive those announces anymore. You will find the latest imapsync.exe binary (release M4_imapsync_VERSION) and the latest imapsync source code (release M4_imapsync_VERSION) at the following link: -http://imapsync.lamiral.info/dist/M4_SECRET_PATH/ + http://imapsync.lamiral.info/dist/M4_SECRET_PATH/ -or also from this page +or also more permanently from this page -http://imapsync.lamiral.info/paypal_return.shtml + http://imapsync.lamiral.info/paypal_return.shtml -Three files are there: -- imapsync is directly the perl script (also found in the tarball) for a fast upgrade. -- imapsync-M4_imapsync_VERSION.tgz is the tarball containing everything of the project (maybe too much) -- imapsync.M4_imapsync_VERSION.zip is the win32 zip archive including standalone binary imapsync.exe. +Three important files are there: +* imapsync is directly the perl script (also found in the tarball and zip) for a fast upgrade. +* imapsync-M4_imapsync_VERSION.tgz is the tarball containing everything of the project (maybe too much) +* imapsync.M4_imapsync_VERSION.zip is the win32 zip archive including standalone binary imapsync.exe. What's new in this M4_imapsync_VERSION release can be found at -http://imapsync.lamiral.info/#latest +http://imapsync.lamiral.info/S/news.shtml I thank you again for buying and using imapsync, I wish you successful imap transfers! diff --git a/W/paypal_reply/bnc_col_prep.txt b/W/paypal_reply/bnc_col_prep.txt deleted file mode 100644 index 60d90a1..0000000 --- a/W/paypal_reply/bnc_col_prep.txt +++ /dev/null @@ -1,93 +0,0 @@ -Date -Code journal -Nom journal -Cte tresorerie associe -Reference -Libelle -Montant TTC -non utilise -Code tiers -Pointage tiers -Compte ventilation 1 -Libelle ventilation 1 -Code TVA 1 -Compte analytique 1 -Montant depense 1 -Montant recette 1 -Montant TVA 1 -Compte TVA 1 -Compte ventilation 2 -Libelle ventilation 2 -Code TVA 2 -Compte analytique 2 -Montant depense 2 -Montant recette 2 -Montant TVA 2 -Compte TVA 2 -Compte ventilation 3 -Libelle ventilation 3 -Code TVA 3 -Compte analytique 3 -Montant depense 3 -Montant recette 3 -Montant TVA 3 -Compte TVA 3 -Compte ventilation 4 -Libelle ventilation 4 -Code TVA 4 -Compte analytique 4 -Montant depense 4 -Montant recette 4 -Montant TVA 4 -Compte TVA 4 -Compte ventilation 5 -Libelle ventilation 5 -Code TVA 5 -Compte analytique 5 -Montant depense 5 -Montant recette 5 -Montant TVA 5 -Compte TVA 5 -Compte ventilation 6 -Libelle ventilation 6 -Code TVA 6 -Compte analytique 6 -Montant depense 6 -Montant recette 6 -Montant TVA 6 -Compte TVA 6 -Compte ventilation 7 -Libelle ventilation 7 -Code TVA 7 -Compte analytique 7 -Montant depense 7 -Montant recette 7 -Montant TVA 7 -Compte TVA 7 -Compte ventilation 8 -Libelle ventilation 8 -Code TVA 8 -Compte analytique 8 -Montant depense 8 -Montant recette 8 -Montant TVA 8 -Compte TVA 8 -Compte ventilation 9 -Libelle ventilation 9 -Code TVA 9 -Compte analytique 9 -Montant depense 9 -Montant recette 9 -Montant TVA 9 -Compte TVA 9 -Compte ventilation 10 -Libelle ventilation 10 -Code TVA 1 -Compte analytique 10 -Montant depense 10 -Montant recette 10 -Montant TVA 10 -Compte TVA 10 -Pointage -Divers -Verrou diff --git a/W/paypal_reply/memo b/W/paypal_reply/memo index ace157e..9dff3be 100644 --- a/W/paypal_reply/memo +++ b/W/paypal_reply/memo @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: memo,v 1.16 2014/05/01 22:08:06 gilles Exp $ +# $Id: memo,v 1.17 2015/07/02 11:53:28 gilles Exp gilles $ echo paypal_bilan_todo diff --git a/W/paypal_reply/paypal_bilan_1.73 b/W/paypal_reply/paypal_bilan_1.73 deleted file mode 100755 index 2dc4130..0000000 --- a/W/paypal_reply/paypal_bilan_1.73 +++ /dev/null @@ -1,1348 +0,0 @@ -#!/usr/bin/perl - -# $Id: paypal_bilan,v 1.73 2014/04/26 16:59:32 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); -use Test::More 'no_plan' ; - -die unless (utf8_supported_charset('ISO-8859-1')); - -my $rcs = '$Id: paypal_bilan,v 1.73 2014/04/26 16:59:32 gilles Exp $ ' ; -$rcs =~ m/,v (\d+\.\d+)/ ; -my $VERSION = ($1) ? $1: "UNKNOWN" ; - - -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_HT_EUR_sup_exo = 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 $nb_invoice_canceled = 0 ; - -my ( $tests, $testeur ) ; -my $dry ; -my $debug ; -my $debug_csv ; -my $debug_dev ; -my $debug_invoice ; -my $debug_invoice_utf8 ; - -my $first_invoice = 1 ; -my $print_details = '' ; -my $bnc = '' ; -my $exportbnc = '' ; - -my $usdeur = 1.2981 ; -my $invoices ; -my %invoice_refund ; -my %invoice_canceled ; -my %invoice_suspended ; -my $write_invoices = 0 ; -my $avoid_numbers ; - -my $dir_invoices = '/g/var/paypal_invoices' ; - -my $option_ret = GetOptions ( - 'tests' => \$tests, - 'dry' => \$dry, - 'debug' => \$debug, - 'debug_csv' => \$debug_csv, - 'debug_dev' => \$debug_dev, - 'debug_invoice' => \$debug_invoice, - 'debug_invoice_utf8' => \$debug_invoice_utf8, - - 'first_invoice=i' => \$first_invoice, - 'print_details|details' => \$print_details, - 'bnc' => \$bnc, - 'exportbnc=s' => \$exportbnc, - '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_invoice ; - -my %invoice_paypal ; - -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" ; - -my @actions ; - -foreach my $file ( @files ) { - - my @actions_file = parse_file( $file ) ; - push( @actions, @actions_file ) ; -} - -foreach my $action (@actions) { - # compute_line() adds $action->{ 'invoice' } if needed - compute_line( $action ) ; - - # index by invoice number - $action_invoice{ $action->{ 'invoice' } } = $action ; -} -delete $action_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_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 }++ ; - build_invoice( $invoice ) if ( $debug_invoice or $debug_invoice_utf8 ) ; - }elsif( not ( $invoice_canceled{ $invoice } or $invoice_refund{ $invoice } ) ) { - $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 ) ; - -my @invoice_canceled = sort { $a <=> $b } keys( %invoice_canceled ) ; -my @invoice_suspended = sort { $a <=> $b } keys( %invoice_suspended ) ; -my @invoice_refund = sort { $a <=> $b } keys( %invoice_refund ) ; - - -print( "\n", "=" x 60, "\n" ) ; - -my $total_usd_paypal_cost ; -$total_usd_paypal_cost = sprintf('%2.2f', $total_usd_invoice - $total_usd_received ) ; -print "USD received $total_usd_received\n" ; -print "USD invoice $total_usd_invoice\n" ; -print "USD costs $total_usd_paypal_cost\n" ; - -my $total_eur_invoice_from_usd ; -my $total_eur_received_from_usd ; -my $total_eur_paypal_cost_from_usd ; - -# au 30 nov 2010 http://fr.finance.yahoo.com/devises/convertisseur/#from=EUR;to=USD;amt=1 -$total_eur_invoice_from_usd = sprintf('%2.2f', $total_usd_invoice / $usdeur ) ; -$total_eur_received_from_usd = sprintf('%2.2f', $total_usd_received / $usdeur ) ; -$total_eur_paypal_cost_from_usd = sprintf('%2.2f', $total_usd_paypal_cost / $usdeur ) ; - -# EUR -$total_eur_received = sprintf('%2.2f', $total_eur_received) ; -$total_eur_invoice = sprintf('%2.2f', $total_eur_invoice) ; -print "EUR invoice from USD $total_eur_invoice_from_usd\n" ; -print "EUR received from EUR $total_eur_received\n" ; -print "EUR invoice from EUR $total_eur_invoice\n" ; - -my $total_eur_invoice_from_eur_usd = $total_eur_invoice_from_usd + $total_eur_invoice ; -my $total_eur_received_from_eur_usd = $total_eur_received_from_usd + $total_eur_received ; -my $total_eur_paypal_cost = $total_eur_invoice - $total_eur_received + $total_eur_paypal_cost_from_usd ; - - -$total_HT_EUR_exo = sprintf('%2.2f', $total_HT_EUR_exo) ; -$total_HT_EUR_ass = sprintf('%2.2f', $total_HT_EUR_ass) ; -$total_TVA_EUR = sprintf('%2.2f', $total_TVA_EUR) ; - -$total_HT_EUR_sup = sprintf('%2.2f', $total_HT_EUR_sup) ; -$total_TVA_EUR_sup = sprintf('%2.2f', $total_TVA_EUR_sup) ; -$total_HT_EUR_sup_exo = sprintf('%2.2f', $total_HT_EUR_sup_exo) ; - -$total_eur_invoice_from_eur_usd = sprintf('%2.2f', $total_eur_invoice_from_eur_usd) ; -$total_eur_paypal_cost = sprintf('%2.2f', $total_eur_paypal_cost) ; - -print( "---- USD + EUR ----\n" ) ; -print "EUR total invoice $total_eur_invoice_from_eur_usd\n" ; -print "EUR total received $total_eur_received_from_eur_usd\n" ; -print "EUR total paypal cost $total_eur_paypal_cost\n" ; -print ; -print( "---- Assujeti TVA ----\n" ) ; -print "EUR total HT licen assuj $total_HT_EUR_ass (autres operations imposables)\n" ; -#print "EUR total TVA licen assuj $total_TVA_EUR\n" ; -print "EUR total HT supp assuj $total_HT_EUR_sup (ventes, prestations)\n" ; -#print "EUR total TVA supp assuj $total_TVA_EUR_sup\n" ; - -print( "---- Exonere TVA ----\n" ) ; -print "EUR total HT licen exo $total_HT_EUR_exo (autres operations NON imposables)\n" ; -print "EUR total HT suppo exo $total_HT_EUR_sup_exo (autres operations NON imposables)\n" ; - -print( "---- Invoices ----\n" ) ; - -print "Nb invoice $nb_invoice ( from $first_invoice_paypal to $last_invoice )\n" ; -print "Nb invoice canceled ($nb_invoice_canceled) @invoice_canceled\n" ; -print "Nb invoice suspended ($nb_invoice_suspended) @invoice_suspended\n" ; -print "Nb invoice refund ($nb_invoice_refund) @invoice_refund\n" ; -print "Nb invoice sent $nb_invoice_sent\n" ; -print "Have to send invoices @invoice_not_sent\n" if ( @invoice_not_sent ) ; - -my $total_eur2 = $total_HT_EUR_exo + $total_HT_EUR_ass + $total_TVA_EUR + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo ; -$total_eur2 = sprintf('%2.2f', $total_eur2) ; -print "$total_eur_invoice_from_eur_usd != $total_eur2 = $total_HT_EUR_exo + $total_HT_EUR_ass + $total_TVA_EUR + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo\n" -if ( $total_eur_invoice_from_eur_usd != $total_eur2 ) ; - -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 invoice_00000 { - my $invoice = shift ; - - return( sprintf( "%04d", $invoice ) ) ; -} - -sub tests_invoice_00000 { - - ok( '0000' eq invoice_00000( 0 ), 'invoice_00000: 0 -> 0000' ) ; - ok( '0147' eq invoice_00000( 147 ), 'invoice_00000: 147 -> 0147' ) ; - ok( '99999' eq invoice_00000( 99999 ), 'invoice_00000: 99999 -> 99999' ) ; -} - -sub tests_next_invoice { - ok( 1 == next_invoice( ), 'next_invoice: 1' ) ; - ok( 2 == next_invoice( ), 'next_invoice: 2' ) ; - @avoid_numbers{ (3, 4, 6, 8 ) } = ( ) ; - ok( 5 == next_invoice( ), 'next_invoice: 7' ) ; - ok( 7 == next_invoice( ), 'next_invoice: 8' ) ; - ok( 9 == next_invoice( ), 'next_invoice: 9' ) ; - %invoice_paypal = () ; - $first_invoice = 7 ; - ok( 7 == next_invoice( ), 'next_invoice: 7' ) ; -} - - -sub tests_exportbnc { - ok( 1 == 1, '1 == 1' ) ; - -} - - - -sub tests { - tests_next_invoice( ) ; - tests_cut( ) ; - tests_invoice_00000( ) ; - #tests_exportbnc( ) ; - tests_tva_rate( ) ; - tests_tva_rate_str( ) ; -} - -sub compute_line { - - my $action = shift ; - my %action = %$action ; - - my( $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, $Nom_Option_2, $Option_2_Valeur, - $Impact_sur_le_solde ) - = @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", 'Nom Option 2', 'Option 2 Valeur', - 'Impact sur le solde') } ; - #print "[$Option_2_Valeur] [$Impact_sur_le_solde]\n" ; - #next; - ( $Etat ) = @action{ ( 'Etat' ) } || @action{ ( 'État' ) } ; - ( $Hors_taxe_paypal ) = @action{ ( 'Hors taxe' ) } || @action{ ( 'Avant commission' ) } ; - $Impact_sur_le_solde ||= '' ; - - my $invoice = 'NONE' ; - $Montant = $action->{ 'Net' } if not defined $Montant; - - - $debug and print( "#" x 78, "\n", - "[$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] ", - "[$Devise] [$Hors_taxe_paypal] [$Montant] [$Numero_davis_de_reception] [$Solde] [$Impact_sur_le_solde] ", - "[$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, $montant_HT_EUR_sup_exo ) ; - - 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] [$Impact_sur_le_solde]\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, $montant_HT_EUR_sup_exo ) - = tva_line( $Devise, $Montant2_usd, $Pays, $Nom_Option_1, $Valeur_Option_1, $Titre_de_l_objet, $Date ) ; - $total_HT_EUR_exo += $montant_HT_EUR_exo ; - $total_HT_EUR_ass += $montant_HT_EUR_ass ; - $total_TVA_EUR += $montant_TVA_EUR ; - - $invoice = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde] [$Impact_sur_le_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, $montant_HT_EUR_sup_exo ) - = tva_line( $Devise, $Montant2_eur, $Pays, $Nom_Option_1, $Valeur_Option_1, $Titre_de_l_objet, $Date ) ; - $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 ; - $total_HT_EUR_sup_exo += $montant_HT_EUR_sup_exo ; - - $invoice = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde] [$Impact_sur_le_solde]\n" ) ; - } - - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and 'Remboursé' eq $Etat - ) { - $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] [$Impact_sur_le_solde]\n" ) ; - } - - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and 'Annulé' eq $Etat - ) { - $invoice = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_canceled++; - $invoice_canceled{ $invoice }++ ; - - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde] [$Impact_sur_le_solde]\n" ) ; - } - - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and 'Suspendu' eq $Etat - ) { - $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] [$Impact_sur_le_solde]\n" ) ; - } - - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and 'Non compensé' eq $Etat - ) { - $invoice = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde] [$Impact_sur_le_solde]\n" ) ; - } - - $action->{ 'invoice' } = $invoice ; - if ( $bnc ) { - my $FR_flag = FR_flag( $Pays ) ; - my $IND_flag = IND_flag( $Nom_Option_1, $Valeur_Option_1 ) ; - my $SUPPORT_flag = SUPPORT_flag( $Titre_de_l_objet ) ; - my $BNC_output = BNC_output( $invoice, $FR_flag, $IND_flag, $SUPPORT_flag, - $Nom, $Date, $MontantEUR, $Devise, $Titre_de_l_objet, $Impact_sur_le_solde, $Type ) ; - print $BNC_output ; - } -} - -sub BNC_output { -# FE 1359 FR IND imapsync Bougon Edouard -# [12/01/2012] FR IND 28.73 EUR - my( $invoice, $FR_flag, $IND_flag, $SUPPORT_flag, - $Nom, $Date, $MontantEUR, $Devise, $Titre_de_l_objet, $Impact_sur_le_solde, $Type ) = @_ ; - - my $BNC_output ; - - if ( 'NONE' eq $invoice ) { - $BNC_output = "[$Date] $MontantEUR $Devise $Nom $Titre_de_l_objet [$Impact_sur_le_solde] [$Type]\n" ; - }else{ - $BNC_output = - "FE $invoice$FR_flag$IND_flag imapsync$SUPPORT_flag $Nom\n" - . "[$Date]$FR_flag$IND_flag $MontantEUR $Devise \n" ; - } - return( $BNC_output ) ; -} - -sub SUPPORT_flag { - my $Titre_de_l_objet = shift ; - my $SUPPORT_flag = '' ; - $SUPPORT_flag = ' support' if ( 'imapsync support' eq $Titre_de_l_objet ) ; -} - -sub IND_flag { - my( $Nom_Option_1, $Valeur_Option_1 ) = @_ ; - my $IND_flag = '' ; - $IND_flag = ' IND' if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) ; - return( $IND_flag ) ; -} - -sub FR_flag { - my $Pays = shift ; - my $FR_flag = '' ; - - $FR_flag = ' FR' if $Pays eq 'France' ; - return( $FR_flag ) ; -} - -sub build_invoice { - my $invoice = shift ; - - return if ! $invoice ; - - my $action = $action_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, - $Nom_Option_2, $Option_2_Valeur ) - = @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', - 'Nom Option 2', 'Option 2 Valeur' ) } ; - - $Etat_Province = @action{ ( 'Etat/Province/Région/Comté/Territoire/Préfecture/République' ) } - || @action{ ( 'État/Province/Région/Comté/Territoire/Préfecture/République' ) } - || '' ; - ( $Hors_taxe ) = @action{ ( 'Hors taxe' ) } || @action{ ( 'Avant commission' ) } ; - #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_address( - $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, - $HTorTTC - ) - = tva_stuff( $clientTypeEN, $Pays, $Hors_taxe, $Devise, $Titre_de_l_objet, $Date ) ; - - 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 ( $Nom1 ) = cut( $Nom, 42 ) ; - - my $clientVAT = '' ; - - if ( ( 'VAT if professional in Europe' eq $Nom_Option_2 ) and $Option_2_Valeur ) { - $clientVAT = $Option_2_Valeur ; - } - - my $tex_variables = qq{ -%% Begin input from paypal_bilan $VERSION -\\providecommand{\\invoiceNumber}{$invoice} -\\providecommand{\\clientName}{$Nom1} -\\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{\\clientVAT}{$clientVAT} -\\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{\\HTorTTC}{$HTorTTC} -\\providecommand{\\priceTTC}{$priceTTC} -\\providecommand{\\priceTTCusd}{$priceTTCusd} -\\providecommand{\\messageTVAFR}{$messageTVAFR} -\\providecommand{\\messageTVAEN}{$messageTVAEN} -\\providecommand{\\urlSrc}{\\url{$urlSrc}} -\\providecommand{\\urlExe}{\\url{$urlExe}} -%% End input from paypal_bilan -} ; - - my $tex_variables_utf8 = to_utf8( { -string => $tex_variables, -charset => 'ISO-8859-1' } ) ; - - $debug_invoice_utf8 and print $tex_variables_utf8 ; - $debug_invoice and 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_utf8 ) ; - } - -} - -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, autorisés.' ; - $descriptionEN = '(Imapsync software. ALL rights conceded, allowed.)' ; - } - - 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. - -Last imapsync release is available from the page -http://imapsync.lamiral.info/paypal_return.shtml - -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. - -Last imapsync release is available from the page -http://imapsync.lamiral.info/paypal_return.shtml - -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 ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - $debug and print "Writing $dir_invoices/$invoice_00000/csv_info.txt\n" ; - $dry and return( ) ; - - open( CSVINFO, "> $dir_invoices/$invoice_00000/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 ) = @_ ; - my $invoice_00000 = invoice_00000( $invoice ) ; - return( 1 ) if ( -f "$dir_invoices/$invoice_00000/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' }); - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $dry and return( ) ; - - open( HEADER, "> $dir_invoices/$invoice_00000/facture_message_header.txt") or die ; - print HEADER $message_header ; - close( HEADER ) ; - - open( BODY, "> $dir_invoices/$invoice_00000/facture_message_body.txt") or die ; - print BODY $message_body_utf8 ; - close( BODY ) ; - - open( ADDRESS, "> $dir_invoices/$invoice_00000/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_utf8 ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $debug and print "Writing imapsync_var.tex $dir_invoices/$invoice_00000/imapsync_var.tex\n" ; - $dry and return( ) ; - - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var.tex") or die ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - - if ( ! -f "$dir_invoices/$invoice_00000/imapsync_var_manual.tex" ) { - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var_manual.tex") or die ; - print FILE "%% $0 created this file -%% Can be used to override imapsync_var.tex definitions\n" ; - print FILE $tex_variables_utf8 ; - 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_rate { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - #return( 0 ) ; - return( 0.196 ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - #print "tva_rate 0.2\n" ; - return( 0.2 ) ; - } - #print "tva_rate 0\n" ; - return( 0 ) ; -} - -sub tests_tva_rate { - ok( 0.196 == tva_rate( '2013_01_01' ), 'tva_rate: old 0.196' ) ; - ok( 0.196 == tva_rate( '2013_12_31' ), 'tva_rate: old 0.196' ) ; - ok( 0.2 == tva_rate( '2014_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2014_12_31' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_12_31' ), 'tva_rate: new 0.2' ) ; - return( 0 ) ; -} - - -sub tva_rate_str { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - return( '19,60\%' ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - return( '20\%' ) ; - } - #print "tva_rate 0\n" ; - return( '' ) ; -} - -sub tests_tva_rate_str { - ok( '19,60\%' eq tva_rate_str( '2013_01_01' ), 'tva_rate_str: old 0.196' ) ; - ok( '19,60\%' eq tva_rate_str( '2013_12_31' ), 'tva_rate_str: old 0.196' ) ; - ok( '20,00\%' eq tva_rate_str( '2014_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20,00\%' eq tva_rate_str( '2014_12_31' ), 'tva_rate_str: new 0.2' ) ; - ok( '20,00\%' eq tva_rate_str( '2050_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20,00\%' eq tva_rate_str( '2050_12_31' ), 'tva_rate_str: new 0.2' ) ; - return( 0 ) ; -} - - - - -sub tva_line { - my( $Devise, $Montant2, $Pays, $Nom_Option_1, $Valeur_Option_1, $Titre_de_l_objet, $Date ) = @_ ; - my( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) = ( 0, 0, 0 ) ; - - my( $montant_HT_EUR_sup, $montant_TVA_EUR_sup, $montant_HT_EUR_sup_exo ) = ( 0, 0, 0 ) ; - - - my $date_aaaa_mm_jj = date_aaaa_mm_jj( $Date ) ; - - $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 + tva_rate( $date_aaaa_mm_jj ) ) ; - $montant_TVA_EUR = $Montant2 / ( 1 + tva_rate( $date_aaaa_mm_jj ) ) * tva_rate( $date_aaaa_mm_jj ) ; - $debug_dev and print "$Montant2 $Pays $Valeur_Option_1\n" ; - }else{ - $montant_HT_EUR_exo = $Montant2 ; - } - } - - if ( 'imapsync support' eq $Titre_de_l_objet ) { - if ( - ( 'imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) - or - ( 'France' eq $Pays ) - or - ( '2013_02_19' gt $date_aaaa_mm_jj ) - ) { - $montant_HT_EUR_sup = $Montant2 / ( 1 + tva_rate( $date_aaaa_mm_jj ) ) ; - $montant_TVA_EUR_sup = $Montant2 / ( 1 + tva_rate( $date_aaaa_mm_jj ) ) * tva_rate( $date_aaaa_mm_jj ) ; - }else{ - $montant_HT_EUR_sup_exo = $Montant2 ; - } - } - return( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR, - $montant_HT_EUR_sup, $montant_TVA_EUR_sup, $montant_HT_EUR_sup_exo ) ; -} - - - -sub tva_stuff { - my( $clientTypeEN, $Pays, $Hors_taxe, $Devise, $Titre_de_l_objet, $Date ) = @_ ; - - my $priceTTCusd = '' ; - $Hors_taxe =~ s{,}{.} ; - - my $date_aaaa_mm_jj = date_aaaa_mm_jj( $Date ) ; - - if ( $Devise eq 'USD' ) { - $priceTTCusd = "(usd $Hors_taxe)" ; - $Hors_taxe = ( $Hors_taxe/$usdeur ) ; - } - - my ( - $priceHT, - $tvaFR, - $tvaEN, - $priceTVA, - $priceTTC, - $messageTVAFR, - $messageTVAEN, - $HTorTTC - ) ; - - if ( ( 'individual' eq $clientTypeEN) - or - ( 'France' eq $Pays ) - ) { - $priceHT = sprintf('%2.2f', $Hors_taxe / ( 1 + tva_rate( $date_aaaa_mm_jj ) ) ) ; - $tvaFR = tva_rate_str( $date_aaaa_mm_jj ) ; - $tvaEN = '' ; - $priceTVA = sprintf('%2.2f', $Hors_taxe / ( 1 + tva_rate( $date_aaaa_mm_jj ) ) * tva_rate( $date_aaaa_mm_jj ) ) ; - $priceTTC = sprintf('%2.2f', $Hors_taxe) ; - $HTorTTC = 'TTC' ; - $messageTVAFR = '' ; - $messageTVAEN = '' ; - }else{ - $priceHT = sprintf('%2.2f', $Hors_taxe) ; - $tvaFR = '' ; - $tvaEN = '' ; - $priceTVA = 'néant (none)' ; - $priceTTC = $priceHT ; - $HTorTTC = 'HT' ; - $messageTVAFR = 'Exonération de TVA, articles 259 et 262 du Code Général des Impôts'; - $messageTVAEN = '(VAT tax-exempt, articles 259 and 262 of 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, - $HTorTTC - ) ; -} - -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_address { - 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+$/ ) ; - my( $Nom1, $Nom2 ) = cut( $Nom, 42 ) ; - push( @address, $Nom1 ) if $Nom1 ; - #push( @address, $Nom2 ) if $Nom2 ; - 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, - ) ; -} - - -sub cut { - my $string = shift ; - my $offset = shift ; - - return( $string, '' ) if length( $string ) < $offset ; - my $first = substr( $string, 0, $offset ) ; - my $last = substr( $string, $offset ) ; - return( $first, $last ) ; -} - -sub tests_cut { - my( $aa, $bb ) = cut("123456789", 4 ) ; - ok( '1234' eq $aa, 'cut 123456789 4 => first 1234' ) ; - ok( '56789' eq $bb, 'cut 123456789 4 => last 56789' ) ; -} diff --git a/W/paypal_reply/paypal_bilan_1.74 b/W/paypal_reply/paypal_bilan_1.74 deleted file mode 100755 index 6340cd9..0000000 --- a/W/paypal_reply/paypal_bilan_1.74 +++ /dev/null @@ -1,1448 +0,0 @@ -#!/usr/bin/perl - -# $Id: paypal_bilan,v 1.74 2014/05/01 21:56:47 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 $rcs = '$Id: paypal_bilan,v 1.74 2014/05/01 21:56:47 gilles Exp gilles $ ' ; -$rcs =~ m/,v (\d+\.\d+)/ ; -my $VERSION = ($1) ? $1: "UNKNOWN" ; - - -my $total_usd_received = 0 ; -my $total_usd_invoice = 0 ; -my $total_HT_EUR_logi_exo = 0 ; -my $total_HT_EUR_logi_ass = 0 ; -my $total_TVA_EUR_logi = 0 ; - -my $total_HT_EUR_sup = 0 ; -my $total_TVA_EUR_sup = 0 ; -my $total_HT_EUR_sup_exo = 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 $nb_invoice_canceled = 0 ; - -my ( $tests, $testeur ) ; -my $dry ; -my $debug ; -my $debug_csv ; -my $debug_dev ; -my $debug_invoice ; -my $debug_invoice_utf8 ; -my $debug_email; - -my $first_invoice = 1 ; -my $print_details = '' ; -my $bnc = '' ; -my $exportbnc = '' ; - -my $usdeur = 1.2981 ; -my $invoices ; -my %invoice_refund ; -my %invoice_canceled ; -my %invoice_suspended ; -my $write_invoices = 0 ; -my $avoid_numbers ; - -my $dir_invoices = '/g/var/paypal_invoices' ; - -my $option_ret = GetOptions ( - 'tests' => \$tests, - 'dry' => \$dry, - 'debug' => \$debug, - 'debug_csv' => \$debug_csv, - 'debug_dev' => \$debug_dev, - 'debug_invoice' => \$debug_invoice, - 'debug_invoice_utf8' => \$debug_invoice_utf8, - 'debug_email' => \$debug_email, - - 'first_invoice=i' => \$first_invoice, - 'print_details|details' => \$print_details, - 'bnc' => \$bnc, - 'exportbnc=s' => \$exportbnc, - '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_invoice ; - -my %invoice_paypal ; - -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" ; - -my @actions ; - -foreach my $file ( @files ) { - - my @actions_file = parse_file( $file ) ; - push( @actions, @actions_file ) ; -} - -foreach my $action (@actions) { - # compute_line() adds $action->{ 'invoice' } if needed - compute_line( $action ) ; - - # index by invoice number - $action_invoice{ $action->{ 'invoice' } } = $action ; -} -delete $action_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_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 }++ ; - build_invoice( $invoice ) if ( $debug_invoice or $debug_invoice_utf8 ) ; - }elsif( not ( $invoice_canceled{ $invoice } or $invoice_refund{ $invoice } ) ) { - $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 ) ; - -my @invoice_canceled = sort { $a <=> $b } keys( %invoice_canceled ) ; -my @invoice_suspended = sort { $a <=> $b } keys( %invoice_suspended ) ; -my @invoice_refund = sort { $a <=> $b } keys( %invoice_refund ) ; - - -print( "\n", "=" x 60, "\n" ) ; - -my $total_usd_paypal_cost ; -$total_usd_paypal_cost = sprintf('%2.2f', $total_usd_invoice - $total_usd_received ) ; -print "USD received $total_usd_received\n" ; -print "USD invoice $total_usd_invoice\n" ; -print "USD costs $total_usd_paypal_cost\n" ; - -my $total_eur_invoice_from_usd ; -my $total_eur_received_from_usd ; -my $total_eur_paypal_cost_from_usd ; - -# au 30 nov 2010 http://fr.finance.yahoo.com/devises/convertisseur/#from=EUR;to=USD;amt=1 -$total_eur_invoice_from_usd = sprintf('%2.2f', $total_usd_invoice / $usdeur ) ; -$total_eur_received_from_usd = sprintf('%2.2f', $total_usd_received / $usdeur ) ; -$total_eur_paypal_cost_from_usd = sprintf('%2.2f', $total_usd_paypal_cost / $usdeur ) ; - -# EUR -$total_eur_received = sprintf('%2.2f', $total_eur_received) ; -$total_eur_invoice = sprintf('%2.2f', $total_eur_invoice) ; -print "EUR invoice from USD $total_eur_invoice_from_usd\n" ; -print "EUR received from EUR $total_eur_received\n" ; -print "EUR invoice from EUR $total_eur_invoice\n" ; - -my $total_eur_invoice_from_eur_usd = $total_eur_invoice_from_usd + $total_eur_invoice ; -my $total_eur_received_from_eur_usd = $total_eur_received_from_usd + $total_eur_received ; -my $total_eur_paypal_cost = $total_eur_invoice - $total_eur_received + $total_eur_paypal_cost_from_usd ; - - -$total_HT_EUR_logi_exo = sprintf('%2.2f', $total_HT_EUR_logi_exo) ; -$total_HT_EUR_logi_ass = sprintf('%2.2f', $total_HT_EUR_logi_ass) ; -$total_TVA_EUR_logi = sprintf('%2.2f', $total_TVA_EUR_logi) ; - -$total_HT_EUR_sup = sprintf('%2.2f', $total_HT_EUR_sup) ; -$total_TVA_EUR_sup = sprintf('%2.2f', $total_TVA_EUR_sup) ; -$total_HT_EUR_sup_exo = sprintf('%2.2f', $total_HT_EUR_sup_exo) ; - -$total_eur_invoice_from_eur_usd = sprintf('%2.2f', $total_eur_invoice_from_eur_usd) ; -$total_eur_paypal_cost = sprintf('%2.2f', $total_eur_paypal_cost) ; - -print( "---- USD + EUR ----\n" ) ; -print "EUR total invoice $total_eur_invoice_from_eur_usd\n" ; -print "EUR total received $total_eur_received_from_eur_usd\n" ; -print "EUR total paypal cost $total_eur_paypal_cost\n" ; -print ; -print( "---- Assujeti TVA ----\n" ) ; -print "EUR total HT licen assuj $total_HT_EUR_logi_ass (autres operations imposables)\n" ; -#print "EUR total TVA licen assuj $total_TVA_EUR_logi\n" ; -print "EUR total HT supp assuj $total_HT_EUR_sup (ventes, prestations)\n" ; -#print "EUR total TVA supp assuj $total_TVA_EUR_sup\n" ; - -print( "---- Exonere TVA ----\n" ) ; -print "EUR total HT licen exo $total_HT_EUR_logi_exo (autres operations NON imposables)\n" ; -print "EUR total HT suppo exo $total_HT_EUR_sup_exo (autres operations NON imposables)\n" ; - -print( "---- Invoices ----\n" ) ; - -print "Nb invoice $nb_invoice ( from $first_invoice_paypal to $last_invoice )\n" ; -print "Nb invoice canceled ($nb_invoice_canceled) @invoice_canceled\n" ; -print "Nb invoice suspended ($nb_invoice_suspended) @invoice_suspended\n" ; -print "Nb invoice refund ($nb_invoice_refund) @invoice_refund\n" ; -print "Nb invoice sent $nb_invoice_sent\n" ; -print "Have to send invoices @invoice_not_sent\n" if ( @invoice_not_sent ) ; - -my $total_eur2 = $total_HT_EUR_logi_exo + $total_HT_EUR_logi_ass + $total_TVA_EUR_logi + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo ; -$total_eur2 = sprintf('%2.2f', $total_eur2) ; -print "$total_eur_invoice_from_eur_usd != $total_eur2 = $total_HT_EUR_logi_exo + $total_HT_EUR_logi_ass + $total_TVA_EUR_logi + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo\n" -if ( $total_eur_invoice_from_eur_usd != $total_eur2 ) ; - -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 invoice_00000 { - my $invoice = shift ; - - return( sprintf( "%04d", $invoice ) ) ; -} - -sub tests_invoice_00000 { - - ok( '0000' eq invoice_00000( 0 ), 'invoice_00000: 0 -> 0000' ) ; - ok( '0147' eq invoice_00000( 147 ), 'invoice_00000: 147 -> 0147' ) ; - ok( '99999' eq invoice_00000( 99999 ), 'invoice_00000: 99999 -> 99999' ) ; -} - -sub tests_next_invoice { - ok( 1 == next_invoice( ), 'next_invoice: 1' ) ; - ok( 2 == next_invoice( ), 'next_invoice: 2' ) ; - @avoid_numbers{ (3, 4, 6, 8 ) } = ( ) ; - ok( 5 == next_invoice( ), 'next_invoice: 7' ) ; - ok( 7 == next_invoice( ), 'next_invoice: 8' ) ; - ok( 9 == next_invoice( ), 'next_invoice: 9' ) ; - %invoice_paypal = () ; - $first_invoice = 7 ; - ok( 7 == next_invoice( ), 'next_invoice: 7' ) ; -} - - -sub tests_exportbnc { - ok( 1 == 1, '1 == 1' ) ; - -} - - - -sub tests { - tests_next_invoice( ) ; - tests_cut( ) ; - tests_invoice_00000( ) ; - #tests_exportbnc( ) ; - tests_tva_rate( ) ; - tests_tva_rate_str( ) ; - tests_software_price( ) ; -} - -sub compute_line_debug { - - my $A = shift ; - - return( "#" x 78, "\n", - "[$A->{Date}] [$A->{Heure}] [$A->{Fuseau_horaire}] [$A->{Nom}] [$A->{Type}] [$A->{Etat}] ", - "[$A->{Devise}] [$A->{Hors_taxe_paypal}] [$A->{Montant}] [$A->{Numero_davis_de_reception}] [$A->{Solde}] [$A->{Impact_sur_le_solde}] ", - "[$A->{Pays}] [$A->{Nom_Option_1}] [$A->{Valeur_Option_1}] [$A->{Titre_de_l_objet}]\n" ) ; - -} - -sub bnc_first_line { - my $A = shift ; - $A->{MontantEUR} = $A->{Montant} ; - $A->{MontantEUR} = sprintf( "%.4f", $A->{Montant}/$usdeur ) if ($A->{Devise} eq 'USD') ; - return( "\n", "=" x 60, "\n", - "[$A->{Date}] [$A->{Nom}] [$A->{Type}] [$A->{Etat}] [$A->{Devise}] ", - "[$A->{Hors_taxe_paypal}] [$A->{Montant}] [EUR $A->{MontantEUR}] [$A->{Impact_sur_le_solde}]\n", - "[$A->{Pays}] [$A->{Nom_Option_1}] [$A->{Valeur_Option_1}] [$A->{Titre_de_l_objet}]\n" ) ; -} - -sub details { - - my $A = shift ; - - return( "[$A->{invoice}] [$A->{Date}] [$A->{Heure}] [$A->{Fuseau_horaire}] ", - "[$A->{Nom}] [$A->{Type}] [$A->{Etat}] [$A->{Devise}] [$A->{Montant}] ", - "[$A->{Numero_davis_de_reception}] [$A->{Solde}] [$A->{Impact_sur_le_solde}]\n" ) ; - -} - -sub paiement_usd_termine{ - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'USD' eq $A->{Devise} - and ( 'Terminé' eq $A->{Etat} or 'Compensé' eq $A->{Etat} ) - ) { - $A->{Montant} =~tr/,/./; - $A->{Montant2} = $A->{Hors_taxe_paypal} ; - $total_usd_received += $A->{Montant} ; - $total_usd_invoice += $A->{Montant2} ; - tva_line( $A ) ; - $total_HT_EUR_logi_exo += $A->{montant_HT_EUR_logi_exo} ; - $total_HT_EUR_logi_ass += $A->{montant_HT_EUR_logi_ass} ; - $total_TVA_EUR_logi += $A->{montant_TVA_EUR_logi} ; - - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_termine { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and ( 'Terminé' eq $A->{Etat} or 'Compensé' eq $A->{Etat} ) - ) { - $A->{Montant} =~tr/,/./; - $A->{Montant2} = $A->{Hors_taxe_paypal} ; - $total_eur_received += $A->{Montant} ; - $total_eur_invoice += $A->{Montant2} ; - tva_line( $A ) ; - $total_HT_EUR_logi_exo += $A->{montant_HT_EUR_logi_exo} ; - $total_HT_EUR_logi_ass += $A->{montant_HT_EUR_logi_ass} ; - $total_TVA_EUR_logi += $A->{montant_TVA_EUR_logi} ; - $total_HT_EUR_sup += $A->{montant_HT_EUR_sup} ; - $total_TVA_EUR_sup += $A->{montant_TVA_EUR_sup} ; - $total_HT_EUR_sup_exo += $A->{montant_HT_EUR_sup_exo} ; - - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_rembourse { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Remboursé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_refund++; - $invoice_refund{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_annule { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Annulé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_canceled++; - $invoice_canceled{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_suspendu { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Suspendu' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_suspended++; - $invoice_suspended{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_non_compense { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Non compensé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - - - -sub compute_line { - - my $action = shift ; - my %action = %$action ; - my $A ; - - @{$A}{ qw( - 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 Nom_Option_2 Option_2_Valeur - Impact_sur_le_solde - ) } - = @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", 'Nom Option 2', 'Option 2 Valeur', - 'Impact sur le solde') } ; - - ( $A->{Etat} ) = @action{ ( 'Etat' ) } || @action{ ( 'État' ) } ; - ( $A->{Hors_taxe_paypal} ) = @action{ ( 'Hors taxe' ) } || @action{ ( 'Avant commission' ) } ; - $A->{Impact_sur_le_solde} ||= '' ; - $A->{invoice} = 'NONE' ; - $A->{Montant} = $action->{ 'Net' } if not defined $A->{Montant}; - - $debug and print( compute_line_debug( $A ) ) ; - - $A->{Montant} =~ s/[^0-9-,.]//g ; - $A->{Montant} =~ s/,/./g ; - $A->{Hors_taxe_paypal} =~ s/,/./g ; - - $bnc and print( bnc_first_line( $A ) ) ; - paiement_usd_termine( $A ) ; - paiement_eur_termine( $A ) ; - paiement_eur_rembourse( $A ) ; - paiement_eur_annule( $A ) ; - paiement_eur_suspendu( $A ) ; - paiement_eur_non_compense( $A ) ; - $bnc and print( BNC_output( $A->{invoice}, FR_flag( $A->{Pays} ), - IND_flag( $A->{Nom_Option_1}, $A->{Valeur_Option_1} ), - SUPPORT_flag( $A->{Titre_de_l_objet} ), - $A->{Nom}, $A->{Date}, $A->{MontantEUR}, $A->{Devise}, - $A->{Titre_de_l_objet}, $A->{Impact_sur_le_solde}, $A->{Type} ) ) ; - - $action->{ 'invoice' } = $A->{invoice} ; -} - -sub BNC_output { -# FE 1359 FR IND imapsync Bougon Edouard -# [12/01/2012] FR IND 28.73 EUR - my( $invoice, $FR_flag, $IND_flag, $SUPPORT_flag, - $Nom, $Date, $MontantEUR, $Devise, $Titre_de_l_objet, $Impact_sur_le_solde, $Type ) = @_ ; - - my $BNC_output ; - - if ( 'NONE' eq $invoice ) { - $BNC_output = "[$Date] $MontantEUR $Devise $Nom $Titre_de_l_objet [$Impact_sur_le_solde] [$Type]\n" ; - }else{ - $BNC_output = - "FE $invoice$FR_flag$IND_flag imapsync$SUPPORT_flag $Nom\n" - . "[$Date]$FR_flag$IND_flag $MontantEUR $Devise \n" ; - } - return( $BNC_output ) ; -} - -sub SUPPORT_flag { - my $Titre_de_l_objet = shift ; - my $SUPPORT_flag = '' ; - $SUPPORT_flag = ' support' if ( 'imapsync support' eq $Titre_de_l_objet ) ; -} - -sub IND_flag { - my( $Nom_Option_1, $Valeur_Option_1 ) = @_ ; - my $IND_flag = '' ; - $IND_flag = ' IND' if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) ; - return( $IND_flag ) ; -} - -sub FR_flag { - my $Pays = shift ; - my $FR_flag = '' ; - - $FR_flag = ' FR' if $Pays eq 'France' ; - return( $FR_flag ) ; -} - -sub build_invoice { - my $invoice = shift ; - - return if ! $invoice ; - - my $F ; - $F->{invoice} = $invoice ; - - my $action = $action_invoice{ $F->{invoice} } ; - #print Data::Dumper->Dump( [$action] ) ; - - @{$F}{ qw( 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 - Nom_Option_2 Option_2_Valeur ) } - = @{$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', - 'Nom Option 2', 'Option 2 Valeur' ) } ; - - $F->{Etat_Province} = $action->{'Etat/Province/Région/Comté/Territoire/Préfecture/République'} - || $action->{'État/Province/Région/Comté/Territoire/Préfecture/République'} - || '' ; - $F->{Hors_taxe} = $action->{'Hors taxe'} || $action->{'Avant commission'} ; - $F->{Hors_taxe_num} = $F->{Hors_taxe} ; - $F->{Hors_taxe_num} =~ s{,}{.} ; - if ($F->{Hors_taxe_num} > 100) { - print "invoice $F->{invoice} $F->{Hors_taxe_num} > 100\n" ; - #return() ; - } - - my ( $email_message_header, $email_message_body ) = - build_email_message( $F->{Date}, $F->{Nom}, $F->{De_l_adresse_email}, $F->{invoice}, $F->{Titre_de_l_objet} ) ; - $debug_email and print( "\n", $email_message_header, $email_message_body ) ; - if ( $write_invoices and ! invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ) ) { - write_email_message( $dir_invoices, $F->{invoice}, - $email_message_header, $email_message_body, - $F->{De_l_adresse_email} ) ; - write_csv_info( $dir_invoices, $F->{invoice}, $F->{file_csv}, $F->{line_number}, $F->{line_csv} ) ; - } - - - my( - $clientAdrA, - $clientAdrB, - $clientAdrC, - $clientAdrD, - $clientAdrE, - $clientAdrF, - ) - = build_address( - $F->{Nom}, - $F->{Adresse_1}, - $F->{Adresse_2_district_quartier}, - $F->{Ville}, - $F->{Code_postal}, - $F->{Etat_Province}, - $F->{Pays}, - ) ; - - foreach my $str ( - $F->{De_l_adresse_email}, - $F->{Nom}, - $clientAdrA, - $clientAdrB, - $clientAdrC, - $clientAdrD, - $clientAdrE, - $clientAdrF, - ) { - $str =~ s{#}{\\#}g ; - $str =~ s{_}{\\_}g ; - $str =~ s{&}{\\&}g ; - } - - my ( $clientTypeEN, $clientTypeFR ) = client_type( $F->{Nom_Option_1}, $F->{Valeur_Option_1} ) ; - - my $quantity = '1' ; - - my ( - $descriptionFR, - $descriptionEN, - $usageFR, - $usageEN, - ) - = description_stuff( $F->{Titre_de_l_objet}, $clientTypeEN ) ; - - my ( - $priceHT, - $tvaFR, - $tvaEN, - $priceTVA, - $priceTTC, - $messageTVAFR, - $messageTVAEN, - $priceTTCusd, - $HTorTTC - ) - = tva_stuff( $clientTypeEN, $F->{Pays}, $F->{Hors_taxe}, $F->{Devise}, $F->{Titre_de_l_objet}, $F->{Date} ) ; - - my $object_type = object_type( $F->{Titre_de_l_objet} ) ; - - my ( $urlSrc, $urlExe ) = download_urls( $F->{Date}, $object_type ) ; - #print "ZZZ $object_type ( $urlSrc, $urlExe )\n" ; - - my ( $Nom1 ) = cut( $F->{Nom}, 42 ) ; - - my $clientVAT = '' ; - - if ( ( 'VAT if professional in Europe' eq $F->{Nom_Option_2} ) and $F->{Option_2_Valeur} ) { - $clientVAT = $F->{Option_2_Valeur} ; - } - - my $tex_variables = qq{ -%% Begin input from paypal_bilan $VERSION -\\providecommand{\\invoiceNumber}{$F->{invoice}} -\\providecommand{\\clientName}{$Nom1} -\\providecommand{\\clientEmail}{$F->{De_l_adresse_email}} -\\providecommand{\\clientAdrA}{$clientAdrA} -\\providecommand{\\clientAdrB}{$clientAdrB} -\\providecommand{\\clientAdrC}{$clientAdrC} -\\providecommand{\\clientAdrD}{$clientAdrD} -\\providecommand{\\clientAdrE}{$clientAdrE} -\\providecommand{\\clientAdrF}{$clientAdrF} -\\providecommand{\\clientVAT}{$clientVAT} -\\providecommand{\\invoiceDate}{$F->{Date}} -\\providecommand{\\invoiceHour}{$F->{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{\\HTorTTC}{$HTorTTC} -\\providecommand{\\priceTTC}{$priceTTC} -\\providecommand{\\priceTTCusd}{$priceTTCusd} -\\providecommand{\\messageTVAFR}{$messageTVAFR} -\\providecommand{\\messageTVAEN}{$messageTVAEN} -\\providecommand{\\urlSrc}{\\url{$urlSrc}} -\\providecommand{\\urlExe}{\\url{$urlExe}} -%% End input from paypal_bilan -} ; - - my $tex_variables_utf8 = to_utf8( { -string => $tex_variables, -charset => 'ISO-8859-1' } ) ; - - $debug_invoice_utf8 and print $tex_variables_utf8 ; - $debug_invoice and print $tex_variables ; - - #print "$F->{invoice} ", invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ), "\n" ; - if ( $write_invoices and ! invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ) ) { - write_tex_variables_file( $dir_invoices, $F->{invoice}, $F->{Date}, $tex_variables_utf8 ) ; - } - -} - -sub description_stuff { - my ( $object, $clientTypeEN ) = @_ ; - - my $object_type = object_type( $object ) ; - - my $descriptionFR = my $descriptionEN = '' ; - if ( 'software' eq $object_type ) { - $descriptionFR = 'Logiciel imapsync. TOUS droits cédés, autorisés.' ; - $descriptionEN = '(Imapsync software. ALL rights conceded, allowed.)' ; - } - - my $usageFR = my $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. - -Last imapsync release is available from the page -http://imapsync.lamiral.info/paypal_return.shtml - -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. - -Last imapsync release is available from the page -http://imapsync.lamiral.info/paypal_return.shtml - -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 = my $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 ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - $debug and print "Writing $dir_invoices/$invoice_00000/csv_info.txt\n" ; - $dry and return( ) ; - - open( CSVINFO, "> $dir_invoices/$invoice_00000/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 ) = @_ ; - my $invoice_00000 = invoice_00000( $invoice ) ; - return( 1 ) if ( -f "$dir_invoices/$invoice_00000/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' }); - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $dry and return( ) ; - - open( HEADER, "> $dir_invoices/$invoice_00000/facture_message_header.txt") or die ; - print HEADER $message_header ; - close( HEADER ) ; - - open( BODY, "> $dir_invoices/$invoice_00000/facture_message_body.txt") or die ; - print BODY $message_body_utf8 ; - close( BODY ) ; - - open( ADDRESS, "> $dir_invoices/$invoice_00000/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_utf8 ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $debug and print "Writing imapsync_var.tex $dir_invoices/$invoice_00000/imapsync_var.tex\n" ; - $dry and return( ) ; - - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var.tex") or die ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - - if ( ! -f "$dir_invoices/$invoice_00000/imapsync_var_manual.tex" ) { - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var_manual.tex") or die ; - print FILE "%% $0 created this file -%% Can be used to override imapsync_var.tex definitions\n" ; - print FILE $tex_variables_utf8 ; - 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_rate { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - #return( 0 ) ; - return( 0.196 ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - #print "tva_rate 0.2\n" ; - return( 0.2 ) ; - } - #print "tva_rate 0\n" ; - return( 0 ) ; -} - -sub tests_tva_rate { - ok( 0.196 == tva_rate( '2013_01_01' ), 'tva_rate: old 0.196' ) ; - ok( 0.196 == tva_rate( '2013_12_31' ), 'tva_rate: old 0.196' ) ; - ok( 0.2 == tva_rate( '2014_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2014_12_31' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_12_31' ), 'tva_rate: new 0.2' ) ; - return( 0 ) ; -} - - -sub tva_rate_str { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - return( '19,60\%' ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - return( '20\%' ) ; - } - #print "tva_rate 0\n" ; - return( '' ) ; -} - -sub tests_tva_rate_str { - ok( '19,60\%' eq tva_rate_str( '2013_01_01' ), 'tva_rate_str: old 0.196' ) ; - ok( '19,60\%' eq tva_rate_str( '2013_12_31' ), 'tva_rate_str: old 0.196' ) ; - ok( '20\%' eq tva_rate_str( '2014_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2014_12_31' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2050_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2050_12_31' ), 'tva_rate_str: new 0.2' ) ; - return( 0 ) ; -} - - -sub tva_line_one_button_for_the_software { - - my $A = shift ; - - if ( 'imapsync' eq $A->{Titre_de_l_objet} - or 'imapsync.exe' eq $A->{Titre_de_l_objet} - or 'imapsync source' eq $A->{Titre_de_l_objet} - or 'imapsync source code' eq $A->{Titre_de_l_objet} - - ) { - if ( - ( 'imapsync usage' eq $A->{Nom_Option_1} and 'individual' eq $A->{Valeur_Option_1} ) - or - ( 'France' eq $A->{Pays} ) - ) { - $A->{montant_HT_EUR_logi_ass} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_logi} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_logi_exo} = $A->{Montant2} ; - } - } - -} - -sub tva_line_one_button_for_the_support { - - my $A = shift ; - - if ( 'imapsync support' eq $A->{Titre_de_l_objet} ) { - if ( - ( 'imapsync usage' eq $A->{Nom_Option_1} and 'individual' eq $A->{Valeur_Option_1} ) - or - ( 'France' eq $A->{Pays} ) - or - ( '2013_02_19' gt $A->{date_aaaa_mm_jj} ) - ) - { - $A->{montant_HT_EUR_sup} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_sup} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_sup_exo} = $A->{Montant2} ; - } - } -} - - -sub software_price { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - return( 50 ) ; - } - return( 0 ) ; -} - - -sub tests_software_price { - ok( 50 == software_price( '2014_01_01' ), 'software_price: 2014_01_01 => 50 ' ) ; - ok( 0 == software_price( '2000_01_01' ), 'software_price: 2000_01_01 => 0' ) ; - return( 0 ) ; -} - - -sub tva_line_one_button_for_support_and_software_case_no_vat_number { - - my $A = shift ; - - $A->{Montant2_logi} = software_price( $A->{date_aaaa_mm_jj} ) ; - $A->{Montant2_supp} = $A->{Montant2} - $A->{Montant2_logi} ; - - if ( 'imapsync all' eq $A->{Titre_de_l_objet} ) { - if ( - ( 'usage' eq $A->{Nom_Option_2} and 'individual' eq $A->{Option_2_Valeur} ) - or - ( 'France' eq $A->{Pays} ) - ) - { - $A->{montant_HT_EUR_sup} = $A->{Montant2_supp} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_sup} = $A->{Montant2_supp} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - $A->{montant_HT_EUR_logi_ass} = $A->{Montant2_logi} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_logi} = $A->{Montant2_logi} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_logi_exo} = $A->{Montant2_logi} ; - $A->{montant_HT_EUR_sup_exo} = $A->{Montant2_supp} ; - } - } -} - - -sub tva_line { - - my $A = shift ; - - $A->{montant_HT_EUR_logi_exo} = $A->{montant_HT_EUR_logi_ass} = $A->{montant_TVA_EUR_logi} = 0 ; - $A->{montant_HT_EUR_sup} = $A->{montant_TVA_EUR_sup} = $A->{montant_HT_EUR_sup_exo} = 0 ; - - $A->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $A->{Date} ) ; - $A->{Montant2} = $A->{Montant2}/$usdeur if 'USD' eq $A->{Devise} ; - - tva_line_one_button_for_the_software( $A ) ; - tva_line_one_button_for_the_support( $A ) ; - tva_line_one_button_for_support_and_software_case_no_vat_number( $A ) ; - return( ) ; -} - - - -sub tva_stuff { - my( $clientTypeEN, $Pays, $Hors_taxe, $Devise, $Titre_de_l_objet, $Date ) = @_ ; - - my $priceTTCusd = '' ; - $Hors_taxe =~ s{,}{.} ; - - my $date_aaaa_mm_jj = date_aaaa_mm_jj( $Date ) ; - - if ( $Devise eq 'USD' ) { - $priceTTCusd = "(usd $Hors_taxe)" ; - $Hors_taxe = ( $Hors_taxe/$usdeur ) ; - } - - my ( - $priceHT, - $tvaFR, - $tvaEN, - $priceTVA, - $priceTTC, - $messageTVAFR, - $messageTVAEN, - $HTorTTC - ) ; - - if ( ( 'individual' eq $clientTypeEN) - or - ( 'France' eq $Pays ) - ) { - $priceHT = sprintf('%2.2f', $Hors_taxe / ( 1 + tva_rate( $date_aaaa_mm_jj ) ) ) ; - $tvaFR = tva_rate_str( $date_aaaa_mm_jj ) ; - $tvaEN = '' ; - $priceTVA = sprintf('%2.2f', $Hors_taxe / ( 1 + tva_rate( $date_aaaa_mm_jj ) ) * tva_rate( $date_aaaa_mm_jj ) ) ; - $priceTTC = sprintf('%2.2f', $Hors_taxe) ; - $HTorTTC = 'TTC' ; - $messageTVAFR = '' ; - $messageTVAEN = '' ; - }else{ - $priceHT = sprintf('%2.2f', $Hors_taxe) ; - $tvaFR = '' ; - $tvaEN = '' ; - $priceTVA = 'néant (none)' ; - $priceTTC = $priceHT ; - $HTorTTC = 'HT' ; - $messageTVAFR = 'Exonération de TVA, articles 259 et 262 du Code Général des Impôts'; - $messageTVAEN = '(VAT tax-exempt, articles 259 and 262 of 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, - $HTorTTC - ) ; -} - -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_address { - 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+$/ ) ; - my( $Nom1, $Nom2 ) = cut( $Nom, 42 ) ; - push( @address, $Nom1 ) if $Nom1 ; - #push( @address, $Nom2 ) if $Nom2 ; - 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, - ) ; -} - - -sub cut { - my $string = shift ; - my $offset = shift ; - - return( $string, '' ) if length( $string ) < $offset ; - my $first = substr( $string, 0, $offset ) ; - my $last = substr( $string, $offset ) ; - return( $first, $last ) ; -} - -sub tests_cut { - my( $aa, $bb ) = cut("123456789", 4 ) ; - ok( '1234' eq $aa, 'cut 123456789 4 => first 1234' ) ; - ok( '56789' eq $bb, 'cut 123456789 4 => last 56789' ) ; -} diff --git a/W/paypal_reply/paypal_bilan_1.75 b/W/paypal_reply/paypal_bilan_1.75 deleted file mode 100755 index 6a1774f..0000000 --- a/W/paypal_reply/paypal_bilan_1.75 +++ /dev/null @@ -1,1372 +0,0 @@ -#!/usr/bin/perl - -# $Id: paypal_bilan,v 1.75 2014/05/02 02:05:28 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 $rcs = '$Id: paypal_bilan,v 1.75 2014/05/02 02:05:28 gilles Exp gilles $ ' ; -$rcs =~ m/,v (\d+\.\d+)/ ; -my $VERSION = ($1) ? $1: "UNKNOWN" ; - - -my $total_usd_received = 0 ; -my $total_usd_invoice = 0 ; -my $total_HT_EUR_logi_exo = 0 ; -my $total_HT_EUR_logi_ass = 0 ; -my $total_TVA_EUR_logi = 0 ; - -my $total_HT_EUR_sup = 0 ; -my $total_TVA_EUR_sup = 0 ; -my $total_HT_EUR_sup_exo = 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 $nb_invoice_canceled = 0 ; - -my ( $tests, $testeur ) ; -my $dry ; -my $debug ; -my $debug_csv ; -my $debug_dev ; -my $debug_invoice ; -my $debug_invoice_utf8 ; -my $debug_email; - -my $first_invoice = 1 ; -my $print_details = '' ; -my $bnc = '' ; -my $exportbnc = '' ; - -my $usdeur = 1.2981 ; -my $invoices ; -my %invoice_refund ; -my %invoice_canceled ; -my %invoice_suspended ; -my $write_invoices = 0 ; -my $avoid_numbers ; - -my $dir_invoices ; - -my $option_ret = GetOptions ( - 'tests' => \$tests, - 'dry' => \$dry, - 'debug' => \$debug, - 'debug_csv' => \$debug_csv, - 'debug_dev' => \$debug_dev, - 'debug_invoice' => \$debug_invoice, - 'debug_invoice_utf8' => \$debug_invoice_utf8, - 'debug_email' => \$debug_email, - - 'first_invoice=i' => \$first_invoice, - 'print_details|details' => \$print_details, - 'bnc' => \$bnc, - 'exportbnc=s' => \$exportbnc, - 'usdeur=f' => \$usdeur, - 'invoices=s' => \$invoices, - 'write_invoices!' => \$write_invoices, - 'dir_invoices=s' => \$dir_invoices, - 'avoid_numbers=s' => \$avoid_numbers, -); - -$dir_invoices ||= '/g/var/paypal_invoices' ; - -$debug and print "dir_invoices = $dir_invoices\n" ; - -$testeur = Test::More->builder ; -$testeur->no_ending(1) ; - -if ( $tests ) { - $testeur->no_ending( 0 ) ; - exit( tests( ) ) ; -} - - -my @files = @ARGV ; -my %action_invoice ; - -my %invoice_paypal ; - -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" ; - -my @actions ; - -foreach my $file ( @files ) { - - my @actions_file = parse_file( $file ) ; - push( @actions, @actions_file ) ; -} - -foreach my $action (@actions) { - # compute_line() adds $action->{ 'invoice' } if needed - compute_line( $action ) ; - - # index by invoice number - $action_invoice{ $action->{ 'invoice' } } = $action ; -} -delete $action_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_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 }++ ; - build_invoice( $invoice ) if ( $debug_invoice or $debug_invoice_utf8 ) ; - }elsif( not ( $invoice_canceled{ $invoice } or $invoice_refund{ $invoice } ) ) { - $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 ) ; - -my @invoice_canceled = sort { $a <=> $b } keys( %invoice_canceled ) ; -my @invoice_suspended = sort { $a <=> $b } keys( %invoice_suspended ) ; -my @invoice_refund = sort { $a <=> $b } keys( %invoice_refund ) ; - - -print( "\n", "=" x 60, "\n" ) ; - -my $total_usd_paypal_cost ; -$total_usd_paypal_cost = sprintf('%2.2f', $total_usd_invoice - $total_usd_received ) ; -print "USD received $total_usd_received\n" ; -print "USD invoice $total_usd_invoice\n" ; -print "USD costs $total_usd_paypal_cost\n" ; - -my $total_eur_invoice_from_usd ; -my $total_eur_received_from_usd ; -my $total_eur_paypal_cost_from_usd ; - -# au 30 nov 2010 http://fr.finance.yahoo.com/devises/convertisseur/#from=EUR;to=USD;amt=1 -$total_eur_invoice_from_usd = sprintf('%2.2f', $total_usd_invoice / $usdeur ) ; -$total_eur_received_from_usd = sprintf('%2.2f', $total_usd_received / $usdeur ) ; -$total_eur_paypal_cost_from_usd = sprintf('%2.2f', $total_usd_paypal_cost / $usdeur ) ; - -# EUR -$total_eur_received = sprintf('%2.2f', $total_eur_received) ; -$total_eur_invoice = sprintf('%2.2f', $total_eur_invoice) ; -print "EUR invoice from USD $total_eur_invoice_from_usd\n" ; -print "EUR received from EUR $total_eur_received\n" ; -print "EUR invoice from EUR $total_eur_invoice\n" ; - -my $total_eur_invoice_from_eur_usd = $total_eur_invoice_from_usd + $total_eur_invoice ; -my $total_eur_received_from_eur_usd = $total_eur_received_from_usd + $total_eur_received ; -my $total_eur_paypal_cost = $total_eur_invoice - $total_eur_received + $total_eur_paypal_cost_from_usd ; - - -$total_HT_EUR_logi_exo = sprintf('%2.2f', $total_HT_EUR_logi_exo) ; -$total_HT_EUR_logi_ass = sprintf('%2.2f', $total_HT_EUR_logi_ass) ; -$total_TVA_EUR_logi = sprintf('%2.2f', $total_TVA_EUR_logi) ; - -$total_HT_EUR_sup = sprintf('%2.2f', $total_HT_EUR_sup) ; -$total_TVA_EUR_sup = sprintf('%2.2f', $total_TVA_EUR_sup) ; -$total_HT_EUR_sup_exo = sprintf('%2.2f', $total_HT_EUR_sup_exo) ; - -$total_eur_invoice_from_eur_usd = sprintf('%2.2f', $total_eur_invoice_from_eur_usd) ; -$total_eur_paypal_cost = sprintf('%2.2f', $total_eur_paypal_cost) ; - -print( "---- USD + EUR ----\n" ) ; -print "EUR total invoice $total_eur_invoice_from_eur_usd\n" ; -print "EUR total received $total_eur_received_from_eur_usd\n" ; -print "EUR total paypal cost $total_eur_paypal_cost\n" ; -print ; -print( "---- Assujeti TVA ----\n" ) ; -print "EUR total HT licen assuj $total_HT_EUR_logi_ass (autres operations imposables)\n" ; -#print "EUR total TVA licen assuj $total_TVA_EUR_logi\n" ; -print "EUR total HT supp assuj $total_HT_EUR_sup (ventes, prestations)\n" ; -#print "EUR total TVA supp assuj $total_TVA_EUR_sup\n" ; - -print( "---- Exonere TVA ----\n" ) ; -print "EUR total HT licen exo $total_HT_EUR_logi_exo (autres operations NON imposables)\n" ; -print "EUR total HT suppo exo $total_HT_EUR_sup_exo (autres operations NON imposables)\n" ; - -print( "---- Invoices ----\n" ) ; - -print "Nb invoice $nb_invoice ( from $first_invoice_paypal to $last_invoice )\n" ; -print "Nb invoice canceled ($nb_invoice_canceled) @invoice_canceled\n" ; -print "Nb invoice suspended ($nb_invoice_suspended) @invoice_suspended\n" ; -print "Nb invoice refund ($nb_invoice_refund) @invoice_refund\n" ; -print "Nb invoice sent $nb_invoice_sent\n" ; -print "Have to send invoices @invoice_not_sent\n" if ( @invoice_not_sent ) ; - -my $total_eur2 = $total_HT_EUR_logi_exo + $total_HT_EUR_logi_ass + $total_TVA_EUR_logi + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo ; -$total_eur2 = sprintf('%2.2f', $total_eur2) ; -print "$total_eur_invoice_from_eur_usd != $total_eur2 = $total_HT_EUR_logi_exo + $total_HT_EUR_logi_ass + $total_TVA_EUR_logi + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo\n" -if ( $total_eur_invoice_from_eur_usd != $total_eur2 ) ; - -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 invoice_00000 { - my $invoice = shift ; - - return( sprintf( "%04d", $invoice ) ) ; -} - -sub tests_invoice_00000 { - - ok( '0000' eq invoice_00000( 0 ), 'invoice_00000: 0 -> 0000' ) ; - ok( '0147' eq invoice_00000( 147 ), 'invoice_00000: 147 -> 0147' ) ; - ok( '99999' eq invoice_00000( 99999 ), 'invoice_00000: 99999 -> 99999' ) ; -} - -sub tests_next_invoice { - ok( 1 == next_invoice( ), 'next_invoice: 1' ) ; - ok( 2 == next_invoice( ), 'next_invoice: 2' ) ; - @avoid_numbers{ (3, 4, 6, 8 ) } = ( ) ; - ok( 5 == next_invoice( ), 'next_invoice: 7' ) ; - ok( 7 == next_invoice( ), 'next_invoice: 8' ) ; - ok( 9 == next_invoice( ), 'next_invoice: 9' ) ; - %invoice_paypal = () ; - $first_invoice = 7 ; - ok( 7 == next_invoice( ), 'next_invoice: 7' ) ; -} - - -sub tests_exportbnc { - ok( 1 == 1, '1 == 1' ) ; - -} - - - -sub tests { - tests_next_invoice( ) ; - tests_cut( ) ; - tests_invoice_00000( ) ; - #tests_exportbnc( ) ; - tests_tva_rate( ) ; - tests_tva_rate_str( ) ; - tests_software_price( ) ; -} - -sub compute_line_debug { - - my $A = shift ; - - return( "#" x 78, "\n", - "[$A->{Date}] [$A->{Heure}] [$A->{Fuseau_horaire}] [$A->{Nom}] [$A->{Type}] [$A->{Etat}] ", - "[$A->{Devise}] [$A->{Hors_taxe_paypal}] [$A->{Montant}] [$A->{Numero_davis_de_reception}] [$A->{Solde}] [$A->{Impact_sur_le_solde}] ", - "[$A->{Pays}] [$A->{Nom_Option_1}] [$A->{Valeur_Option_1}] [$A->{Titre_de_l_objet}]\n" ) ; - -} - -sub bnc_first_line { - my $A = shift ; - $A->{MontantEUR} = $A->{Montant} ; - $A->{MontantEUR} = sprintf( "%.4f", $A->{Montant}/$usdeur ) if ($A->{Devise} eq 'USD') ; - return( "\n", "=" x 60, "\n", - "[$A->{Date}] [$A->{Nom}] [$A->{Type}] [$A->{Etat}] [$A->{Devise}] ", - "[$A->{Hors_taxe_paypal}] [$A->{Montant}] [EUR $A->{MontantEUR}] [$A->{Impact_sur_le_solde}]\n", - "[$A->{Pays}] [$A->{Nom_Option_1}] [$A->{Valeur_Option_1}] [$A->{Titre_de_l_objet}]\n" ) ; -} - -sub details { - - my $A = shift ; - - return( "[$A->{invoice}] [$A->{Date}] [$A->{Heure}] [$A->{Fuseau_horaire}] ", - "[$A->{Nom}] [$A->{Type}] [$A->{Etat}] [$A->{Devise}] [$A->{Montant}] ", - "[$A->{Numero_davis_de_reception}] [$A->{Solde}] [$A->{Impact_sur_le_solde}]\n" ) ; - -} - -sub paiement_usd_termine{ - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'USD' eq $A->{Devise} - and ( 'Terminé' eq $A->{Etat} or 'Compensé' eq $A->{Etat} ) - ) { - $A->{Montant} =~tr/,/./; - $A->{Montant2} = $A->{Hors_taxe_paypal} ; - $total_usd_received += $A->{Montant} ; - $total_usd_invoice += $A->{Montant2} ; - tva_line( $A ) ; - $total_HT_EUR_logi_exo += $A->{montant_HT_EUR_logi_exo} ; - $total_HT_EUR_logi_ass += $A->{montant_HT_EUR_logi_ass} ; - $total_TVA_EUR_logi += $A->{montant_TVA_EUR_logi} ; - - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_termine { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and ( 'Terminé' eq $A->{Etat} or 'Compensé' eq $A->{Etat} ) - ) { - $A->{Montant} =~tr/,/./; - $A->{Montant2} = $A->{Hors_taxe_paypal} ; - $total_eur_received += $A->{Montant} ; - $total_eur_invoice += $A->{Montant2} ; - tva_line( $A ) ; - $total_HT_EUR_logi_exo += $A->{montant_HT_EUR_logi_exo} ; - $total_HT_EUR_logi_ass += $A->{montant_HT_EUR_logi_ass} ; - $total_TVA_EUR_logi += $A->{montant_TVA_EUR_logi} ; - $total_HT_EUR_sup += $A->{montant_HT_EUR_sup} ; - $total_TVA_EUR_sup += $A->{montant_TVA_EUR_sup} ; - $total_HT_EUR_sup_exo += $A->{montant_HT_EUR_sup_exo} ; - - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_rembourse { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Remboursé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_refund++; - $invoice_refund{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_annule { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Annulé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_canceled++; - $invoice_canceled{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_suspendu { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Suspendu' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_suspended++; - $invoice_suspended{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_non_compense { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Non compensé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - - - -sub compute_line { - - my $action = shift ; - my %action = %$action ; - my $A ; - - @{$A}{ qw( - 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 Nom_Option_2 Option_2_Valeur - Impact_sur_le_solde - ) } - = @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", 'Nom Option 2', 'Option 2 Valeur', - 'Impact sur le solde') } ; - - ( $A->{Etat} ) = @action{ ( 'Etat' ) } || @action{ ( 'État' ) } ; - ( $A->{Hors_taxe_paypal} ) = @action{ ( 'Hors taxe' ) } || @action{ ( 'Avant commission' ) } ; - $A->{Impact_sur_le_solde} ||= '' ; - $A->{invoice} = 'NONE' ; - $A->{Montant} = $action->{ 'Net' } if not defined $A->{Montant}; - - $debug and print( compute_line_debug( $A ) ) ; - - $A->{Montant} =~ s/[^0-9-,.]//g ; - $A->{Montant} =~ s/,/./g ; - $A->{Hors_taxe_paypal} =~ s/,/./g ; - - $bnc and print( bnc_first_line( $A ) ) ; - paiement_usd_termine( $A ) ; - paiement_eur_termine( $A ) ; - paiement_eur_rembourse( $A ) ; - paiement_eur_annule( $A ) ; - paiement_eur_suspendu( $A ) ; - paiement_eur_non_compense( $A ) ; - $bnc and print( BNC_output( $A->{invoice}, FR_flag( $A->{Pays} ), - IND_flag( $A->{Nom_Option_1}, $A->{Valeur_Option_1} ), - SUPPORT_flag( $A->{Titre_de_l_objet} ), - $A->{Nom}, $A->{Date}, $A->{MontantEUR}, $A->{Devise}, - $A->{Titre_de_l_objet}, $A->{Impact_sur_le_solde}, $A->{Type} ) ) ; - - $action->{ 'invoice' } = $A->{invoice} ; -} - -sub BNC_output { -# FE 1359 FR IND imapsync Bougon Edouard -# [12/01/2012] FR IND 28.73 EUR - my( $invoice, $FR_flag, $IND_flag, $SUPPORT_flag, - $Nom, $Date, $MontantEUR, $Devise, $Titre_de_l_objet, $Impact_sur_le_solde, $Type ) = @_ ; - - my $BNC_output ; - - if ( 'NONE' eq $invoice ) { - $BNC_output = "[$Date] $MontantEUR $Devise $Nom $Titre_de_l_objet [$Impact_sur_le_solde] [$Type]\n" ; - }else{ - $BNC_output = - "FE $invoice$FR_flag$IND_flag imapsync$SUPPORT_flag $Nom\n" - . "[$Date]$FR_flag$IND_flag $MontantEUR $Devise \n" ; - } - return( $BNC_output ) ; -} - -sub SUPPORT_flag { - my $Titre_de_l_objet = shift ; - my $SUPPORT_flag = '' ; - $SUPPORT_flag = ' support' if ( 'imapsync support' eq $Titre_de_l_objet ) ; -} - -sub IND_flag { - my( $Nom_Option_1, $Valeur_Option_1 ) = @_ ; - my $IND_flag = '' ; - $IND_flag = ' IND' if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) ; - return( $IND_flag ) ; -} - -sub FR_flag { - my $Pays = shift ; - my $FR_flag = '' ; - - $FR_flag = ' FR' if $Pays eq 'France' ; - return( $FR_flag ) ; -} - -sub escape_for_tex { - - my $F = shift ; - foreach my $str ( - $F->{De_l_adresse_email}, - $F->{Nom}, - $F->{clientAdrA}, - $F->{clientAdrB}, - $F->{clientAdrC}, - $F->{clientAdrD}, - $F->{clientAdrE}, - $F->{clientAdrF}, - ) { - $str =~ s{#}{\\#}g ; - $str =~ s{_}{\\_}g ; - $str =~ s{&}{\\&}g ; - } -} - -sub build_invoice { - my $invoice = shift ; - - return if ! $invoice ; - - my $F ; - $F->{invoice} = $invoice ; - - my $action = $action_invoice{ $F->{invoice} } ; - #print Data::Dumper->Dump( [$action] ) ; - - @{$F}{ qw( 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 - Nom_Option_2 Option_2_Valeur ) } - = @{$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', - 'Nom Option 2', 'Option 2 Valeur' ) } ; - - $F->{Etat_Province} = $action->{'Etat/Province/Région/Comté/Territoire/Préfecture/République'} - || $action->{'État/Province/Région/Comté/Territoire/Préfecture/République'} - || '' ; - $F->{Hors_taxe} = $action->{'Hors taxe'} || $action->{'Avant commission'} ; - $F->{Hors_taxe_num} = $F->{Hors_taxe} ; - $F->{Hors_taxe_num} =~ s{,}{.} ; - if ($F->{Hors_taxe_num} > 100) { - print "invoice $F->{invoice} $F->{Hors_taxe_num} > 100\n" ; - #return() ; - } - - build_email_message( $F ) ; - $debug_email and print( "\n", $F->{email_message_header}, $F->{email_message_body} ) ; - - if ( $write_invoices and ! invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ) ) { - write_email_message( $dir_invoices, $F->{invoice}, - $F->{email_message_header}, $F->{email_message_body}, - $F->{De_l_adresse_email} ) ; - write_csv_info( $dir_invoices, $F->{invoice}, $F->{file_csv}, $F->{line_number}, $F->{line_csv} ) ; - } - - - build_address( $F ) ; - escape_for_tex( $F ) ; - client_type( $F ) ; - object_type( $F ) ; - description_stuff( $F ) ; - tva_stuff( $F ) ; - $F->{quantity} = '1' ; - - download_urls( $F ) ; - ( $F->{Nom1} ) = cut( $F->{Nom}, 42 ) ; - $F->{clientVAT} = '' ; - - if ( ( 'VAT if professional in Europe' eq $F->{Nom_Option_2} ) and $F->{Option_2_Valeur} ) { - $F->{clientVAT} = $F->{Option_2_Valeur} ; - } - - my $tex_variables = qq{ -%% Begin input from paypal_bilan $VERSION -\\providecommand{\\invoiceNumber}{$F->{invoice}} -\\providecommand{\\clientName}{$F->{Nom1}} -\\providecommand{\\clientEmail}{$F->{De_l_adresse_email}} -\\providecommand{\\clientAdrA}{$F->{clientAdrA}} -\\providecommand{\\clientAdrB}{$F->{clientAdrB}} -\\providecommand{\\clientAdrC}{$F->{clientAdrC}} -\\providecommand{\\clientAdrD}{$F->{clientAdrD}} -\\providecommand{\\clientAdrE}{$F->{clientAdrE}} -\\providecommand{\\clientAdrF}{$F->{clientAdrF}} -\\providecommand{\\clientVAT}{$F->{clientVAT}} -\\providecommand{\\invoiceDate}{$F->{Date}} -\\providecommand{\\invoiceHour}{$F->{Heure}} - -\\providecommand{\\descriptionFR}{$F->{descriptionFR}} -\\providecommand{\\descriptionEN}{$F->{descriptionEN}} -\\providecommand{\\usageFR}{$F->{usageFR}} -\\providecommand{\\usageEN}{$F->{usageEN}} -\\providecommand{\\quantity}{$F->{quantity}} - -\\providecommand{\\priceHT}{$F->{priceHT}} -\\providecommand{\\tvaFR}{$F->{tvaFR}} -\\providecommand{\\tvaEN}{$F->{tvaEN}} -\\providecommand{\\priceTVA}{$F->{priceTVA}} -\\providecommand{\\HTorTTC}{$F->{HTorTTC}} -\\providecommand{\\priceTTC}{$F->{priceTTC}} -\\providecommand{\\priceTTCusd}{$F->{priceTTCusd}} -\\providecommand{\\messageTVAFR}{$F->{messageTVAFR}} -\\providecommand{\\messageTVAEN}{$F->{messageTVAEN}} -\\providecommand{\\urlSrc}{\\url{$F->{urlSrc}}} -\\providecommand{\\urlExe}{\\url{$F->{urlExe}}} -%% End input from paypal_bilan -} ; - - my $tex_variables_utf8 = to_utf8( { -string => $tex_variables, -charset => 'ISO-8859-1' } ) ; - - $debug_invoice_utf8 and print $tex_variables_utf8 ; - $debug_invoice and print $tex_variables ; - - #print "$F->{invoice} ", invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ), "\n" ; - if ( $write_invoices and ! invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ) ) { - write_tex_variables_file( $dir_invoices, $F->{invoice}, $F->{Date}, $tex_variables_utf8 ) ; - } - -} - -sub description_stuff { - my $F = shift ; - - $F->{descriptionFR} = $F->{descriptionEN} = '' ; - if ( 'software' eq $F->{object_type} ) { - $F->{descriptionFR} = 'Logiciel imapsync. TOUS droits cédés, autorisés.' ; - $F->{descriptionEN} = '(Imapsync software. ALL rights conceded, allowed.)' ; - } - - $F->{usageFR} = $F->{usageEN} = '' ; - - if ( 'professional' eq $F->{clientTypeEN} - and 'software' eq $F->{object_type} ) { - $F->{usageFR} = 'Usage à titre professionnel.' ; - $F->{usageEN} = '(professional usage.)' ; - } - - if ( 'individual' eq $F->{clientTypeEN} - and 'software' eq $F->{object_type} ) { - $F->{usageFR} = 'Usage à titre individuel.' ; - $F->{usageEN} = '(individual usage.)' ; - } - - if ( 'support' eq $F->{object_type} ) { - $F->{descriptionFR} = 'Support sur le logiciel imapsync.' ; - $F->{descriptionEN} = '(Imapsync support.)' ; - $F->{usageFR} = '' ; - $F->{usageEN} = '' ; - } -} - - - -sub object_type { - my $F = shift ; - - $F->{object_type} = '' ; - if ( 'imapsync' eq $F->{Titre_de_l_objet} - or 'imapsync.exe' eq $F->{Titre_de_l_objet} - or 'imapsync source' eq $F->{Titre_de_l_objet} - or 'imapsync source code' eq $F->{Titre_de_l_objet} - ) { - $F->{object_type} = 'software' ; - }elsif ( 'imapsync support' eq $F->{Titre_de_l_objet} ) { - $F->{object_type} = 'support' ; - } -} - -sub build_email_message { - - my $F = shift ; - - #my $object_type ; - object_type( $F ) ; - - my $invoice = $F->{invoice} ; - - my $message_header_software = qq{X-imapsync: invoice $invoice for imapsync software -From: Gilles LAMIRAL -Bcc: gilles\@lamiral.info -Subject: [imapsync invoice] $invoice ($F->{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 ($F->{Date}) for imapsync support -Disposition-Notification-To: Gilles LAMIRAL -} ; - - my $message_body_software = qq{ -Hello $F->{Nom}, - -First of all, I'm sorry for the delay in getting back to you. - -Last imapsync release is available from the page -http://imapsync.lamiral.info/paypal_return.shtml - -You'll find in the attachment the invoice of imapsync -software you bought and paid (dd/mm/yyyy $F->{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 $F->{Nom}, - -First of all, I'm sorry for the delay in getting back to you. - -Last imapsync release is available from the page -http://imapsync.lamiral.info/paypal_return.shtml - -You'll find in the attachment the invoice of imapsync -support you bought and paid (dd/mm/yyyy $F->{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 = my $message_body = '' ; - - if ( 'support' eq $F->{object_type} ) { - $message_header = $message_header_support ; - $message_body = $message_body_support ; - }elsif ( 'software' eq $F->{object_type} ) { - $message_header = $message_header_software ; - $message_body = $message_body_software ; - } - $F->{email_message_header} = $message_header ; - $F->{email_message_body} = $message_body ; - return( ) ; - -} - -sub write_csv_info { - - my( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - $debug and print "Writing $dir_invoices/$invoice_00000/csv_info.txt\n" ; - $dry and return( ) ; - - open( CSVINFO, "> $dir_invoices/$invoice_00000/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 ) = @_ ; - my $invoice_00000 = invoice_00000( $invoice ) ; - return( 1 ) if ( -f "$dir_invoices/$invoice_00000/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' }); - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $dry and return( ) ; - - open( HEADER, "> $dir_invoices/$invoice_00000/facture_message_header.txt") or die ; - print HEADER $message_header ; - close( HEADER ) ; - - open( BODY, "> $dir_invoices/$invoice_00000/facture_message_body.txt") or die ; - print BODY $message_body_utf8 ; - close( BODY ) ; - - open( ADDRESS, "> $dir_invoices/$invoice_00000/email_address.txt") or die ; - print ADDRESS "$email_address\n" ; - close( ADDRESS ) ; -} - - -sub write_tex_variables_file { - my ( $dir_invoices, $invoice, $Date, $tex_variables_utf8 ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $debug and print "Writing imapsync_var.tex $dir_invoices/$invoice_00000/imapsync_var.tex\n" ; - $dry and return( ) ; - - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var.tex") or die ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - - if ( ! -f "$dir_invoices/$invoice_00000/imapsync_var_manual.tex" ) { - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var_manual.tex") or die ; - print FILE "%% $0 created this file -%% Can be used to override imapsync_var.tex definitions\n" ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - } - -} - -sub download_urls { - my $F = shift ; - - $F->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $F->{Date} ) ; - - if ('2011_05_01' le $F->{date_aaaa_mm_jj} - and 'software' eq $F->{object_type} ) { - $F->{urlSrc} = 'http://ks.lamiral.info/imapsync/paypal_return.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - - if ('2011_05_01' le $F->{date_aaaa_mm_jj} - and 'support' eq $F->{object_type} ) { - $F->{urlSrc} = 'http://ks.lamiral.info/imapsync/paypal_return_support.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - - if ('2011_03_24' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/prj/imapsync/paypal_return.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - if ('2011_02_21' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2011_02_21/OUMbo7/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2011_02_21/rHSVNs/' ; - return( ) ; - } - if ('2011_01_18' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2011_01_18/zPRRNt/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2011_01_18/FO1QzG/' ; - return( ) ; - } - if ('2011_01_18' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2010_11_28/SiNdlZ/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2010_11_28/R3ZAyr/' ; - return( ) ; - } - $F->{urlSrc} = 'http://www.linux-france.org/depot/2010_11_08/X2PWMe/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2010_11_08/ZZ7zSc/' ; - return( ) ; -} - -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_rate { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - #return( 0 ) ; - return( 0.196 ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - #print "tva_rate 0.2\n" ; - return( 0.2 ) ; - } - #print "tva_rate 0\n" ; - return( 0 ) ; -} - -sub tests_tva_rate { - ok( 0.196 == tva_rate( '2013_01_01' ), 'tva_rate: old 0.196' ) ; - ok( 0.196 == tva_rate( '2013_12_31' ), 'tva_rate: old 0.196' ) ; - ok( 0.2 == tva_rate( '2014_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2014_12_31' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_12_31' ), 'tva_rate: new 0.2' ) ; - return( 0 ) ; -} - - -sub tva_rate_str { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - return( '19,60\%' ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - return( '20\%' ) ; - } - #print "tva_rate 0\n" ; - return( '' ) ; -} - -sub tests_tva_rate_str { - ok( '19,60\%' eq tva_rate_str( '2013_01_01' ), 'tva_rate_str: old 0.196' ) ; - ok( '19,60\%' eq tva_rate_str( '2013_12_31' ), 'tva_rate_str: old 0.196' ) ; - ok( '20\%' eq tva_rate_str( '2014_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2014_12_31' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2050_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2050_12_31' ), 'tva_rate_str: new 0.2' ) ; - return( 0 ) ; -} - - -sub tva_line_one_button_for_the_software { - - my $A = shift ; - - if ( 'imapsync' eq $A->{Titre_de_l_objet} - or 'imapsync.exe' eq $A->{Titre_de_l_objet} - or 'imapsync source' eq $A->{Titre_de_l_objet} - or 'imapsync source code' eq $A->{Titre_de_l_objet} - - ) { - if ( - ( 'imapsync usage' eq $A->{Nom_Option_1} and 'individual' eq $A->{Valeur_Option_1} ) - or - ( 'France' eq $A->{Pays} ) - ) { - $A->{montant_HT_EUR_logi_ass} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_logi} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_logi_exo} = $A->{Montant2} ; - } - } - -} - -sub tva_line_one_button_for_the_support { - - my $A = shift ; - - if ( 'imapsync support' eq $A->{Titre_de_l_objet} ) { - if ( - ( 'imapsync usage' eq $A->{Nom_Option_1} and 'individual' eq $A->{Valeur_Option_1} ) - or - ( 'France' eq $A->{Pays} ) - or - ( '2013_02_19' gt $A->{date_aaaa_mm_jj} ) - ) - { - $A->{montant_HT_EUR_sup} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_sup} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_sup_exo} = $A->{Montant2} ; - } - } -} - - -sub software_price { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - return( 50 ) ; - } - return( 0 ) ; -} - - -sub tests_software_price { - ok( 50 == software_price( '2014_01_01' ), 'software_price: 2014_01_01 => 50 ' ) ; - ok( 0 == software_price( '2000_01_01' ), 'software_price: 2000_01_01 => 0' ) ; - return( 0 ) ; -} - - -sub tva_line_one_button_for_support_and_software_case_no_vat_number { - - my $A = shift ; - - $A->{Montant2_logi} = software_price( $A->{date_aaaa_mm_jj} ) ; - $A->{Montant2_supp} = $A->{Montant2} - $A->{Montant2_logi} ; - - if ( 'imapsync all' eq $A->{Titre_de_l_objet} ) { - if ( - ( 'usage' eq $A->{Nom_Option_2} and 'individual' eq $A->{Option_2_Valeur} ) - or - ( 'France' eq $A->{Pays} ) - ) - { - $A->{montant_HT_EUR_sup} = $A->{Montant2_supp} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_sup} = $A->{Montant2_supp} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - $A->{montant_HT_EUR_logi_ass} = $A->{Montant2_logi} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_logi} = $A->{Montant2_logi} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_logi_exo} = $A->{Montant2_logi} ; - $A->{montant_HT_EUR_sup_exo} = $A->{Montant2_supp} ; - } - } -} - - -sub tva_line { - - my $A = shift ; - - $A->{montant_HT_EUR_logi_exo} = $A->{montant_HT_EUR_logi_ass} = $A->{montant_TVA_EUR_logi} = 0 ; - $A->{montant_HT_EUR_sup} = $A->{montant_TVA_EUR_sup} = $A->{montant_HT_EUR_sup_exo} = 0 ; - - $A->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $A->{Date} ) ; - $A->{Montant2} = $A->{Montant2}/$usdeur if 'USD' eq $A->{Devise} ; - - tva_line_one_button_for_the_software( $A ) ; - tva_line_one_button_for_the_support( $A ) ; - tva_line_one_button_for_support_and_software_case_no_vat_number( $A ) ; - return( ) ; -} - - - -sub tva_stuff { - my $F = shift ; - - $F->{priceTTCusd} = '' ; - $F->{Hors_taxe} =~ s{,}{.} ; - - $F->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $F->{Date} ) ; - - if ( $F->{Devise} eq 'USD' ) { - $F->{priceTTCusd} = "(usd $F->{Hors_taxe})" ; - $F->{Hors_taxe} = ( $F->{Hors_taxe}/$usdeur ) ; - } - - if ( ( 'individual' eq $F->{clientTypeEN}) - or - ( 'France' eq $F->{Pays} ) - ) { - $F->{priceHT} = sprintf('%2.2f', $F->{Hors_taxe} / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) ) ; - $F->{tvaFR} = tva_rate_str( $F->{date_aaaa_mm_jj} ) ; - $F->{tvaEN} = '' ; - $F->{priceTVA} = sprintf('%2.2f', $F->{Hors_taxe} / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) * tva_rate( $F->{date_aaaa_mm_jj} ) ) ; - $F->{priceTTC} = sprintf('%2.2f', $F->{Hors_taxe}) ; - $F->{HTorTTC} = 'TTC' ; - $F->{messageTVAFR} = '' ; - $F->{messageTVAEN} = '' ; - }else{ - $F->{priceHT} = sprintf('%2.2f', $F->{Hors_taxe}) ; - $F->{tvaFR} = '' ; - $F->{tvaEN} = '' ; - $F->{priceTVA} = 'néant (none)' ; - $F->{priceTTC} = $F->{priceHT} ; - $F->{HTorTTC} = 'HT' ; - $F->{messageTVAFR} = 'Exonération de TVA, articles 259 et 262 du Code Général des Impôts'; - $F->{messageTVAEN} = '(VAT tax-exempt, articles 259 and 262 of French General Tax Code)'; - } - foreach my $price ( $F->{priceHT}, $F->{priceTVA}, $F->{priceTTC}, $F->{priceTTCusd} ) { - #print "[$price]\n" ; - $price =~ s{\.}{, } ; - } - return( ) ; -} - -sub client_type { - my $F = shift ; - - ( $F->{clientTypeEN}, $F->{clientTypeFR} ) = ( 'professional', 'professionnel' ) ; - - if ('imapsync usage' eq $F->{Nom_Option_1} and 'individual' eq $F->{Valeur_Option_1} ) { - $F->{clientTypeEN} = 'individual' ; - $F->{clientTypeFR} = 'individuel' ; - }elsif ('imapsync usage' eq $F->{Nom_Option_1} and 'professional' eq $F->{Valeur_Option_1} ) { - $F->{clientTypeEN} = 'professional' ; - $F->{clientTypeFR} = 'professionnel' ; - } - return( ) ; -} - -sub build_address { - my $F = shift ; - - my $addr = " -=========================================================== -Nom $F->{Nom} -Adresse_1 $F->{Adresse_1} -Adresse_2_district_quartier $F->{Adresse_2_district_quartier} -Ville Code_postal $F->{Ville} $F->{Code_postal} -Etat_Province $F->{Etat_Province} -Pays $F->{Pays} -" ; - #print $addr ; - - my @address ; - $F->{Nom} = '' if ( $F->{Nom} =~ m/^\s+$/ ) ; - my( $Nom1, $Nom2 ) = cut( $F->{Nom}, 42 ) ; - push( @address, $Nom1 ) if $Nom1 ; - #push( @address, $Nom2 ) if $Nom2 ; - push( @address, $F->{Adresse_1} ) if $F->{Adresse_1} ; - push( @address, $F->{Adresse_2_district_quartier} ) if $F->{Adresse_2_district_quartier} ; - push( @address, "$F->{Ville} $F->{Code_postal}" ) if ( $F->{Ville} or $F->{Code_postal} ) ; - push( @address, $F->{Etat_Province} ) if $F->{Etat_Province} ; - push( @address, $F->{Pays}, ) if $F->{Pays} ; - - - $F->{clientAdrA} = shift( @address ) || '' ; - $F->{clientAdrB} = shift( @address ) || '' ; - $F->{clientAdrC} = shift( @address ) || '' ; - $F->{clientAdrD} = shift( @address ) || '' ; - $F->{clientAdrE} = shift( @address ) || '' ; - $F->{clientAdrF} = shift( @address ) || '' ; - - return( ) ; -} - - -sub cut { - my $string = shift ; - my $offset = shift ; - return( $string, '' ) if length( $string ) < $offset ; - my $first = substr( $string, 0, $offset ) ; - my $last = substr( $string, $offset ) ; - - return( $first, $last ) ; -} - -sub tests_cut { - my( $aa, $bb ) = cut("123456789", 4 ) ; - ok( '1234' eq $aa, 'cut 123456789 4 => first 1234' ) ; - ok( '56789' eq $bb, 'cut 123456789 4 => last 56789' ) ; -} diff --git a/W/paypal_reply/paypal_bilan_1.76 b/W/paypal_reply/paypal_bilan_1.76 deleted file mode 100755 index 8a7769b..0000000 --- a/W/paypal_reply/paypal_bilan_1.76 +++ /dev/null @@ -1,1347 +0,0 @@ -#!/usr/bin/perl - -# $Id: paypal_bilan,v 1.76 2014/05/03 00:15:22 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 $rcs = '$Id: paypal_bilan,v 1.76 2014/05/03 00:15:22 gilles Exp gilles $ ' ; -$rcs =~ m/,v (\d+\.\d+)/ ; -my $VERSION = ($1) ? $1: "UNKNOWN" ; - - -my $total_usd_received = 0 ; -my $total_usd_invoice = 0 ; -my $total_HT_EUR_logi_exo = 0 ; -my $total_HT_EUR_logi_ass = 0 ; -my $total_TVA_EUR_logi = 0 ; - -my $total_HT_EUR_sup = 0 ; -my $total_TVA_EUR_sup = 0 ; -my $total_HT_EUR_sup_exo = 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 $nb_invoice_canceled = 0 ; - -my ( $tests, $testeur ) ; -my $dry ; -my $debug ; -my $debug_csv ; -my $debug_dev ; -my $debug_invoice ; -my $debug_invoice_utf8 ; -my $debug_email; - -my $first_invoice = 1 ; -my $print_details = '' ; -my $bnc = '' ; -my $exportbnc = '' ; - -my $usdeur = 1.2981 ; -my $invoices ; -my %invoice_refund ; -my %invoice_canceled ; -my %invoice_suspended ; -my $write_invoices = 0 ; -my $avoid_numbers ; - -my $dir_invoices ; - -my $option_ret = GetOptions ( - 'tests' => \$tests, - 'dry' => \$dry, - 'debug' => \$debug, - 'debug_csv' => \$debug_csv, - 'debug_dev' => \$debug_dev, - 'debug_invoice' => \$debug_invoice, - 'debug_invoice_utf8' => \$debug_invoice_utf8, - 'debug_email' => \$debug_email, - - 'first_invoice=i' => \$first_invoice, - 'print_details|details' => \$print_details, - 'bnc' => \$bnc, - 'exportbnc=s' => \$exportbnc, - 'usdeur=f' => \$usdeur, - 'invoices=s' => \$invoices, - 'write_invoices!' => \$write_invoices, - 'dir_invoices=s' => \$dir_invoices, - 'avoid_numbers=s' => \$avoid_numbers, -); - -$dir_invoices ||= '/g/var/paypal_invoices' ; -if ( $write_invoices and not -d "$dir_invoices" ) { - $debug and print "mkdir $dir_invoices\n" ; - $dry or mkdir( $dir_invoices ) or die ; -} - - - -$debug and print "dir_invoices = $dir_invoices\n" ; - -$testeur = Test::More->builder ; -$testeur->no_ending(1) ; - -if ( $tests ) { - $testeur->no_ending( 0 ) ; - exit( tests( ) ) ; -} - - -my @files = @ARGV ; -my %action_invoice ; - -my %invoice_paypal ; - -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" ; - -my @actions ; - -foreach my $file ( @files ) { - - my @actions_file = parse_file( $file ) ; - push( @actions, @actions_file ) ; -} - -foreach my $action (@actions) { - # compute_line() adds $action->{ 'invoice' } if needed - compute_line( $action ) ; - - # index by invoice number - $action_invoice{ $action->{ 'invoice' } } = $action ; -} -delete $action_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_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 }++ ; - build_invoice( $invoice ) if ( $debug_invoice or $debug_invoice_utf8 ) ; - }elsif( not ( $invoice_canceled{ $invoice } or $invoice_refund{ $invoice } ) ) { - $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 ) ; - -my @invoice_canceled = sort { $a <=> $b } keys( %invoice_canceled ) ; -my @invoice_suspended = sort { $a <=> $b } keys( %invoice_suspended ) ; -my @invoice_refund = sort { $a <=> $b } keys( %invoice_refund ) ; - - -print( "\n", "=" x 60, "\n" ) ; - -my $total_usd_paypal_cost ; -$total_usd_paypal_cost = sprintf('%2.2f', $total_usd_invoice - $total_usd_received ) ; -print "USD received $total_usd_received\n" ; -print "USD invoice $total_usd_invoice\n" ; -print "USD costs $total_usd_paypal_cost\n" ; - -my $total_eur_invoice_from_usd ; -my $total_eur_received_from_usd ; -my $total_eur_paypal_cost_from_usd ; - -# au 30 nov 2010 http://fr.finance.yahoo.com/devises/convertisseur/#from=EUR;to=USD;amt=1 -$total_eur_invoice_from_usd = sprintf('%2.2f', $total_usd_invoice / $usdeur ) ; -$total_eur_received_from_usd = sprintf('%2.2f', $total_usd_received / $usdeur ) ; -$total_eur_paypal_cost_from_usd = sprintf('%2.2f', $total_usd_paypal_cost / $usdeur ) ; - -# EUR -$total_eur_received = sprintf('%2.2f', $total_eur_received) ; -$total_eur_invoice = sprintf('%2.2f', $total_eur_invoice) ; -print "EUR invoice from USD $total_eur_invoice_from_usd\n" ; -print "EUR received from EUR $total_eur_received\n" ; -print "EUR invoice from EUR $total_eur_invoice\n" ; - -my $total_eur_invoice_from_eur_usd = $total_eur_invoice_from_usd + $total_eur_invoice ; -my $total_eur_received_from_eur_usd = $total_eur_received_from_usd + $total_eur_received ; -my $total_eur_paypal_cost = $total_eur_invoice - $total_eur_received + $total_eur_paypal_cost_from_usd ; - - -$total_HT_EUR_logi_exo = sprintf('%2.2f', $total_HT_EUR_logi_exo) ; -$total_HT_EUR_logi_ass = sprintf('%2.2f', $total_HT_EUR_logi_ass) ; -$total_TVA_EUR_logi = sprintf('%2.2f', $total_TVA_EUR_logi) ; - -$total_HT_EUR_sup = sprintf('%2.2f', $total_HT_EUR_sup) ; -$total_TVA_EUR_sup = sprintf('%2.2f', $total_TVA_EUR_sup) ; -$total_HT_EUR_sup_exo = sprintf('%2.2f', $total_HT_EUR_sup_exo) ; - -$total_eur_invoice_from_eur_usd = sprintf('%2.2f', $total_eur_invoice_from_eur_usd) ; -$total_eur_paypal_cost = sprintf('%2.2f', $total_eur_paypal_cost) ; - -print( "---- USD + EUR ----\n" ) ; -print "EUR total invoice $total_eur_invoice_from_eur_usd\n" ; -print "EUR total received $total_eur_received_from_eur_usd\n" ; -print "EUR total paypal cost $total_eur_paypal_cost\n" ; -print ; -print( "---- Assujeti TVA ----\n" ) ; -print "EUR total HT licen assuj $total_HT_EUR_logi_ass (autres operations imposables)\n" ; -#print "EUR total TVA licen assuj $total_TVA_EUR_logi\n" ; -print "EUR total HT supp assuj $total_HT_EUR_sup (ventes, prestations)\n" ; -#print "EUR total TVA supp assuj $total_TVA_EUR_sup\n" ; - -print( "---- Exonere TVA ----\n" ) ; -print "EUR total HT licen exo $total_HT_EUR_logi_exo (autres operations NON imposables)\n" ; -print "EUR total HT suppo exo $total_HT_EUR_sup_exo (autres operations NON imposables)\n" ; - -print( "---- Invoices ----\n" ) ; - -print "Nb invoice $nb_invoice ( from $first_invoice_paypal to $last_invoice )\n" ; -print "Nb invoice canceled ($nb_invoice_canceled) @invoice_canceled\n" ; -print "Nb invoice suspended ($nb_invoice_suspended) @invoice_suspended\n" ; -print "Nb invoice refund ($nb_invoice_refund) @invoice_refund\n" ; -print "Nb invoice sent $nb_invoice_sent\n" ; -print "Have to send invoices @invoice_not_sent\n" if ( @invoice_not_sent ) ; - -my $total_eur2 = $total_HT_EUR_logi_exo + $total_HT_EUR_logi_ass + $total_TVA_EUR_logi + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo ; -$total_eur2 = sprintf('%2.2f', $total_eur2) ; -print "$total_eur_invoice_from_eur_usd != $total_eur2 = $total_HT_EUR_logi_exo + $total_HT_EUR_logi_ass + $total_TVA_EUR_logi + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo\n" -if ( $total_eur_invoice_from_eur_usd != $total_eur2 ) ; - -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 invoice_00000 { - my $invoice = shift ; - - return( sprintf( "%04d", $invoice ) ) ; -} - -sub tests_invoice_00000 { - - ok( '0000' eq invoice_00000( 0 ), 'invoice_00000: 0 -> 0000' ) ; - ok( '0147' eq invoice_00000( 147 ), 'invoice_00000: 147 -> 0147' ) ; - ok( '99999' eq invoice_00000( 99999 ), 'invoice_00000: 99999 -> 99999' ) ; -} - -sub tests_next_invoice { - ok( 1 == next_invoice( ), 'next_invoice: 1' ) ; - ok( 2 == next_invoice( ), 'next_invoice: 2' ) ; - @avoid_numbers{ (3, 4, 6, 8 ) } = ( ) ; - ok( 5 == next_invoice( ), 'next_invoice: 7' ) ; - ok( 7 == next_invoice( ), 'next_invoice: 8' ) ; - ok( 9 == next_invoice( ), 'next_invoice: 9' ) ; - %invoice_paypal = () ; - $first_invoice = 7 ; - ok( 7 == next_invoice( ), 'next_invoice: 7' ) ; -} - - -sub tests_exportbnc { - ok( 1 == 1, '1 == 1' ) ; - -} - - - -sub tests { - tests_next_invoice( ) ; - tests_cut( ) ; - tests_invoice_00000( ) ; - #tests_exportbnc( ) ; - tests_tva_rate( ) ; - tests_tva_rate_str( ) ; - tests_software_price( ) ; -} - -sub compute_line_debug { - - my $A = shift ; - - return( "#" x 78, "\n", - "[$A->{Date}] [$A->{Heure}] [$A->{Fuseau_horaire}] [$A->{Nom}] [$A->{Type}] [$A->{Etat}] ", - "[$A->{Devise}] [$A->{Hors_taxe_paypal}] [$A->{Montant}] [$A->{Numero_davis_de_reception}] [$A->{Solde}] [$A->{Impact_sur_le_solde}] ", - "[$A->{Pays}] [$A->{Nom_Option_1}] [$A->{Valeur_Option_1}] [$A->{Titre_de_l_objet}]\n" ) ; - -} - -sub bnc_first_line { - my $A = shift ; - $A->{MontantEUR} = $A->{Montant} ; - $A->{MontantEUR} = sprintf( "%.4f", $A->{Montant}/$usdeur ) if ($A->{Devise} eq 'USD') ; - return( "\n", "=" x 60, "\n", - "[$A->{Date}] [$A->{Nom}] [$A->{Type}] [$A->{Etat}] [$A->{Devise}] ", - "[$A->{Hors_taxe_paypal}] [$A->{Montant}] [EUR $A->{MontantEUR}] [$A->{Impact_sur_le_solde}]\n", - "[$A->{Pays}] [$A->{Nom_Option_1}] [$A->{Valeur_Option_1}] [$A->{Titre_de_l_objet}]\n" ) ; -} - -sub details { - - my $A = shift ; - - return( "[$A->{invoice}] [$A->{Date}] [$A->{Heure}] [$A->{Fuseau_horaire}] ", - "[$A->{Nom}] [$A->{Type}] [$A->{Etat}] [$A->{Devise}] [$A->{Montant}] ", - "[$A->{Numero_davis_de_reception}] [$A->{Solde}] [$A->{Impact_sur_le_solde}]\n" ) ; - -} - -sub paiement_usd_termine{ - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'USD' eq $A->{Devise} - and ( 'Terminé' eq $A->{Etat} or 'Compensé' eq $A->{Etat} ) - ) { - $A->{Montant} =~tr/,/./; - $A->{Montant2} = $A->{Hors_taxe_paypal} ; - $total_usd_received += $A->{Montant} ; - $total_usd_invoice += $A->{Montant2} ; - tva_line( $A ) ; - $total_HT_EUR_logi_exo += $A->{montant_HT_EUR_logi_exo} ; - $total_HT_EUR_logi_ass += $A->{montant_HT_EUR_logi_ass} ; - $total_TVA_EUR_logi += $A->{montant_TVA_EUR_logi} ; - - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_termine { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and ( 'Terminé' eq $A->{Etat} or 'Compensé' eq $A->{Etat} ) - ) { - $A->{Montant} =~tr/,/./; - $A->{Montant2} = $A->{Hors_taxe_paypal} ; - $total_eur_received += $A->{Montant} ; - $total_eur_invoice += $A->{Montant2} ; - tva_line( $A ) ; - $total_HT_EUR_logi_exo += $A->{montant_HT_EUR_logi_exo} ; - $total_HT_EUR_logi_ass += $A->{montant_HT_EUR_logi_ass} ; - $total_TVA_EUR_logi += $A->{montant_TVA_EUR_logi} ; - $total_HT_EUR_sup += $A->{montant_HT_EUR_sup} ; - $total_TVA_EUR_sup += $A->{montant_TVA_EUR_sup} ; - $total_HT_EUR_sup_exo += $A->{montant_HT_EUR_sup_exo} ; - - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_rembourse { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Remboursé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_refund++; - $invoice_refund{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_annule { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Annulé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_canceled++; - $invoice_canceled{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_suspendu { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Suspendu' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_suspended++; - $invoice_suspended{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_non_compense { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Non compensé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - - - -sub compute_line { - - my $action = shift ; - my %action = %$action ; - my $A ; - - @{$A}{ qw( - 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 Nom_Option_2 Option_2_Valeur - Impact_sur_le_solde - ) } - = @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", 'Nom Option 2', 'Option 2 Valeur', - 'Impact sur le solde') } ; - - ( $A->{Etat} ) = @action{ ( 'Etat' ) } || @action{ ( 'État' ) } ; - ( $A->{Hors_taxe_paypal} ) = @action{ ( 'Hors taxe' ) } || @action{ ( 'Avant commission' ) } ; - $A->{Impact_sur_le_solde} ||= '' ; - $A->{invoice} = 'NONE' ; - $A->{Montant} = $action->{ 'Net' } if not defined $A->{Montant}; - - $debug and print( compute_line_debug( $A ) ) ; - - $A->{Montant} =~ s/[^0-9-,.]//g ; - $A->{Montant} =~ s/,/./g ; - $A->{Hors_taxe_paypal} =~ s/,/./g ; - - $bnc and print( bnc_first_line( $A ) ) ; - paiement_usd_termine( $A ) ; - paiement_eur_termine( $A ) ; - paiement_eur_rembourse( $A ) ; - paiement_eur_annule( $A ) ; - paiement_eur_suspendu( $A ) ; - paiement_eur_non_compense( $A ) ; - $bnc and print( BNC_output( $A->{invoice}, FR_flag( $A->{Pays} ), - IND_flag( $A->{Nom_Option_1}, $A->{Valeur_Option_1} ), - SUPPORT_flag( $A->{Titre_de_l_objet} ), - $A->{Nom}, $A->{Date}, $A->{MontantEUR}, $A->{Devise}, - $A->{Titre_de_l_objet}, $A->{Impact_sur_le_solde}, $A->{Type} ) ) ; - - $action->{ 'invoice' } = $A->{invoice} ; -} - -sub BNC_output { -# FE 1359 FR IND imapsync Bougon Edouard -# [12/01/2012] FR IND 28.73 EUR - my( $invoice, $FR_flag, $IND_flag, $SUPPORT_flag, - $Nom, $Date, $MontantEUR, $Devise, $Titre_de_l_objet, $Impact_sur_le_solde, $Type ) = @_ ; - - my $BNC_output ; - - if ( 'NONE' eq $invoice ) { - $BNC_output = "[$Date] $MontantEUR $Devise $Nom $Titre_de_l_objet [$Impact_sur_le_solde] [$Type]\n" ; - }else{ - $BNC_output = - "FE $invoice$FR_flag$IND_flag imapsync$SUPPORT_flag $Nom\n" - . "[$Date]$FR_flag$IND_flag $MontantEUR $Devise \n" ; - } - return( $BNC_output ) ; -} - -sub SUPPORT_flag { - my $Titre_de_l_objet = shift ; - my $SUPPORT_flag = '' ; - $SUPPORT_flag = ' support' if ( 'imapsync support' eq $Titre_de_l_objet ) ; -} - -sub IND_flag { - my( $Nom_Option_1, $Valeur_Option_1 ) = @_ ; - my $IND_flag = '' ; - $IND_flag = ' IND' if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) ; - return( $IND_flag ) ; -} - -sub FR_flag { - my $Pays = shift ; - my $FR_flag = '' ; - - $FR_flag = ' FR' if $Pays eq 'France' ; - return( $FR_flag ) ; -} - -sub escape_for_tex { - - my $F = shift ; - foreach my $str ( - $F->{De_l_adresse_email}, - $F->{Nom}, - $F->{clientAdrA}, - $F->{clientAdrB}, - $F->{clientAdrC}, - $F->{clientAdrD}, - $F->{clientAdrE}, - $F->{clientAdrF}, - ) { - $str =~ s{#}{\\#}g ; - $str =~ s{_}{\\_}g ; - $str =~ s{&}{\\&}g ; - } -} - -sub build_invoice { - my $invoice = shift ; - - return if ! $invoice ; - - my $F ; - $F->{invoice} = $invoice ; - - my $action = $action_invoice{ $F->{invoice} } ; - #print Data::Dumper->Dump( [$action] ) ; - - @{$F}{ qw( 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 - Nom_Option_2 Option_2_Valeur ) } - = @{$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', - 'Nom Option 2', 'Option 2 Valeur' ) } ; - - $F->{Etat_Province} = $action->{'Etat/Province/Région/Comté/Territoire/Préfecture/République'} - || $action->{'État/Province/Région/Comté/Territoire/Préfecture/République'} - || '' ; - $F->{Hors_taxe} = $action->{'Hors taxe'} || $action->{'Avant commission'} ; - $F->{Hors_taxe_num} = $F->{Hors_taxe} ; - $F->{Hors_taxe_num} =~ s{,}{.} ; - if ($F->{Hors_taxe_num} > 100) { - print "invoice $F->{invoice} $F->{Hors_taxe_num} > 100\n" ; - #return() ; - } - - build_email_message( $F ) ; - $debug_email and print( "\n", $F->{email_message_header}, $F->{email_message_body} ) ; - - if ( $write_invoices and ! invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ) ) { - write_email_message( $dir_invoices, $F->{invoice}, - $F->{email_message_header}, $F->{email_message_body}, - $F->{De_l_adresse_email} ) ; - write_csv_info( $dir_invoices, $F->{invoice}, $F->{file_csv}, $F->{line_number}, $F->{line_csv} ) ; - } - - - build_address( $F ) ; - escape_for_tex( $F ) ; - client_type( $F ) ; - object_type( $F ) ; - description_stuff( $F ) ; - tva_stuff( $F ) ; - $F->{quantity} = '1' ; - - download_urls( $F ) ; - ( $F->{Nom1} ) = cut( $F->{Nom}, 42 ) ; - $F->{clientVAT} = '' ; - - if ( ( 'VAT if professional in Europe' eq $F->{Nom_Option_2} ) and $F->{Option_2_Valeur} ) { - $F->{clientVAT} = $F->{Option_2_Valeur} ; - } - - my $tex_variables = qq{ -%% Begin input from paypal_bilan $VERSION -\\providecommand{\\invoiceNumber}{$F->{invoice}} -\\providecommand{\\clientName}{$F->{Nom1}} -\\providecommand{\\clientEmail}{$F->{De_l_adresse_email}} -\\providecommand{\\clientAdrA}{$F->{clientAdrA}} -\\providecommand{\\clientAdrB}{$F->{clientAdrB}} -\\providecommand{\\clientAdrC}{$F->{clientAdrC}} -\\providecommand{\\clientAdrD}{$F->{clientAdrD}} -\\providecommand{\\clientAdrE}{$F->{clientAdrE}} -\\providecommand{\\clientAdrF}{$F->{clientAdrF}} -\\providecommand{\\clientVAT}{$F->{clientVAT}} -\\providecommand{\\invoiceDate}{$F->{Date}} -\\providecommand{\\invoiceHour}{$F->{Heure}} - -\\providecommand{\\descriptionFR}{$F->{descriptionFR}} -\\providecommand{\\descriptionEN}{$F->{descriptionEN}} -\\providecommand{\\usageFR}{$F->{usageFR}} -\\providecommand{\\usageEN}{$F->{usageEN}} -\\providecommand{\\quantity}{$F->{quantity}} - -\\providecommand{\\priceHT}{$F->{priceHT}} -\\providecommand{\\tvaFR}{$F->{tvaFR}} -\\providecommand{\\tvaEN}{$F->{tvaEN}} -\\providecommand{\\priceTVA}{$F->{priceTVA}} -\\providecommand{\\HTorTTC}{$F->{HTorTTC}} -\\providecommand{\\priceTTC}{$F->{priceTTC}} -\\providecommand{\\priceTTCusd}{$F->{priceTTCusd}} -\\providecommand{\\messageTVAFR}{$F->{messageTVAFR}} -\\providecommand{\\messageTVAEN}{$F->{messageTVAEN}} -\\providecommand{\\urlSrc}{\\url{$F->{urlSrc}}} -\\providecommand{\\urlExe}{\\url{$F->{urlExe}}} -%% End input from paypal_bilan -} ; - - my $tex_variables_utf8 = to_utf8( { -string => $tex_variables, -charset => 'ISO-8859-1' } ) ; - - $debug_invoice_utf8 and print $tex_variables_utf8 ; - $debug_invoice and print $tex_variables ; - - #print "$F->{invoice} ", invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ), "\n" ; - if ( $write_invoices and ! invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ) ) { - write_tex_variables_file( $dir_invoices, $F->{invoice}, $F->{Date}, $tex_variables_utf8 ) ; - } - -} - -sub description_stuff { - my $F = shift ; - - $F->{descriptionFR} = $F->{descriptionEN} = '' ; - - if ( 'software' eq $F->{object_type} ) { - $F->{descriptionFR} = 'Logiciel imapsync. TOUS droits cédés, autorisés.' ; - $F->{descriptionEN} = '(Imapsync software. ALL rights conceded, allowed.)' ; - } - - $F->{usageFR} = $F->{usageEN} = '' ; - - if ( 'professional' eq $F->{clientTypeEN} - and ( - ( 'software' eq $F->{object_type} ) - or - ( 'software + support' eq $F->{object_type} ) - ) - ) { - $F->{usageFR} = 'Usage à titre professionnel.' ; - $F->{usageEN} = '(professional usage.)' ; - } - - if ( 'individual' eq $F->{clientTypeEN} - and 'software' eq $F->{object_type} ) { - $F->{usageFR} = 'Usage à titre individuel.' ; - $F->{usageEN} = '(individual usage.)' ; - } - - if ( 'support' eq $F->{object_type} ) { - $F->{descriptionFR} = 'Support sur le logiciel imapsync.' ; - $F->{descriptionEN} = '(Imapsync support.)' ; - $F->{usageFR} = '' ; - $F->{usageEN} = '' ; - } -} - - - -sub object_type { - my $F = shift ; - - $F->{object_type} = '' ; - - if ( 'imapsync' eq $F->{Titre_de_l_objet} - or 'imapsync.exe' eq $F->{Titre_de_l_objet} - or 'imapsync source' eq $F->{Titre_de_l_objet} - or 'imapsync source code' eq $F->{Titre_de_l_objet} - ) { - $F->{object_type} = 'software' ; - }elsif ( 'imapsync support' eq $F->{Titre_de_l_objet} ) { - $F->{object_type} = 'support' ; - }elsif ( ( 'imapsync all' eq $F->{Titre_de_l_objet} ) - and ( 'software only' eq $F->{Valeur_Option_1} ) ) { - $F->{object_type} = 'software' ; - }elsif ( ( 'imapsync all' eq $F->{Titre_de_l_objet} ) - and ( 'software + support' eq $F->{Valeur_Option_1} ) ) { - $F->{object_type} = 'software + support' ; - } -} - -sub build_email_message { - - my $F = shift ; - - object_type( $F ) ; - my $invoice = $F->{invoice} ; - - my $message_header = qq{X-imapsync: invoice $invoice for imapsync $F->{object_type} -From: Gilles LAMIRAL -Bcc: gilles\@lamiral.info -Subject: [imapsync invoice] $invoice ($F->{Hors_taxe_num} EUR on $F->{Date}) for imapsync $F->{object_type}. -Disposition-Notification-To: Gilles LAMIRAL -} ; - - - my $message_body = qq{ -Hello $F->{Nom}, - -First of all, I'm sorry for the delay in getting back to you. - -Last imapsync release is available from the page -http://imapsync.lamiral.info/paypal_return.shtml - -You'll find in the attachment the invoice of imapsync -$F->{object_type} you bought and paid (dd/mm/yyyy $F->{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 $F->{object_type}. - -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. -} ; - - $F->{email_message_header} = $message_header ; - $F->{email_message_body} = $message_body ; - return( ) ; - -} - -sub write_csv_info { - - my( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - $debug and print "Writing $dir_invoices/$invoice_00000/csv_info.txt\n" ; - $dry and return( ) ; - - open( CSVINFO, "> $dir_invoices/$invoice_00000/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 ) = @_ ; - my $invoice_00000 = invoice_00000( $invoice ) ; - return( 1 ) if ( -f "$dir_invoices/$invoice_00000/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' }); - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $dry and return( ) ; - - open( HEADER, "> $dir_invoices/$invoice_00000/facture_message_header.txt") or die ; - print HEADER $message_header ; - close( HEADER ) ; - - open( BODY, "> $dir_invoices/$invoice_00000/facture_message_body.txt") or die ; - print BODY $message_body_utf8 ; - close( BODY ) ; - - open( ADDRESS, "> $dir_invoices/$invoice_00000/email_address.txt") or die ; - print ADDRESS "$email_address\n" ; - close( ADDRESS ) ; -} - - -sub write_tex_variables_file { - my ( $dir_invoices, $invoice, $Date, $tex_variables_utf8 ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $debug and print "Writing imapsync_var.tex $dir_invoices/$invoice_00000/imapsync_var.tex\n" ; - $dry and return( ) ; - - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var.tex") or die ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - - if ( ! -f "$dir_invoices/$invoice_00000/imapsync_var_manual.tex" ) { - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var_manual.tex") or die ; - print FILE "%% $0 created this file -%% Can be used to override imapsync_var.tex definitions\n" ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - } - -} - -sub download_urls { - my $F = shift ; - - $F->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $F->{Date} ) ; - - if ( '2014_04_13' le $F->{date_aaaa_mm_jj} - and ( - ( 'software' eq $F->{object_type} ) - or - ( 'software + support' eq $F->{object_type} ) - ) - ) { - $F->{urlSrc} = 'http://imapsync.lamiral.info/paypal_return.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - - if ('2011_05_01' le $F->{date_aaaa_mm_jj} - and 'software' eq $F->{object_type} ) { - $F->{urlSrc} = 'http://ks.lamiral.info/imapsync/paypal_return.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - - if ('2011_05_01' le $F->{date_aaaa_mm_jj} - and 'support' eq $F->{object_type} ) { - $F->{urlSrc} = 'http://ks.lamiral.info/imapsync/paypal_return_support.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - - if ('2011_03_24' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/prj/imapsync/paypal_return.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - if ('2011_02_21' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2011_02_21/OUMbo7/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2011_02_21/rHSVNs/' ; - return( ) ; - } - if ('2011_01_18' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2011_01_18/zPRRNt/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2011_01_18/FO1QzG/' ; - return( ) ; - } - if ('2011_01_18' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2010_11_28/SiNdlZ/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2010_11_28/R3ZAyr/' ; - return( ) ; - } - $F->{urlSrc} = 'http://www.linux-france.org/depot/2010_11_08/X2PWMe/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2010_11_08/ZZ7zSc/' ; - return( ) ; -} - -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_rate { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - #return( 0 ) ; - return( 0.196 ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - #print "tva_rate 0.2\n" ; - return( 0.2 ) ; - } - #print "tva_rate 0\n" ; - return( 0 ) ; -} - -sub tests_tva_rate { - ok( 0.196 == tva_rate( '2013_01_01' ), 'tva_rate: old 0.196' ) ; - ok( 0.196 == tva_rate( '2013_12_31' ), 'tva_rate: old 0.196' ) ; - ok( 0.2 == tva_rate( '2014_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2014_12_31' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_12_31' ), 'tva_rate: new 0.2' ) ; - return( 0 ) ; -} - - -sub tva_rate_str { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - return( '19,60\%' ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - return( '20\%' ) ; - } - #print "tva_rate 0\n" ; - return( '' ) ; -} - -sub tests_tva_rate_str { - ok( '19,60\%' eq tva_rate_str( '2013_01_01' ), 'tva_rate_str: old 0.196' ) ; - ok( '19,60\%' eq tva_rate_str( '2013_12_31' ), 'tva_rate_str: old 0.196' ) ; - ok( '20\%' eq tva_rate_str( '2014_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2014_12_31' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2050_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2050_12_31' ), 'tva_rate_str: new 0.2' ) ; - return( 0 ) ; -} - - -sub tva_line_one_button_for_the_software { - - my $A = shift ; - - if ( 'imapsync' eq $A->{Titre_de_l_objet} - or 'imapsync.exe' eq $A->{Titre_de_l_objet} - or 'imapsync source' eq $A->{Titre_de_l_objet} - or 'imapsync source code' eq $A->{Titre_de_l_objet} - - ) { - if ( - ( 'imapsync usage' eq $A->{Nom_Option_1} and 'individual' eq $A->{Valeur_Option_1} ) - or - ( 'France' eq $A->{Pays} ) - ) { - $A->{montant_HT_EUR_logi_ass} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_logi} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_logi_exo} = $A->{Montant2} ; - } - } - -} - -sub tva_line_one_button_for_the_support { - - my $A = shift ; - - if ( 'imapsync support' eq $A->{Titre_de_l_objet} ) { - if ( - ( 'imapsync usage' eq $A->{Nom_Option_1} and 'individual' eq $A->{Valeur_Option_1} ) - or - ( 'France' eq $A->{Pays} ) - or - ( '2013_02_19' gt $A->{date_aaaa_mm_jj} ) - ) - { - $A->{montant_HT_EUR_sup} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_sup} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_sup_exo} = $A->{Montant2} ; - } - } -} - - -sub software_price { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - return( 50 ) ; - } - return( 0 ) ; -} - - -sub tests_software_price { - ok( 50 == software_price( '2014_01_01' ), 'software_price: 2014_01_01 => 50 ' ) ; - ok( 0 == software_price( '2000_01_01' ), 'software_price: 2000_01_01 => 0' ) ; - return( 0 ) ; -} - - -sub tva_line_one_button_for_support_and_software_case_no_vat_number { - - my $A = shift ; - - $A->{Montant2_logi} = software_price( $A->{date_aaaa_mm_jj} ) ; - $A->{Montant2_supp} = $A->{Montant2} - $A->{Montant2_logi} ; - - if ( 'imapsync all' eq $A->{Titre_de_l_objet} ) { - if ( - ( 'usage' eq $A->{Nom_Option_2} and 'individual' eq $A->{Option_2_Valeur} ) - or - ( 'France' eq $A->{Pays} ) - ) - { - $A->{montant_HT_EUR_sup} = $A->{Montant2_supp} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_sup} = $A->{Montant2_supp} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - $A->{montant_HT_EUR_logi_ass} = $A->{Montant2_logi} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_logi} = $A->{Montant2_logi} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_logi_exo} = $A->{Montant2_logi} ; - $A->{montant_HT_EUR_sup_exo} = $A->{Montant2_supp} ; - } - } -} - - -sub tva_line { - - my $A = shift ; - - $A->{montant_HT_EUR_logi_exo} = $A->{montant_HT_EUR_logi_ass} = $A->{montant_TVA_EUR_logi} = 0 ; - $A->{montant_HT_EUR_sup} = $A->{montant_TVA_EUR_sup} = $A->{montant_HT_EUR_sup_exo} = 0 ; - - $A->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $A->{Date} ) ; - $A->{Montant2} = $A->{Montant2}/$usdeur if 'USD' eq $A->{Devise} ; - - tva_line_one_button_for_the_software( $A ) ; - tva_line_one_button_for_the_support( $A ) ; - tva_line_one_button_for_support_and_software_case_no_vat_number( $A ) ; - return( ) ; -} - - - -sub tva_stuff { - my $F = shift ; - - $F->{priceTTCusd} = '' ; - $F->{Hors_taxe} =~ s{,}{.} ; - - $F->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $F->{Date} ) ; - - if ( $F->{Devise} eq 'USD' ) { - $F->{priceTTCusd} = "(usd $F->{Hors_taxe})" ; - $F->{Hors_taxe} = ( $F->{Hors_taxe}/$usdeur ) ; - } - - if ( ( 'individual' eq $F->{clientTypeEN}) - or - ( 'France' eq $F->{Pays} ) - ) { - $F->{priceHT} = sprintf('%2.2f', $F->{Hors_taxe} / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) ) ; - $F->{tvaFR} = tva_rate_str( $F->{date_aaaa_mm_jj} ) ; - $F->{tvaEN} = '' ; - $F->{priceTVA} = sprintf('%2.2f', $F->{Hors_taxe} / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) * tva_rate( $F->{date_aaaa_mm_jj} ) ) ; - $F->{priceTTC} = sprintf('%2.2f', $F->{Hors_taxe}) ; - $F->{HTorTTC} = 'TTC' ; - $F->{messageTVAFR} = '' ; - $F->{messageTVAEN} = '' ; - }else{ - $F->{priceHT} = sprintf('%2.2f', $F->{Hors_taxe}) ; - $F->{tvaFR} = '' ; - $F->{tvaEN} = '' ; - $F->{priceTVA} = 'néant (none)' ; - $F->{priceTTC} = $F->{priceHT} ; - $F->{HTorTTC} = 'HT' ; - $F->{messageTVAFR} = 'Exonération de TVA, articles 259 et 262 du Code Général des Impôts'; - $F->{messageTVAEN} = '(VAT tax-exempt, articles 259 and 262 of French General Tax Code)'; - } - foreach my $price ( $F->{priceHT}, $F->{priceTVA}, $F->{priceTTC}, $F->{priceTTCusd} ) { - #print "[$price]\n" ; - $price =~ s{\.}{, } ; - } - return( ) ; -} - -sub client_type { - my $F = shift ; - - ( $F->{clientTypeEN}, $F->{clientTypeFR} ) = ( 'professional', 'professionnel' ) ; - - if ('imapsync usage' eq $F->{Nom_Option_1} and 'individual' eq $F->{Valeur_Option_1} ) { - $F->{clientTypeEN} = 'individual' ; - $F->{clientTypeFR} = 'individuel' ; - }elsif ('imapsync usage' eq $F->{Nom_Option_1} and 'professional' eq $F->{Valeur_Option_1} ) { - $F->{clientTypeEN} = 'professional' ; - $F->{clientTypeFR} = 'professionnel' ; - }elsif('usage' eq $F->{Nom_Option_2} and 'individual' eq $F->{Option_2_Valeur} ) { - $F->{clientTypeEN} = 'individual' ; - $F->{clientTypeFR} = 'individuel' ; - } - - return( ) ; -} - -sub build_address { - my $F = shift ; - - my $addr = " -=========================================================== -Nom $F->{Nom} -Adresse_1 $F->{Adresse_1} -Adresse_2_district_quartier $F->{Adresse_2_district_quartier} -Ville Code_postal $F->{Ville} $F->{Code_postal} -Etat_Province $F->{Etat_Province} -Pays $F->{Pays} -" ; - #print $addr ; - - my @address ; - $F->{Nom} = '' if ( $F->{Nom} =~ m/^\s+$/ ) ; - my( $Nom1, $Nom2 ) = cut( $F->{Nom}, 42 ) ; - push( @address, $Nom1 ) if $Nom1 ; - #push( @address, $Nom2 ) if $Nom2 ; - push( @address, $F->{Adresse_1} ) if $F->{Adresse_1} ; - push( @address, $F->{Adresse_2_district_quartier} ) if $F->{Adresse_2_district_quartier} ; - push( @address, "$F->{Ville} $F->{Code_postal}" ) if ( $F->{Ville} or $F->{Code_postal} ) ; - push( @address, $F->{Etat_Province} ) if $F->{Etat_Province} ; - push( @address, $F->{Pays}, ) if $F->{Pays} ; - - - $F->{clientAdrA} = shift( @address ) || '' ; - $F->{clientAdrB} = shift( @address ) || '' ; - $F->{clientAdrC} = shift( @address ) || '' ; - $F->{clientAdrD} = shift( @address ) || '' ; - $F->{clientAdrE} = shift( @address ) || '' ; - $F->{clientAdrF} = shift( @address ) || '' ; - - return( ) ; -} - - -sub cut { - my $string = shift ; - my $offset = shift ; - return( $string, '' ) if length( $string ) < $offset ; - my $first = substr( $string, 0, $offset ) ; - my $last = substr( $string, $offset ) ; - - return( $first, $last ) ; -} - -sub tests_cut { - my( $aa, $bb ) = cut("123456789", 4 ) ; - ok( '1234' eq $aa, 'cut 123456789 4 => first 1234' ) ; - ok( '56789' eq $bb, 'cut 123456789 4 => last 56789' ) ; -} diff --git a/W/paypal_reply/paypal_bilan_1.77 b/W/paypal_reply/paypal_bilan_1.77 deleted file mode 100755 index 6831523..0000000 --- a/W/paypal_reply/paypal_bilan_1.77 +++ /dev/null @@ -1,1417 +0,0 @@ -#!/usr/bin/perl - -# $Id: paypal_bilan,v 1.77 2014/05/03 02:38:05 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 $rcs = '$Id: paypal_bilan,v 1.77 2014/05/03 02:38:05 gilles Exp gilles $ ' ; -$rcs =~ m/,v (\d+\.\d+)/ ; -my $VERSION = ($1) ? $1: "UNKNOWN" ; - - -my $total_usd_received = 0 ; -my $total_usd_invoice = 0 ; -my $total_HT_EUR_logi_exo = 0 ; -my $total_HT_EUR_logi_ass = 0 ; -my $total_TVA_EUR_logi = 0 ; - -my $total_HT_EUR_sup = 0 ; -my $total_TVA_EUR_sup = 0 ; -my $total_HT_EUR_sup_exo = 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 $nb_invoice_canceled = 0 ; - -my ( $tests, $testeur ) ; -my $dry ; -my $debug ; -my $debug_csv ; -my $debug_dev ; -my $debug_invoice ; -my $debug_invoice_utf8 ; -my $debug_email; - -my $first_invoice = 1 ; -my $print_details = '' ; -my $bnc = '' ; -my $exportbnc = '' ; - -my $usdeur = 1.2981 ; -my $invoices ; -my %invoice_refund ; -my %invoice_canceled ; -my %invoice_suspended ; -my $write_invoices = 0 ; -my $avoid_numbers ; - -my $dir_invoices ; - -my $option_ret = GetOptions ( - 'tests' => \$tests, - 'dry' => \$dry, - 'debug' => \$debug, - 'debug_csv' => \$debug_csv, - 'debug_dev' => \$debug_dev, - 'debug_invoice' => \$debug_invoice, - 'debug_invoice_utf8' => \$debug_invoice_utf8, - 'debug_email' => \$debug_email, - - 'first_invoice=i' => \$first_invoice, - 'print_details|details' => \$print_details, - 'bnc' => \$bnc, - 'exportbnc=s' => \$exportbnc, - 'usdeur=f' => \$usdeur, - 'invoices=s' => \$invoices, - 'write_invoices!' => \$write_invoices, - 'dir_invoices=s' => \$dir_invoices, - 'avoid_numbers=s' => \$avoid_numbers, -); - -$dir_invoices ||= '/g/var/paypal_invoices' ; -if ( $write_invoices and not -d "$dir_invoices" ) { - $debug and print "mkdir $dir_invoices\n" ; - $dry or mkdir( $dir_invoices ) or die ; -} - - - -$debug and print "dir_invoices = $dir_invoices\n" ; - -$testeur = Test::More->builder ; -$testeur->no_ending(1) ; - -if ( $tests ) { - $testeur->no_ending( 0 ) ; - exit( tests( ) ) ; -} - - -my @files = @ARGV ; -my %action_invoice ; - -my %invoice_paypal ; - -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" ; - -my @actions ; - -foreach my $file ( @files ) { - - my @actions_file = parse_file( $file ) ; - push( @actions, @actions_file ) ; -} - -foreach my $action (@actions) { - # compute_line() adds $action->{ 'invoice' } if needed - compute_line( $action ) ; - - # index by invoice number - $action_invoice{ $action->{ 'invoice' } } = $action ; -} -delete $action_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_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 }++ ; - build_invoice( $invoice ) if ( $debug_invoice or $debug_invoice_utf8 ) ; - }elsif( not ( $invoice_canceled{ $invoice } or $invoice_refund{ $invoice } ) ) { - $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 ) ; - -my @invoice_canceled = sort { $a <=> $b } keys( %invoice_canceled ) ; -my @invoice_suspended = sort { $a <=> $b } keys( %invoice_suspended ) ; -my @invoice_refund = sort { $a <=> $b } keys( %invoice_refund ) ; - - -print( "\n", "=" x 60, "\n" ) ; - -my $total_usd_paypal_cost ; -$total_usd_paypal_cost = sprintf('%2.2f', $total_usd_invoice - $total_usd_received ) ; -print "USD received $total_usd_received\n" ; -print "USD invoice $total_usd_invoice\n" ; -print "USD costs $total_usd_paypal_cost\n" ; - -my $total_eur_invoice_from_usd ; -my $total_eur_received_from_usd ; -my $total_eur_paypal_cost_from_usd ; - -# au 30 nov 2010 http://fr.finance.yahoo.com/devises/convertisseur/#from=EUR;to=USD;amt=1 -$total_eur_invoice_from_usd = sprintf('%2.2f', $total_usd_invoice / $usdeur ) ; -$total_eur_received_from_usd = sprintf('%2.2f', $total_usd_received / $usdeur ) ; -$total_eur_paypal_cost_from_usd = sprintf('%2.2f', $total_usd_paypal_cost / $usdeur ) ; - -# EUR -$total_eur_received = sprintf('%2.2f', $total_eur_received) ; -$total_eur_invoice = sprintf('%2.2f', $total_eur_invoice) ; -print "EUR invoice from USD $total_eur_invoice_from_usd\n" ; -print "EUR received from EUR $total_eur_received\n" ; -print "EUR invoice from EUR $total_eur_invoice\n" ; - -my $total_eur_invoice_from_eur_usd = $total_eur_invoice_from_usd + $total_eur_invoice ; -my $total_eur_received_from_eur_usd = $total_eur_received_from_usd + $total_eur_received ; -my $total_eur_paypal_cost = $total_eur_invoice - $total_eur_received + $total_eur_paypal_cost_from_usd ; - - -$total_HT_EUR_logi_exo = sprintf('%2.2f', $total_HT_EUR_logi_exo) ; -$total_HT_EUR_logi_ass = sprintf('%2.2f', $total_HT_EUR_logi_ass) ; -$total_TVA_EUR_logi = sprintf('%2.2f', $total_TVA_EUR_logi) ; - -$total_HT_EUR_sup = sprintf('%2.2f', $total_HT_EUR_sup) ; -$total_TVA_EUR_sup = sprintf('%2.2f', $total_TVA_EUR_sup) ; -$total_HT_EUR_sup_exo = sprintf('%2.2f', $total_HT_EUR_sup_exo) ; - -$total_eur_invoice_from_eur_usd = sprintf('%2.2f', $total_eur_invoice_from_eur_usd) ; -$total_eur_paypal_cost = sprintf('%2.2f', $total_eur_paypal_cost) ; - -print( "---- USD + EUR ----\n" ) ; -print "EUR total invoice $total_eur_invoice_from_eur_usd\n" ; -print "EUR total received $total_eur_received_from_eur_usd\n" ; -print "EUR total paypal cost $total_eur_paypal_cost\n" ; -print ; -print( "---- Assujeti TVA ----\n" ) ; -print "EUR total HT licen assuj $total_HT_EUR_logi_ass (autres operations imposables)\n" ; -#print "EUR total TVA licen assuj $total_TVA_EUR_logi\n" ; -print "EUR total HT supp assuj $total_HT_EUR_sup (ventes, prestations)\n" ; -#print "EUR total TVA supp assuj $total_TVA_EUR_sup\n" ; - -print( "---- Exonere TVA ----\n" ) ; -print "EUR total HT licen exo $total_HT_EUR_logi_exo (autres operations NON imposables)\n" ; -print "EUR total HT suppo exo $total_HT_EUR_sup_exo (autres operations NON imposables)\n" ; - -print( "---- Invoices ----\n" ) ; - -print "Nb invoice $nb_invoice ( from $first_invoice_paypal to $last_invoice )\n" ; -print "Nb invoice canceled ($nb_invoice_canceled) @invoice_canceled\n" ; -print "Nb invoice suspended ($nb_invoice_suspended) @invoice_suspended\n" ; -print "Nb invoice refund ($nb_invoice_refund) @invoice_refund\n" ; -print "Nb invoice sent $nb_invoice_sent\n" ; -print "Have to send invoices @invoice_not_sent\n" if ( @invoice_not_sent ) ; - -my $total_eur2 = $total_HT_EUR_logi_exo + $total_HT_EUR_logi_ass + $total_TVA_EUR_logi + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo ; -$total_eur2 = sprintf('%2.2f', $total_eur2) ; -print "$total_eur_invoice_from_eur_usd != $total_eur2 = $total_HT_EUR_logi_exo + $total_HT_EUR_logi_ass + $total_TVA_EUR_logi + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo\n" -if ( $total_eur_invoice_from_eur_usd != $total_eur2 ) ; - -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 invoice_00000 { - my $invoice = shift ; - - return( sprintf( "%04d", $invoice ) ) ; -} - -sub tests_invoice_00000 { - - ok( '0000' eq invoice_00000( 0 ), 'invoice_00000: 0 -> 0000' ) ; - ok( '0147' eq invoice_00000( 147 ), 'invoice_00000: 147 -> 0147' ) ; - ok( '99999' eq invoice_00000( 99999 ), 'invoice_00000: 99999 -> 99999' ) ; -} - -sub tests_next_invoice { - ok( 1 == next_invoice( ), 'next_invoice: 1' ) ; - ok( 2 == next_invoice( ), 'next_invoice: 2' ) ; - @avoid_numbers{ (3, 4, 6, 8 ) } = ( ) ; - ok( 5 == next_invoice( ), 'next_invoice: 7' ) ; - ok( 7 == next_invoice( ), 'next_invoice: 8' ) ; - ok( 9 == next_invoice( ), 'next_invoice: 9' ) ; - %invoice_paypal = () ; - $first_invoice = 7 ; - ok( 7 == next_invoice( ), 'next_invoice: 7' ) ; -} - - -sub tests_exportbnc { - ok( 1 == 1, '1 == 1' ) ; - -} - - - -sub tests { - tests_next_invoice( ) ; - tests_cut( ) ; - tests_invoice_00000( ) ; - #tests_exportbnc( ) ; - tests_tva_rate( ) ; - tests_tva_rate_str( ) ; - tests_software_price( ) ; -} - -sub compute_line_debug { - - my $A = shift ; - - return( "#" x 78, "\n", - "[$A->{Date}] [$A->{Heure}] [$A->{Fuseau_horaire}] [$A->{Nom}] [$A->{Type}] [$A->{Etat}] ", - "[$A->{Devise}] [$A->{Hors_taxe_paypal}] [$A->{Montant}] [$A->{Numero_davis_de_reception}] [$A->{Solde}] [$A->{Impact_sur_le_solde}] ", - "[$A->{Pays}] [$A->{Nom_Option_1}] [$A->{Valeur_Option_1}] [$A->{Titre_de_l_objet}]\n" ) ; - -} - -sub bnc_first_line { - my $A = shift ; - $A->{MontantEUR} = $A->{Montant} ; - $A->{MontantEUR} = sprintf( "%.4f", $A->{Montant}/$usdeur ) if ($A->{Devise} eq 'USD') ; - return( "\n", "=" x 60, "\n", - "[$A->{Date}] [$A->{Nom}] [$A->{Type}] [$A->{Etat}] [$A->{Devise}] ", - "[$A->{Hors_taxe_paypal}] [$A->{Montant}] [EUR $A->{MontantEUR}] [$A->{Impact_sur_le_solde}]\n", - "[$A->{Pays}] [$A->{Nom_Option_1}] [$A->{Valeur_Option_1}] [$A->{Titre_de_l_objet}]\n" ) ; -} - -sub details { - - my $A = shift ; - - return( "[$A->{invoice}] [$A->{Date}] [$A->{Heure}] [$A->{Fuseau_horaire}] ", - "[$A->{Nom}] [$A->{Type}] [$A->{Etat}] [$A->{Devise}] [$A->{Montant}] ", - "[$A->{Numero_davis_de_reception}] [$A->{Solde}] [$A->{Impact_sur_le_solde}]\n" ) ; - -} - -sub paiement_usd_termine{ - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'USD' eq $A->{Devise} - and ( 'Terminé' eq $A->{Etat} or 'Compensé' eq $A->{Etat} ) - ) { - $A->{Montant} =~tr/,/./; - $A->{Montant2} = $A->{Hors_taxe_paypal} ; - $total_usd_received += $A->{Montant} ; - $total_usd_invoice += $A->{Montant2} ; - tva_line( $A ) ; - $total_HT_EUR_logi_exo += $A->{montant_HT_EUR_logi_exo} ; - $total_HT_EUR_logi_ass += $A->{montant_HT_EUR_logi_ass} ; - $total_TVA_EUR_logi += $A->{montant_TVA_EUR_logi} ; - - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_termine { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and ( 'Terminé' eq $A->{Etat} or 'Compensé' eq $A->{Etat} ) - ) { - $A->{Montant} =~tr/,/./; - $A->{Montant2} = $A->{Hors_taxe_paypal} ; - $total_eur_received += $A->{Montant} ; - $total_eur_invoice += $A->{Montant2} ; - tva_line( $A ) ; - $total_HT_EUR_logi_exo += $A->{montant_HT_EUR_logi_exo} ; - $total_HT_EUR_logi_ass += $A->{montant_HT_EUR_logi_ass} ; - $total_TVA_EUR_logi += $A->{montant_TVA_EUR_logi} ; - $total_HT_EUR_sup += $A->{montant_HT_EUR_sup} ; - $total_TVA_EUR_sup += $A->{montant_TVA_EUR_sup} ; - $total_HT_EUR_sup_exo += $A->{montant_HT_EUR_sup_exo} ; - - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_rembourse { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Remboursé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_refund++; - $invoice_refund{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_annule { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Annulé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_canceled++; - $invoice_canceled{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_suspendu { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Suspendu' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_suspended++; - $invoice_suspended{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_non_compense { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Non compensé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - - - -sub compute_line { - - my $action = shift ; - my %action = %$action ; - my $A ; - - @{$A}{ qw( - 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 Nom_Option_2 Option_2_Valeur - Impact_sur_le_solde - ) } - = @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", 'Nom Option 2', 'Option 2 Valeur', - 'Impact sur le solde') } ; - - ( $A->{Etat} ) = @action{ ( 'Etat' ) } || @action{ ( 'État' ) } ; - ( $A->{Hors_taxe_paypal} ) = @action{ ( 'Hors taxe' ) } || @action{ ( 'Avant commission' ) } ; - $A->{Impact_sur_le_solde} ||= '' ; - $A->{invoice} = 'NONE' ; - $A->{Montant} = $action->{ 'Net' } if not defined $A->{Montant}; - - $debug and print( compute_line_debug( $A ) ) ; - - $A->{Montant} =~ s/[^0-9-,.]//g ; - $A->{Montant} =~ s/,/./g ; - $A->{Hors_taxe_paypal} =~ s/,/./g ; - - $bnc and print( bnc_first_line( $A ) ) ; - paiement_usd_termine( $A ) ; - paiement_eur_termine( $A ) ; - paiement_eur_rembourse( $A ) ; - paiement_eur_annule( $A ) ; - paiement_eur_suspendu( $A ) ; - paiement_eur_non_compense( $A ) ; - $bnc and print( BNC_output( $A->{invoice}, FR_flag( $A->{Pays} ), - IND_flag( $A->{Nom_Option_1}, $A->{Valeur_Option_1} ), - SUPPORT_flag( $A->{Titre_de_l_objet} ), - $A->{Nom}, $A->{Date}, $A->{MontantEUR}, $A->{Devise}, - $A->{Titre_de_l_objet}, $A->{Impact_sur_le_solde}, $A->{Type} ) ) ; - - $action->{ 'invoice' } = $A->{invoice} ; -} - -sub BNC_output { -# FE 1359 FR IND imapsync Bougon Edouard -# [12/01/2012] FR IND 28.73 EUR - my( $invoice, $FR_flag, $IND_flag, $SUPPORT_flag, - $Nom, $Date, $MontantEUR, $Devise, $Titre_de_l_objet, $Impact_sur_le_solde, $Type ) = @_ ; - - my $BNC_output ; - - if ( 'NONE' eq $invoice ) { - $BNC_output = "[$Date] $MontantEUR $Devise $Nom $Titre_de_l_objet [$Impact_sur_le_solde] [$Type]\n" ; - }else{ - $BNC_output = - "FE $invoice$FR_flag$IND_flag imapsync$SUPPORT_flag $Nom\n" - . "[$Date]$FR_flag$IND_flag $MontantEUR $Devise \n" ; - } - return( $BNC_output ) ; -} - -sub SUPPORT_flag { - my $Titre_de_l_objet = shift ; - my $SUPPORT_flag = '' ; - $SUPPORT_flag = ' support' if ( 'imapsync support' eq $Titre_de_l_objet ) ; -} - -sub IND_flag { - my( $Nom_Option_1, $Valeur_Option_1 ) = @_ ; - my $IND_flag = '' ; - $IND_flag = ' IND' if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) ; - return( $IND_flag ) ; -} - -sub FR_flag { - my $Pays = shift ; - my $FR_flag = '' ; - - $FR_flag = ' FR' if $Pays eq 'France' ; - return( $FR_flag ) ; -} - -sub escape_for_tex { - - my $F = shift ; - foreach my $str ( - $F->{De_l_adresse_email}, - $F->{Nom}, - $F->{clientAdrA}, - $F->{clientAdrB}, - $F->{clientAdrC}, - $F->{clientAdrD}, - $F->{clientAdrE}, - $F->{clientAdrF}, - ) { - $str =~ s{#}{\\#}g ; - $str =~ s{_}{\\_}g ; - $str =~ s{&}{\\&}g ; - } -} - -sub build_invoice { - my $invoice = shift ; - - return if ! $invoice ; - - my $F ; - $F->{invoice} = $invoice ; - - my $action = $action_invoice{ $F->{invoice} } ; - #print Data::Dumper->Dump( [$action] ) ; - - @{$F}{ qw( 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 - Nom_Option_2 Option_2_Valeur ) } - = @{$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', - 'Nom Option 2', 'Option 2 Valeur' ) } ; - - $F->{Etat_Province} = $action->{'Etat/Province/Région/Comté/Territoire/Préfecture/République'} - || $action->{'État/Province/Région/Comté/Territoire/Préfecture/République'} - || '' ; - $F->{Hors_taxe} = $action->{'Hors taxe'} || $action->{'Avant commission'} ; - $F->{Hors_taxe_num} = $F->{Hors_taxe} ; - $F->{Hors_taxe_num} =~ s{,}{.} ; - if ($F->{Hors_taxe_num} > 100) { - print "invoice $F->{invoice} $F->{Hors_taxe_num} > 100\n" ; - #return() ; - } - - build_email_message( $F ) ; - $debug_email and print( "\n", $F->{email_message_header}, $F->{email_message_body} ) ; - - if ( $write_invoices and ! invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ) ) { - write_email_message( $dir_invoices, $F->{invoice}, - $F->{email_message_header}, $F->{email_message_body}, - $F->{De_l_adresse_email} ) ; - write_csv_info( $dir_invoices, $F->{invoice}, $F->{file_csv}, $F->{line_number}, $F->{line_csv} ) ; - } - - - build_address( $F ) ; - escape_for_tex( $F ) ; - client_type( $F ) ; - object_type( $F ) ; - description_stuff( $F ) ; - tva_stuff( $F ) ; - $F->{quantity} = '1' ; - - download_urls( $F ) ; - ( $F->{Nom1} ) = cut( $F->{Nom}, 42 ) ; - $F->{clientVAT} = '' ; - - if ( ( 'VAT if professional in Europe' eq $F->{Nom_Option_2} ) and $F->{Option_2_Valeur} ) { - $F->{clientVAT} = $F->{Option_2_Valeur} ; - } - - my $tex_variables = qq{ -%% Begin input from paypal_bilan $VERSION -\\providecommand{\\invoiceNumber}{$F->{invoice}} -\\providecommand{\\clientName}{$F->{Nom1}} -\\providecommand{\\clientEmail}{$F->{De_l_adresse_email}} -\\providecommand{\\clientAdrA}{$F->{clientAdrA}} -\\providecommand{\\clientAdrB}{$F->{clientAdrB}} -\\providecommand{\\clientAdrC}{$F->{clientAdrC}} -\\providecommand{\\clientAdrD}{$F->{clientAdrD}} -\\providecommand{\\clientAdrE}{$F->{clientAdrE}} -\\providecommand{\\clientAdrF}{$F->{clientAdrF}} -\\providecommand{\\clientVAT}{$F->{clientVAT}} -\\providecommand{\\invoiceDate}{$F->{Date}} -\\providecommand{\\invoiceHour}{$F->{Heure}} - -\\providecommand{\\descriptionFR}{$F->{descriptionFR}} -\\providecommand{\\descriptionEN}{$F->{descriptionEN}} -\\providecommand{\\descriptionBFR}{$F->{descriptionBFR}} -\\providecommand{\\descriptionBEN}{$F->{descriptionBEN}} -\\providecommand{\\usageFR}{$F->{usageFR}} -\\providecommand{\\usageEN}{$F->{usageEN}} -\\providecommand{\\quantity}{$F->{quantity}} -\\providecommand{\\quantityB}{$F->{quantityB}} - -\\providecommand{\\priceHT}{$F->{priceHT}} -\\providecommand{\\priceBHT}{$F->{priceBHT}} -\\providecommand{\\priceZHT}{$F->{priceZHT}} -\\providecommand{\\tvaFR}{$F->{tvaFR}} -\\providecommand{\\priceZTVA}{$F->{priceZTVA}} -\\providecommand{\\HTorTTC}{$F->{HTorTTC}} -\\providecommand{\\priceZTTC}{$F->{priceZTTC}} -\\providecommand{\\messageTVAFR}{$F->{messageTVAFR}} -\\providecommand{\\messageTVAEN}{$F->{messageTVAEN}} -\\providecommand{\\urlSrc}{\\url{$F->{urlSrc}}} -%% End input from paypal_bilan -} ; - - my $tex_variables_utf8 = to_utf8( { -string => $tex_variables, -charset => 'ISO-8859-1' } ) ; - - $debug_invoice_utf8 and print $tex_variables_utf8 ; - $debug_invoice and print $tex_variables ; - - #print "$F->{invoice} ", invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ), "\n" ; - if ( $write_invoices and ! invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ) ) { - write_tex_variables_file( $dir_invoices, $F->{invoice}, $F->{Date}, $tex_variables_utf8 ) ; - } - -} - -sub description_stuff { - my $F = shift ; - - $F->{descriptionFR} = $F->{descriptionEN} = '' ; - $F->{descriptionBFR} = $F->{descriptionBEN} = '' ; - $F->{quantityB} = '' ; - $F->{usageFR} = $F->{usageEN} = '' ; - - - if ( 'software' eq $F->{object_type} ) { - $F->{descriptionFR} = 'Logiciel imapsync. TOUS droits cédés, autorisés.' ; - $F->{descriptionEN} = '(Imapsync software. ALL rights conceded, allowed.)' ; - } - - if ( 'professional' eq $F->{clientTypeEN} - and 'software' eq $F->{object_type} ) { - $F->{usageFR} = 'Usage à titre professionnel.' ; - $F->{usageEN} = '(professional usage.)' ; - } - - if ( 'individual' eq $F->{clientTypeEN} - and 'software' eq $F->{object_type} ) { - $F->{usageFR} = 'Usage à titre individuel.' ; - $F->{usageEN} = '(individual usage.)' ; - } - - if ( 'support' eq $F->{object_type} ) { - $F->{usageFR} = '' ; - $F->{usageEN} = '' ; - $F->{descriptionFR} = 'Support sur le logiciel imapsync.' ; - $F->{descriptionEN} = '(Imapsync support.)' ; - } - - if ( 'professional' eq $F->{clientTypeEN} - and 'software + support' eq $F->{object_type} ) { - $F->{usageFR} = 'Usage à titre professionnel.' ; - $F->{usageEN} = '(professional usage.)' ; - $F->{descriptionFR} = 'Logiciel imapsync. TOUS droits cédés, autorisés.' ; - $F->{descriptionEN} = '(Imapsync software. ALL rights conceded, allowed.)' ; - $F->{descriptionBFR} = 'Support sur le logiciel imapsync.' ; - $F->{descriptionBEN} = '(Imapsync support.)' ; - $F->{quantityB} = '1' ; - } -} - - - -sub object_type { - my $F = shift ; - - $F->{object_type} = '' ; - - if ( 'imapsync' eq $F->{Titre_de_l_objet} - or 'imapsync.exe' eq $F->{Titre_de_l_objet} - or 'imapsync source' eq $F->{Titre_de_l_objet} - or 'imapsync source code' eq $F->{Titre_de_l_objet} - ) { - $F->{object_type} = 'software' ; - }elsif ( 'imapsync support' eq $F->{Titre_de_l_objet} ) { - $F->{object_type} = 'support' ; - }elsif ( ( 'imapsync all' eq $F->{Titre_de_l_objet} ) - and ( 'software only' eq $F->{Valeur_Option_1} ) ) { - $F->{object_type} = 'software' ; - }elsif ( ( 'imapsync all' eq $F->{Titre_de_l_objet} ) - and ( 'software + support' eq $F->{Valeur_Option_1} ) ) { - $F->{object_type} = 'software + support' ; - } -} - -sub build_email_message { - - my $F = shift ; - - object_type( $F ) ; - my $invoice = $F->{invoice} ; - - my $message_header = qq{X-imapsync: invoice $invoice for imapsync $F->{object_type} -From: Gilles LAMIRAL -Bcc: gilles\@lamiral.info -Subject: [imapsync invoice] $invoice ($F->{Hors_taxe_num} EUR on $F->{Date}) for imapsync $F->{object_type}. -Disposition-Notification-To: Gilles LAMIRAL -} ; - - - my $message_body = qq{ -Hello $F->{Nom}, - -First of all, I'm sorry for the delay in getting back to you. - -Last imapsync release is available from the page -http://imapsync.lamiral.info/paypal_return.shtml - -You'll find in the attachment the invoice of imapsync -$F->{object_type} you bought and paid (dd/mm/yyyy $F->{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 $F->{object_type}. - -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. -} ; - - $F->{email_message_header} = $message_header ; - $F->{email_message_body} = $message_body ; - return( ) ; - -} - -sub write_csv_info { - - my( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - $debug and print "Writing $dir_invoices/$invoice_00000/csv_info.txt\n" ; - $dry and return( ) ; - - open( CSVINFO, "> $dir_invoices/$invoice_00000/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 ) = @_ ; - my $invoice_00000 = invoice_00000( $invoice ) ; - return( 1 ) if ( -f "$dir_invoices/$invoice_00000/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' }); - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $dry and return( ) ; - - open( HEADER, "> $dir_invoices/$invoice_00000/facture_message_header.txt") or die ; - print HEADER $message_header ; - close( HEADER ) ; - - open( BODY, "> $dir_invoices/$invoice_00000/facture_message_body.txt") or die ; - print BODY $message_body_utf8 ; - close( BODY ) ; - - open( ADDRESS, "> $dir_invoices/$invoice_00000/email_address.txt") or die ; - print ADDRESS "$email_address\n" ; - close( ADDRESS ) ; -} - - -sub write_tex_variables_file { - my ( $dir_invoices, $invoice, $Date, $tex_variables_utf8 ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $debug and print "Writing imapsync_var.tex $dir_invoices/$invoice_00000/imapsync_var.tex\n" ; - $dry and return( ) ; - - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var.tex") or die ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - - if ( ! -f "$dir_invoices/$invoice_00000/imapsync_var_manual.tex" ) { - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var_manual.tex") or die ; - print FILE "%% $0 created this file -%% Can be used to override imapsync_var.tex definitions\n" ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - } - -} - -sub download_urls { - my $F = shift ; - - $F->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $F->{Date} ) ; - - if ( '2014_04_13' le $F->{date_aaaa_mm_jj} - and ( - ( 'software' eq $F->{object_type} ) - or - ( 'software + support' eq $F->{object_type} ) - ) - ) { - $F->{urlSrc} = 'http://imapsync.lamiral.info/paypal_return.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - - if ('2011_05_01' le $F->{date_aaaa_mm_jj} - and 'software' eq $F->{object_type} ) { - $F->{urlSrc} = 'http://ks.lamiral.info/imapsync/paypal_return.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - - if ('2011_05_01' le $F->{date_aaaa_mm_jj} - and 'support' eq $F->{object_type} ) { - $F->{urlSrc} = 'http://ks.lamiral.info/imapsync/paypal_return_support.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - - if ('2011_03_24' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/prj/imapsync/paypal_return.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - if ('2011_02_21' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2011_02_21/OUMbo7/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2011_02_21/rHSVNs/' ; - return( ) ; - } - if ('2011_01_18' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2011_01_18/zPRRNt/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2011_01_18/FO1QzG/' ; - return( ) ; - } - if ('2011_01_18' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2010_11_28/SiNdlZ/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2010_11_28/R3ZAyr/' ; - return( ) ; - } - $F->{urlSrc} = 'http://www.linux-france.org/depot/2010_11_08/X2PWMe/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2010_11_08/ZZ7zSc/' ; - return( ) ; -} - -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_rate { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - #return( 0 ) ; - return( 0.196 ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - #print "tva_rate 0.2\n" ; - return( 0.2 ) ; - } - #print "tva_rate 0\n" ; - return( 0 ) ; -} - -sub tests_tva_rate { - ok( 0.196 == tva_rate( '2013_01_01' ), 'tva_rate: old 0.196' ) ; - ok( 0.196 == tva_rate( '2013_12_31' ), 'tva_rate: old 0.196' ) ; - ok( 0.2 == tva_rate( '2014_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2014_12_31' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_12_31' ), 'tva_rate: new 0.2' ) ; - return( 0 ) ; -} - - -sub tva_rate_str { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - return( '19,60\%' ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - return( '20\%' ) ; - } - #print "tva_rate 0\n" ; - return( '' ) ; -} - -sub tests_tva_rate_str { - ok( '19,60\%' eq tva_rate_str( '2013_01_01' ), 'tva_rate_str: old 0.196' ) ; - ok( '19,60\%' eq tva_rate_str( '2013_12_31' ), 'tva_rate_str: old 0.196' ) ; - ok( '20\%' eq tva_rate_str( '2014_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2014_12_31' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2050_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2050_12_31' ), 'tva_rate_str: new 0.2' ) ; - return( 0 ) ; -} - - -sub tva_line_one_button_for_the_software { - - my $A = shift ; - - if ( 'imapsync' eq $A->{Titre_de_l_objet} - or 'imapsync.exe' eq $A->{Titre_de_l_objet} - or 'imapsync source' eq $A->{Titre_de_l_objet} - or 'imapsync source code' eq $A->{Titre_de_l_objet} - - ) { - if ( - ( 'imapsync usage' eq $A->{Nom_Option_1} and 'individual' eq $A->{Valeur_Option_1} ) - or - ( 'France' eq $A->{Pays} ) - ) { - $A->{montant_HT_EUR_logi_ass} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_logi} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_logi_exo} = $A->{Montant2} ; - } - } - -} - -sub tva_line_one_button_for_the_support { - - my $A = shift ; - - if ( 'imapsync support' eq $A->{Titre_de_l_objet} ) { - if ( - ( 'imapsync usage' eq $A->{Nom_Option_1} and 'individual' eq $A->{Valeur_Option_1} ) - or - ( 'France' eq $A->{Pays} ) - or - ( '2013_02_19' gt $A->{date_aaaa_mm_jj} ) - ) - { - $A->{montant_HT_EUR_sup} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_sup} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_sup_exo} = $A->{Montant2} ; - } - } -} - - -sub software_price { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - return( 50 ) ; - } - return( 0 ) ; -} - - -sub tests_software_price { - ok( 50 == software_price( '2014_01_01' ), 'software_price: 2014_01_01 => 50 ' ) ; - ok( 0 == software_price( '2000_01_01' ), 'software_price: 2000_01_01 => 0' ) ; - return( 0 ) ; -} - - -sub tva_line_one_button_for_support_and_software_case_no_vat_number { - - my $A = shift ; - - $A->{Montant2_logi} = software_price( $A->{date_aaaa_mm_jj} ) ; - $A->{Montant2_supp} = $A->{Montant2} - $A->{Montant2_logi} ; - - if ( 'imapsync all' eq $A->{Titre_de_l_objet} ) { - if ( - ( 'usage' eq $A->{Nom_Option_2} and 'individual' eq $A->{Option_2_Valeur} ) - or - ( 'France' eq $A->{Pays} ) - ) - { - $A->{montant_HT_EUR_sup} = $A->{Montant2_supp} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_sup} = $A->{Montant2_supp} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - $A->{montant_HT_EUR_logi_ass} = $A->{Montant2_logi} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_logi} = $A->{Montant2_logi} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_logi_exo} = $A->{Montant2_logi} ; - $A->{montant_HT_EUR_sup_exo} = $A->{Montant2_supp} ; - } - } -} - - -sub tva_line { - - my $A = shift ; - - $A->{montant_HT_EUR_logi_exo} = $A->{montant_HT_EUR_logi_ass} = $A->{montant_TVA_EUR_logi} = 0 ; - $A->{montant_HT_EUR_sup} = $A->{montant_TVA_EUR_sup} = $A->{montant_HT_EUR_sup_exo} = 0 ; - - $A->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $A->{Date} ) ; - $A->{Montant2} = $A->{Montant2}/$usdeur if 'USD' eq $A->{Devise} ; - - tva_line_one_button_for_the_software( $A ) ; - tva_line_one_button_for_the_support( $A ) ; - tva_line_one_button_for_support_and_software_case_no_vat_number( $A ) ; - return( ) ; -} - - -sub tva_stuff_one_button_for_support_xor_software { - - my $F = shift ; - - if ( not ( 'software' eq $F->{object_type} - or 'support' eq $F->{object_type} - ) ) { - return( ) ; - } - - if ( ( 'individual' eq $F->{clientTypeEN}) - or - ( 'France' eq $F->{Pays} ) - ) { - $F->{priceHT} = sprintf('%2.2f', $F->{Hors_taxe} / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) ) ; - $F->{priceBHT} = '' ; - $F->{priceZHT} = $F->{priceHT} ; - $F->{tvaFR} = tva_rate_str( $F->{date_aaaa_mm_jj} ) ; - $F->{priceZTVA} = sprintf('%2.2f', $F->{Hors_taxe} / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) * tva_rate( $F->{date_aaaa_mm_jj} ) ) ; - $F->{priceZTTC} = sprintf('%2.2f', $F->{Hors_taxe}) ; - $F->{HTorTTC} = 'TTC' ; - $F->{messageTVAFR} = '' ; - $F->{messageTVAEN} = '' ; - }else{ - $F->{priceHT} = sprintf('%2.2f', $F->{Hors_taxe}) ; - $F->{priceBHT} = '' ; - $F->{priceZHT} = $F->{priceHT} ; - $F->{tvaFR} = '' ; - $F->{priceZTVA} = 'néant (none)' ; - $F->{priceZTTC} = $F->{priceHT} ; - $F->{HTorTTC} = 'HT' ; - $F->{messageTVAFR} = 'Exonération de TVA, articles 259 et 262 du Code Général des Impôts'; - $F->{messageTVAEN} = '(VAT tax-exempt, articles 259 and 262 of French General Tax Code)'; - } - - foreach my $price ( $F->{priceHT}, $F->{priceBHT}, $F->{priceZHT}, - $F->{priceZTVA}, $F->{priceZTTC} ) { - $price =~ s{\.}{, } ; - } - - return( ) ; -} - -sub tva_stuff_one_button_for_support_and_software { - - my $F = shift ; - - if ( not ( 'software + support' eq $F->{object_type} ) ) { - return( ) ; - } - - my $amountZ = $F->{Hors_taxe} ; - my $amountA = software_price( $F->{date_aaaa_mm_jj} ) ; - my $amountB = $amountZ - $amountA ; - - if ( ( 'individual' eq $F->{clientTypeEN}) - or - ( 'France' eq $F->{Pays} ) - ) { - $F->{priceHT} = sprintf('%2.2f', $amountA / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) ) ; - $F->{priceBHT} = sprintf('%2.2f', $amountB / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) ) ; - $F->{priceZHT} = $F->{Hors_taxe} ; - $F->{tvaFR} = tva_rate_str( $F->{date_aaaa_mm_jj} ) ; - $F->{priceZTVA} = sprintf('%2.2f', $F->{Hors_taxe} / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) * tva_rate( $F->{date_aaaa_mm_jj} ) ) ; - $F->{priceZTTC} = sprintf('%2.2f', $F->{Hors_taxe}) ; - $F->{HTorTTC} = 'TTC' ; - $F->{messageTVAFR} = '' ; - $F->{messageTVAEN} = '' ; - }else{ - $F->{priceHT} = sprintf('%2.2f', $amountA ) ; - $F->{priceBHT} = sprintf('%2.2f', $amountB ) ; - $F->{priceZHT} = $F->{Hors_taxe} ; - $F->{tvaFR} = '' ; - $F->{priceZTVA} = 'néant (none)' ; - $F->{priceZTTC} = $F->{Hors_taxe} ; - $F->{HTorTTC} = 'HT' ; - $F->{messageTVAFR} = 'Exonération de TVA, articles 259 et 262 du Code Général des Impôts'; - $F->{messageTVAEN} = '(VAT tax-exempt, articles 259 and 262 of French General Tax Code)'; - } - - foreach my $price ( $F->{priceHT}, $F->{priceBHT}, $F->{priceZHT}, - $F->{priceZTVA}, $F->{priceZTTC} ) { - $price =~ s{\.}{, } ; - } - - return( ) ; -} - - - -sub tva_stuff { - my $F = shift ; - - $F->{priceTTCusd} = '' ; - $F->{Hors_taxe} =~ s{,}{.} ; - - $F->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $F->{Date} ) ; - - tva_stuff_one_button_for_support_xor_software( $F ) ; - tva_stuff_one_button_for_support_and_software( $F ) ; - return( ) ; -} - -sub client_type { - my $F = shift ; - - ( $F->{clientTypeEN}, $F->{clientTypeFR} ) = ( 'professional', 'professionnel' ) ; - - if ('imapsync usage' eq $F->{Nom_Option_1} and 'individual' eq $F->{Valeur_Option_1} ) { - $F->{clientTypeEN} = 'individual' ; - $F->{clientTypeFR} = 'individuel' ; - }elsif ('imapsync usage' eq $F->{Nom_Option_1} and 'professional' eq $F->{Valeur_Option_1} ) { - $F->{clientTypeEN} = 'professional' ; - $F->{clientTypeFR} = 'professionnel' ; - }elsif('usage' eq $F->{Nom_Option_2} and 'individual' eq $F->{Option_2_Valeur} ) { - $F->{clientTypeEN} = 'individual' ; - $F->{clientTypeFR} = 'individuel' ; - } - - return( ) ; -} - -sub build_address { - my $F = shift ; - - my $addr = " -=========================================================== -Nom $F->{Nom} -Adresse_1 $F->{Adresse_1} -Adresse_2_district_quartier $F->{Adresse_2_district_quartier} -Ville Code_postal $F->{Ville} $F->{Code_postal} -Etat_Province $F->{Etat_Province} -Pays $F->{Pays} -" ; - #print $addr ; - - my @address ; - $F->{Nom} = '' if ( $F->{Nom} =~ m/^\s+$/ ) ; - my( $Nom1, $Nom2 ) = cut( $F->{Nom}, 42 ) ; - push( @address, $Nom1 ) if $Nom1 ; - #push( @address, $Nom2 ) if $Nom2 ; - push( @address, $F->{Adresse_1} ) if $F->{Adresse_1} ; - push( @address, $F->{Adresse_2_district_quartier} ) if $F->{Adresse_2_district_quartier} ; - push( @address, "$F->{Ville} $F->{Code_postal}" ) if ( $F->{Ville} or $F->{Code_postal} ) ; - push( @address, $F->{Etat_Province} ) if $F->{Etat_Province} ; - push( @address, $F->{Pays}, ) if $F->{Pays} ; - - - $F->{clientAdrA} = shift( @address ) || '' ; - $F->{clientAdrB} = shift( @address ) || '' ; - $F->{clientAdrC} = shift( @address ) || '' ; - $F->{clientAdrD} = shift( @address ) || '' ; - $F->{clientAdrE} = shift( @address ) || '' ; - $F->{clientAdrF} = shift( @address ) || '' ; - - return( ) ; -} - - -sub cut { - my $string = shift ; - my $offset = shift ; - return( $string, '' ) if length( $string ) < $offset ; - my $first = substr( $string, 0, $offset ) ; - my $last = substr( $string, $offset ) ; - - return( $first, $last ) ; -} - -sub tests_cut { - my( $aa, $bb ) = cut("123456789", 4 ) ; - ok( '1234' eq $aa, 'cut 123456789 4 => first 1234' ) ; - ok( '56789' eq $bb, 'cut 123456789 4 => last 56789' ) ; -} diff --git a/W/paypal_reply/paypal_bilan_1.78 b/W/paypal_reply/paypal_bilan_1.78 deleted file mode 100755 index cfa3591..0000000 --- a/W/paypal_reply/paypal_bilan_1.78 +++ /dev/null @@ -1,1445 +0,0 @@ -#!/usr/bin/perl - -# $Id: paypal_bilan,v 1.78 2014/05/04 02:01:26 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 $rcs = '$Id: paypal_bilan,v 1.78 2014/05/04 02:01:26 gilles Exp gilles $ ' ; -$rcs =~ m/,v (\d+\.\d+)/ ; -my $VERSION = ($1) ? $1: "UNKNOWN" ; - - -my $total_usd_received = 0 ; -my $total_usd_invoice = 0 ; -my $total_HT_EUR_logi_exo = 0 ; -my $total_HT_EUR_logi_ass = 0 ; -my $total_TVA_EUR_logi = 0 ; - -my $total_HT_EUR_sup = 0 ; -my $total_TVA_EUR_sup = 0 ; -my $total_HT_EUR_sup_exo = 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 $nb_invoice_canceled = 0 ; - -my ( $tests, $testeur ) ; -my $dry ; -my $debug ; -my $debug_csv ; -my $debug_dev ; -my $debug_invoice ; -my $debug_invoice_utf8 ; -my $debug_email; - -my $first_invoice = 1 ; -my $print_details = '' ; -my $bnc = '' ; -my $exportbnc = '' ; - -my $usdeur = 1.2981 ; -my $invoices ; -my %invoice_refund ; -my %invoice_canceled ; -my %invoice_suspended ; -my $write_invoices = 0 ; -my $avoid_numbers ; - -my $dir_invoices ; - -my $option_ret = GetOptions ( - 'tests' => \$tests, - 'dry' => \$dry, - 'debug' => \$debug, - 'debug_csv' => \$debug_csv, - 'debug_dev' => \$debug_dev, - 'debug_invoice' => \$debug_invoice, - 'debug_invoice_utf8' => \$debug_invoice_utf8, - 'debug_email' => \$debug_email, - - 'first_invoice=i' => \$first_invoice, - 'print_details|details' => \$print_details, - 'bnc' => \$bnc, - 'exportbnc=s' => \$exportbnc, - 'usdeur=f' => \$usdeur, - 'invoices=s' => \$invoices, - 'write_invoices!' => \$write_invoices, - 'dir_invoices=s' => \$dir_invoices, - 'avoid_numbers=s' => \$avoid_numbers, -); - -$dir_invoices ||= '/g/var/paypal_invoices' ; -if ( $write_invoices and not -d "$dir_invoices" ) { - $debug and print "mkdir $dir_invoices\n" ; - $dry or mkdir( $dir_invoices ) or die ; -} - - - -$debug and print "dir_invoices = $dir_invoices\n" ; - -$testeur = Test::More->builder ; -$testeur->no_ending(1) ; - -if ( $tests ) { - $testeur->no_ending( 0 ) ; - exit( tests( ) ) ; -} - - -my @files = @ARGV ; -my %action_invoice ; - -my %invoice_paypal ; - -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" ; - -my @actions ; - -foreach my $file ( @files ) { - - my @actions_file = parse_file( $file ) ; - push( @actions, @actions_file ) ; -} - -foreach my $action (@actions) { - # compute_line() adds $action->{ 'invoice' } if needed - compute_line( $action ) ; - - # index by invoice number - $action_invoice{ $action->{ 'invoice' } } = $action ; -} -delete $action_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_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 }++ ; - build_invoice( $invoice ) if ( $debug_invoice or $debug_invoice_utf8 ) ; - }elsif( not ( $invoice_canceled{ $invoice } or $invoice_refund{ $invoice } ) ) { - $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 ) ; - -my @invoice_canceled = sort { $a <=> $b } keys( %invoice_canceled ) ; -my @invoice_suspended = sort { $a <=> $b } keys( %invoice_suspended ) ; -my @invoice_refund = sort { $a <=> $b } keys( %invoice_refund ) ; - - -print( "\n", "=" x 60, "\n" ) ; - -my $total_usd_paypal_cost ; -$total_usd_paypal_cost = sprintf('%2.2f', $total_usd_invoice - $total_usd_received ) ; -print "USD received $total_usd_received\n" ; -print "USD invoice $total_usd_invoice\n" ; -print "USD costs $total_usd_paypal_cost\n" ; - -my $total_eur_invoice_from_usd ; -my $total_eur_received_from_usd ; -my $total_eur_paypal_cost_from_usd ; - -# au 30 nov 2010 http://fr.finance.yahoo.com/devises/convertisseur/#from=EUR;to=USD;amt=1 -$total_eur_invoice_from_usd = sprintf('%2.2f', $total_usd_invoice / $usdeur ) ; -$total_eur_received_from_usd = sprintf('%2.2f', $total_usd_received / $usdeur ) ; -$total_eur_paypal_cost_from_usd = sprintf('%2.2f', $total_usd_paypal_cost / $usdeur ) ; - -# EUR -$total_eur_received = sprintf('%2.2f', $total_eur_received) ; -$total_eur_invoice = sprintf('%2.2f', $total_eur_invoice) ; -print "EUR invoice from USD $total_eur_invoice_from_usd\n" ; -print "EUR received from EUR $total_eur_received\n" ; -print "EUR invoice from EUR $total_eur_invoice\n" ; - -my $total_eur_invoice_from_eur_usd = $total_eur_invoice_from_usd + $total_eur_invoice ; -my $total_eur_received_from_eur_usd = $total_eur_received_from_usd + $total_eur_received ; -my $total_eur_paypal_cost = $total_eur_invoice - $total_eur_received + $total_eur_paypal_cost_from_usd ; - - -$total_HT_EUR_logi_exo = sprintf('%2.2f', $total_HT_EUR_logi_exo) ; -$total_HT_EUR_logi_ass = sprintf('%2.2f', $total_HT_EUR_logi_ass) ; -$total_TVA_EUR_logi = sprintf('%2.2f', $total_TVA_EUR_logi) ; - -$total_HT_EUR_sup = sprintf('%2.2f', $total_HT_EUR_sup) ; -$total_TVA_EUR_sup = sprintf('%2.2f', $total_TVA_EUR_sup) ; -$total_HT_EUR_sup_exo = sprintf('%2.2f', $total_HT_EUR_sup_exo) ; - -$total_eur_invoice_from_eur_usd = sprintf('%2.2f', $total_eur_invoice_from_eur_usd) ; -$total_eur_paypal_cost = sprintf('%2.2f', $total_eur_paypal_cost) ; - -print( "---- USD + EUR ----\n" ) ; -print "EUR total invoice $total_eur_invoice_from_eur_usd\n" ; -print "EUR total received $total_eur_received_from_eur_usd\n" ; -print "EUR total paypal cost $total_eur_paypal_cost\n" ; -print ; -print( "---- Assujeti TVA ----\n" ) ; -print "EUR total HT licen assuj $total_HT_EUR_logi_ass (autres operations imposables)\n" ; -#print "EUR total TVA licen assuj $total_TVA_EUR_logi\n" ; -print "EUR total HT supp assuj $total_HT_EUR_sup (ventes, prestations)\n" ; -#print "EUR total TVA supp assuj $total_TVA_EUR_sup\n" ; - -print( "---- Exonere TVA ----\n" ) ; -print "EUR total HT licen exo $total_HT_EUR_logi_exo (autres operations NON imposables)\n" ; -print "EUR total HT suppo exo $total_HT_EUR_sup_exo (autres operations NON imposables)\n" ; - -print( "---- Invoices ----\n" ) ; - -print "Nb invoice $nb_invoice ( from $first_invoice_paypal to $last_invoice )\n" ; -print "Nb invoice canceled ($nb_invoice_canceled) @invoice_canceled\n" ; -print "Nb invoice suspended ($nb_invoice_suspended) @invoice_suspended\n" ; -print "Nb invoice refund ($nb_invoice_refund) @invoice_refund\n" ; -print "Nb invoice sent $nb_invoice_sent\n" ; -print "Have to send invoices @invoice_not_sent\n" if ( @invoice_not_sent ) ; - -my $total_eur2 = $total_HT_EUR_logi_exo + $total_HT_EUR_logi_ass + $total_TVA_EUR_logi + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo ; -$total_eur2 = sprintf('%2.2f', $total_eur2) ; -print "$total_eur_invoice_from_eur_usd != $total_eur2 = $total_HT_EUR_logi_exo + $total_HT_EUR_logi_ass + $total_TVA_EUR_logi + $total_HT_EUR_sup + $total_TVA_EUR_sup + $total_HT_EUR_sup_exo\n" -if ( $total_eur_invoice_from_eur_usd != $total_eur2 ) ; - -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 invoice_00000 { - my $invoice = shift ; - - return( sprintf( "%04d", $invoice ) ) ; -} - -sub tests_invoice_00000 { - - ok( '0000' eq invoice_00000( 0 ), 'invoice_00000: 0 -> 0000' ) ; - ok( '0147' eq invoice_00000( 147 ), 'invoice_00000: 147 -> 0147' ) ; - ok( '99999' eq invoice_00000( 99999 ), 'invoice_00000: 99999 -> 99999' ) ; -} - -sub tests_next_invoice { - ok( 1 == next_invoice( ), 'next_invoice: 1' ) ; - ok( 2 == next_invoice( ), 'next_invoice: 2' ) ; - @avoid_numbers{ (3, 4, 6, 8 ) } = ( ) ; - ok( 5 == next_invoice( ), 'next_invoice: 7' ) ; - ok( 7 == next_invoice( ), 'next_invoice: 8' ) ; - ok( 9 == next_invoice( ), 'next_invoice: 9' ) ; - %invoice_paypal = () ; - $first_invoice = 7 ; - ok( 7 == next_invoice( ), 'next_invoice: 7' ) ; -} - - -sub tests_exportbnc { - ok( 1 == 1, '1 == 1' ) ; - -} - - - -sub tests { - tests_next_invoice( ) ; - tests_cut( ) ; - tests_invoice_00000( ) ; - #tests_exportbnc( ) ; - tests_tva_rate( ) ; - tests_tva_rate_str( ) ; - tests_software_price( ) ; -} - -sub compute_line_debug { - - my $A = shift ; - - return( "#" x 78, "\n", - "[$A->{Date}] [$A->{Heure}] [$A->{Fuseau_horaire}] [$A->{Nom}] [$A->{Type}] [$A->{Etat}] ", - "[$A->{Devise}] [$A->{Hors_taxe_paypal}] [$A->{Montant}] [$A->{Numero_davis_de_reception}] [$A->{Solde}] [$A->{Impact_sur_le_solde}] ", - "[$A->{Pays}] [$A->{Nom_Option_1}] [$A->{Valeur_Option_1}] [$A->{Titre_de_l_objet}]\n" ) ; - -} - -sub bnc_first_line { - my $A = shift ; - $A->{MontantEUR} = $A->{Montant} ; - $A->{MontantEUR} = sprintf( "%.4f", $A->{Montant}/$usdeur ) if ($A->{Devise} eq 'USD') ; - return( "\n", "=" x 60, "\n", - "[$A->{Date}] [$A->{Nom}] [$A->{Type}] [$A->{Etat}] [$A->{Devise}] ", - "[$A->{Hors_taxe_paypal}] [$A->{Montant}] [EUR $A->{MontantEUR}] [$A->{Impact_sur_le_solde}]\n", - "[$A->{Pays}] [$A->{Nom_Option_1}] [$A->{Valeur_Option_1}] [$A->{Titre_de_l_objet}]\n" ) ; -} - -sub details { - - my $A = shift ; - - return( "[$A->{invoice}] [$A->{Date}] [$A->{Heure}] [$A->{Fuseau_horaire}] ", - "[$A->{Nom}] [$A->{Type}] [$A->{Etat}] [$A->{Devise}] [$A->{Montant}] ", - "[$A->{Numero_davis_de_reception}] [$A->{Solde}] [$A->{Impact_sur_le_solde}]\n" ) ; - -} - -sub paiement_usd_termine{ - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'USD' eq $A->{Devise} - and ( 'Terminé' eq $A->{Etat} or 'Compensé' eq $A->{Etat} ) - ) { - $A->{Montant} =~tr/,/./; - $A->{Montant2} = $A->{Hors_taxe_paypal} ; - $total_usd_received += $A->{Montant} ; - $total_usd_invoice += $A->{Montant2} ; - tva_line( $A ) ; - $total_HT_EUR_logi_exo += $A->{montant_HT_EUR_logi_exo} ; - $total_HT_EUR_logi_ass += $A->{montant_HT_EUR_logi_ass} ; - $total_TVA_EUR_logi += $A->{montant_TVA_EUR_logi} ; - - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_termine { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and ( 'Terminé' eq $A->{Etat} or 'Compensé' eq $A->{Etat} ) - ) { - $A->{Montant} =~tr/,/./; - $A->{Montant2} = $A->{Hors_taxe_paypal} ; - $total_eur_received += $A->{Montant} ; - $total_eur_invoice += $A->{Montant2} ; - tva_line( $A ) ; - $total_HT_EUR_logi_exo += $A->{montant_HT_EUR_logi_exo} ; - $total_HT_EUR_logi_ass += $A->{montant_HT_EUR_logi_ass} ; - $total_TVA_EUR_logi += $A->{montant_TVA_EUR_logi} ; - $total_HT_EUR_sup += $A->{montant_HT_EUR_sup} ; - $total_TVA_EUR_sup += $A->{montant_TVA_EUR_sup} ; - $total_HT_EUR_sup_exo += $A->{montant_HT_EUR_sup_exo} ; - - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_rembourse { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Remboursé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_refund++; - $invoice_refund{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_annule { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Annulé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_canceled++; - $invoice_canceled{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_suspendu { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Suspendu' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $nb_invoice_suspended++; - $invoice_suspended{ $A->{invoice} }++ ; - - $print_details and print( details( $A ) ) ; - } -} - -sub paiement_eur_non_compense { - - my $A = shift ; - - if ( - 'Paiement sur site marchand reçu' eq $A->{Type} - and 'EUR' eq $A->{Devise} - and 'Non compensé' eq $A->{Etat} - ) { - $A->{invoice} = next_invoice( ) ; - $nb_invoice++ ; - $print_details and print( details( $A ) ) ; - } -} - - - -sub compute_line { - - my $action = shift ; - my %action = %$action ; - my $A ; - - @{$A}{ qw( - 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 Nom_Option_2 Option_2_Valeur - Impact_sur_le_solde - ) } - = @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", 'Nom Option 2', 'Option 2 Valeur', - 'Impact sur le solde') } ; - - ( $A->{Etat} ) = @action{ ( 'Etat' ) } || @action{ ( 'État' ) } ; - ( $A->{Hors_taxe_paypal} ) = @action{ ( 'Hors taxe' ) } || @action{ ( 'Avant commission' ) } ; - $A->{Impact_sur_le_solde} ||= '' ; - $A->{invoice} = 'NONE' ; - $A->{Montant} = $action->{ 'Net' } if not defined $A->{Montant}; - - $debug and print( compute_line_debug( $A ) ) ; - - $A->{Montant} =~ s/[^0-9-,.]//g ; - $A->{Montant} =~ s/,/./g ; - $A->{Hors_taxe_paypal} =~ s/,/./g ; - - $bnc and print( bnc_first_line( $A ) ) ; - paiement_usd_termine( $A ) ; - paiement_eur_termine( $A ) ; - paiement_eur_rembourse( $A ) ; - paiement_eur_annule( $A ) ; - paiement_eur_suspendu( $A ) ; - paiement_eur_non_compense( $A ) ; - $bnc and print( BNC_output( $A->{invoice}, FR_flag( $A->{Pays} ), - IND_flag( $A->{Nom_Option_1}, $A->{Valeur_Option_1} ), - SUPPORT_flag( $A->{Titre_de_l_objet} ), - $A->{Nom}, $A->{Date}, $A->{MontantEUR}, $A->{Devise}, - $A->{Titre_de_l_objet}, $A->{Impact_sur_le_solde}, $A->{Type} ) ) ; - - $action->{ 'invoice' } = $A->{invoice} ; -} - -sub BNC_output { -# FE 1359 FR IND imapsync Bougon Edouard -# [12/01/2012] FR IND 28.73 EUR - my( $invoice, $FR_flag, $IND_flag, $SUPPORT_flag, - $Nom, $Date, $MontantEUR, $Devise, $Titre_de_l_objet, $Impact_sur_le_solde, $Type ) = @_ ; - - my $BNC_output ; - - if ( 'NONE' eq $invoice ) { - $BNC_output = "[$Date] $MontantEUR $Devise $Nom $Titre_de_l_objet [$Impact_sur_le_solde] [$Type]\n" ; - }else{ - $BNC_output = - "FE $invoice$FR_flag$IND_flag imapsync$SUPPORT_flag $Nom\n" - . "[$Date]$FR_flag$IND_flag $MontantEUR $Devise \n" ; - } - return( $BNC_output ) ; -} - -sub SUPPORT_flag { - my $Titre_de_l_objet = shift ; - my $SUPPORT_flag = '' ; - $SUPPORT_flag = ' support' if ( 'imapsync support' eq $Titre_de_l_objet ) ; -} - -sub IND_flag { - my( $Nom_Option_1, $Valeur_Option_1 ) = @_ ; - my $IND_flag = '' ; - $IND_flag = ' IND' if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) ; - return( $IND_flag ) ; -} - -sub FR_flag { - my $Pays = shift ; - my $FR_flag = '' ; - - $FR_flag = ' FR' if $Pays eq 'France' ; - return( $FR_flag ) ; -} - -sub escape_for_tex { - - my $F = shift ; - foreach my $str ( - $F->{De_l_adresse_email}, - $F->{Nom}, - $F->{clientAdrA}, - $F->{clientAdrB}, - $F->{clientAdrC}, - $F->{clientAdrD}, - $F->{clientAdrE}, - $F->{clientAdrF}, - ) { - $str =~ s{#}{\\#}g ; - $str =~ s{_}{\\_}g ; - $str =~ s{&}{\\&}g ; - } -} - -sub build_invoice { - my $invoice = shift ; - - return if ! $invoice ; - - my $F ; - $F->{invoice} = $invoice ; - - my $action = $action_invoice{ $F->{invoice} } ; - #print Data::Dumper->Dump( [$action] ) ; - - @{$F}{ qw( 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 - Nom_Option_2 Option_2_Valeur ) } - = @{$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', - 'Nom Option 2', 'Option 2 Valeur' ) } ; - - $F->{Etat_Province} = $action->{'Etat/Province/Région/Comté/Territoire/Préfecture/République'} - || $action->{'État/Province/Région/Comté/Territoire/Préfecture/République'} - || '' ; - $F->{Hors_taxe} = $action->{'Hors taxe'} || $action->{'Avant commission'} ; - $F->{Hors_taxe_num} = $F->{Hors_taxe} ; - $F->{Hors_taxe_num} =~ s{,}{.} ; - if ($F->{Hors_taxe_num} > 100) { - print "invoice $F->{invoice} $F->{Hors_taxe_num} > 100\n" ; - #return() ; - } - - build_email_message( $F ) ; - $debug_email and print( "\n", $F->{email_message_header}, $F->{email_message_body} ) ; - - if ( $write_invoices and ! invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ) ) { - write_email_message( $dir_invoices, $F->{invoice}, - $F->{email_message_header}, $F->{email_message_body}, - $F->{De_l_adresse_email} ) ; - write_csv_info( $dir_invoices, $F->{invoice}, $F->{file_csv}, $F->{line_number}, $F->{line_csv} ) ; - } - - - build_address( $F ) ; - escape_for_tex( $F ) ; - client_type( $F ) ; - object_type( $F ) ; - description_stuff( $F ) ; - tva_stuff( $F ) ; - $F->{quantity} = '1' ; - - download_urls( $F ) ; - ( $F->{Nom1} ) = cut( $F->{Nom}, 42 ) ; - $F->{clientVAT} = '' ; - - if ( ( 'VAT if professional in Europe' eq $F->{Nom_Option_2} ) and $F->{Option_2_Valeur} ) { - $F->{clientVAT} = $F->{Option_2_Valeur} ; - } - - my $tex_variables = qq{ -%% Begin input from paypal_bilan $VERSION -\\providecommand{\\invoiceNumber}{$F->{invoice}} -\\providecommand{\\clientName}{$F->{Nom1}} -\\providecommand{\\clientEmail}{$F->{De_l_adresse_email}} -\\providecommand{\\clientAdrA}{$F->{clientAdrA}} -\\providecommand{\\clientAdrB}{$F->{clientAdrB}} -\\providecommand{\\clientAdrC}{$F->{clientAdrC}} -\\providecommand{\\clientAdrD}{$F->{clientAdrD}} -\\providecommand{\\clientAdrE}{$F->{clientAdrE}} -\\providecommand{\\clientAdrF}{$F->{clientAdrF}} -\\providecommand{\\clientVAT}{$F->{clientVAT}} -\\providecommand{\\invoiceDate}{$F->{Date}} -\\providecommand{\\invoiceHour}{$F->{Heure}} - -\\providecommand{\\descriptionFR}{$F->{descriptionFR}} -\\providecommand{\\descriptionEN}{$F->{descriptionEN}} -\\providecommand{\\descriptionBFR}{$F->{descriptionBFR}} -\\providecommand{\\descriptionBEN}{$F->{descriptionBEN}} -\\providecommand{\\usageFR}{$F->{usageFR}} -\\providecommand{\\usageEN}{$F->{usageEN}} -\\providecommand{\\quantity}{$F->{quantity}} -\\providecommand{\\quantityB}{$F->{quantityB}} - -\\providecommand{\\priceHT}{$F->{priceHT}} -\\providecommand{\\priceBHT}{$F->{priceBHT}} -\\providecommand{\\priceZHT}{$F->{priceZHT}} -\\providecommand{\\tvaFR}{$F->{tvaFR}} -\\providecommand{\\priceZTVA}{$F->{priceZTVA}} -\\providecommand{\\HTorTTC}{$F->{HTorTTC}} -\\providecommand{\\priceZTTC}{$F->{priceZTTC}} -\\providecommand{\\messageTVAFR}{$F->{messageTVAFR}} -\\providecommand{\\messageTVAEN}{$F->{messageTVAEN}} -\\providecommand{\\urlSrc}{\\url{$F->{urlSrc}}} -%% End input from paypal_bilan -} ; - - my $tex_variables_utf8 = to_utf8( { -string => $tex_variables, -charset => 'ISO-8859-1' } ) ; - - $debug_invoice_utf8 and print $tex_variables_utf8 ; - $debug_invoice and print $tex_variables ; - - #print "$F->{invoice} ", invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ), "\n" ; - if ( $write_invoices and ! invoice_sent( $dir_invoices, $F->{invoice}, $F->{De_l_adresse_email} ) ) { - write_tex_variables_file( $dir_invoices, $F->{invoice}, $F->{Date}, $tex_variables_utf8 ) ; - } - -} - -sub description_stuff { - my $F = shift ; - - $F->{descriptionFR} = $F->{descriptionEN} = '' ; - $F->{descriptionBFR} = $F->{descriptionBEN} = '' ; - $F->{quantityB} = '' ; - $F->{usageFR} = $F->{usageEN} = '' ; - - - if ( 'software' eq $F->{object_type} ) { - $F->{descriptionFR} = 'Logiciel imapsync. TOUS droits cédés, autorisés.' ; - $F->{descriptionEN} = '(Imapsync software. ALL rights conceded, allowed.)' ; - } - - if ( 'professional' eq $F->{clientTypeEN} - and 'software' eq $F->{object_type} ) { - $F->{usageFR} = 'Usage à titre professionnel.' ; - $F->{usageEN} = '(professional usage.)' ; - } - - if ( 'individual' eq $F->{clientTypeEN} - and 'software' eq $F->{object_type} ) { - $F->{usageFR} = 'Usage à titre individuel.' ; - $F->{usageEN} = '(individual usage.)' ; - } - - if ( 'support' eq $F->{object_type} ) { - $F->{usageFR} = '' ; - $F->{usageEN} = '' ; - $F->{descriptionFR} = 'Support sur le logiciel imapsync.' ; - $F->{descriptionEN} = '(Imapsync support.)' ; - } - - if ( 'professional' eq $F->{clientTypeEN} - and 'software + support' eq $F->{object_type} ) { - $F->{usageFR} = 'Usage à titre professionnel.' ; - $F->{usageEN} = '(professional usage.)' ; - $F->{descriptionFR} = 'Logiciel imapsync. TOUS droits cédés, autorisés.' ; - $F->{descriptionEN} = '(Imapsync software. ALL rights conceded, allowed.)' ; - $F->{descriptionBFR} = 'Support sur le logiciel imapsync.' ; - $F->{descriptionBEN} = '(Imapsync support.)' ; - $F->{quantityB} = '1' ; - } -} - - - -sub object_type { - my $F = shift ; - - $F->{object_type} = '' ; - - if ( 'imapsync' eq $F->{Titre_de_l_objet} - or 'imapsync.exe' eq $F->{Titre_de_l_objet} - or 'imapsync source' eq $F->{Titre_de_l_objet} - or 'imapsync source code' eq $F->{Titre_de_l_objet} - ) { - $F->{object_type} = 'software' ; - }elsif ( 'imapsync support' eq $F->{Titre_de_l_objet} ) { - $F->{object_type} = 'support' ; - }elsif ( ( 'imapsync all' eq $F->{Titre_de_l_objet} ) - and ( 'software only' eq $F->{Valeur_Option_1} ) ) { - $F->{object_type} = 'software' ; - }elsif ( ( 'imapsync all' eq $F->{Titre_de_l_objet} ) - and ( 'software + support' eq $F->{Valeur_Option_1} ) ) { - $F->{object_type} = 'software + support' ; - }elsif ( ( 'imapsync any' eq $F->{Titre_de_l_objet} ) - and ( 'Software only. For professional use.' eq $F->{Valeur_Option_1} ) ) { - $F->{object_type} = 'software' ; - }elsif ( ( 'imapsync any' eq $F->{Titre_de_l_objet} ) - and ( 'Software + Support. For professional use.' eq $F->{Valeur_Option_1} ) ) { - $F->{object_type} = 'software + support' ; - }elsif ( ( 'imapsync any' eq $F->{Titre_de_l_objet} ) - and ( 'Software only. For individual use.' eq $F->{Valeur_Option_1} ) ) { - $F->{object_type} = 'software' ; - } -} - -sub build_email_message { - - my $F = shift ; - - object_type( $F ) ; - my $invoice = $F->{invoice} ; - - my $message_header = qq{X-imapsync: invoice $invoice for imapsync $F->{object_type} -From: Gilles LAMIRAL -Bcc: gilles\@lamiral.info -Subject: [imapsync invoice] $invoice ($F->{Hors_taxe_num} EUR on $F->{Date}) for imapsync $F->{object_type}. -Disposition-Notification-To: Gilles LAMIRAL -} ; - - - my $message_body = qq{ -Hello $F->{Nom}, - -First of all, I'm sorry for the delay in getting back to you. - -Last imapsync release is available from the page -http://imapsync.lamiral.info/paypal_return.shtml - -You'll find in the attachment the invoice of imapsync -$F->{object_type} you bought and paid (dd/mm/yyyy $F->{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 $F->{object_type}. - -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. -} ; - - $F->{email_message_header} = $message_header ; - $F->{email_message_body} = $message_body ; - return( ) ; - -} - -sub write_csv_info { - - my( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - $debug and print "Writing $dir_invoices/$invoice_00000/csv_info.txt\n" ; - $dry and return( ) ; - - open( CSVINFO, "> $dir_invoices/$invoice_00000/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 ) = @_ ; - my $invoice_00000 = invoice_00000( $invoice ) ; - return( 1 ) if ( -f "$dir_invoices/$invoice_00000/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' }); - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $dry and return( ) ; - - open( HEADER, "> $dir_invoices/$invoice_00000/facture_message_header.txt") or die ; - print HEADER $message_header ; - close( HEADER ) ; - - open( BODY, "> $dir_invoices/$invoice_00000/facture_message_body.txt") or die ; - print BODY $message_body_utf8 ; - close( BODY ) ; - - open( ADDRESS, "> $dir_invoices/$invoice_00000/email_address.txt") or die ; - print ADDRESS "$email_address\n" ; - close( ADDRESS ) ; -} - - -sub write_tex_variables_file { - my ( $dir_invoices, $invoice, $Date, $tex_variables_utf8 ) = @_ ; - - my $invoice_00000 = invoice_00000( $invoice ) ; - - if ( ! -d "$dir_invoices/$invoice_00000" ) { - $debug and print "mkdir $dir_invoices/$invoice_00000\n" ; - $dry or mkdir( "$dir_invoices/$invoice_00000" ) or die ; - } - - $debug and print "Writing imapsync_var.tex $dir_invoices/$invoice_00000/imapsync_var.tex\n" ; - $dry and return( ) ; - - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var.tex") or die ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - - if ( ! -f "$dir_invoices/$invoice_00000/imapsync_var_manual.tex" ) { - open( FILE, "> $dir_invoices/$invoice_00000/imapsync_var_manual.tex") or die ; - print FILE "%% $0 created this file -%% Can be used to override imapsync_var.tex definitions\n" ; - print FILE $tex_variables_utf8 ; - close( FILE ) ; - } - -} - -sub download_urls { - my $F = shift ; - - $F->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $F->{Date} ) ; - - if ( '2014_04_13' le $F->{date_aaaa_mm_jj} - and ( - ( 'software' eq $F->{object_type} ) - or - ( 'software + support' eq $F->{object_type} ) - ) - ) { - $F->{urlSrc} = 'http://imapsync.lamiral.info/paypal_return.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - - if ('2011_05_01' le $F->{date_aaaa_mm_jj} - and 'software' eq $F->{object_type} ) { - $F->{urlSrc} = 'http://ks.lamiral.info/imapsync/paypal_return.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - - if ('2011_05_01' le $F->{date_aaaa_mm_jj} - and 'support' eq $F->{object_type} ) { - $F->{urlSrc} = 'http://ks.lamiral.info/imapsync/paypal_return_support.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - - if ('2011_03_24' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/prj/imapsync/paypal_return.shtml' ; - $F->{urlExe} = '' ; - return( ) ; - } - if ('2011_02_21' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2011_02_21/OUMbo7/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2011_02_21/rHSVNs/' ; - return( ) ; - } - if ('2011_01_18' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2011_01_18/zPRRNt/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2011_01_18/FO1QzG/' ; - return( ) ; - } - if ('2011_01_18' le $F->{date_aaaa_mm_jj}) { - $F->{urlSrc} = 'http://www.linux-france.org/depot/2010_11_28/SiNdlZ/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2010_11_28/R3ZAyr/' ; - return( ) ; - } - $F->{urlSrc} = 'http://www.linux-france.org/depot/2010_11_08/X2PWMe/' ; - $F->{urlExe} = 'http://www.linux-france.org/depot/2010_11_08/ZZ7zSc/' ; - return( ) ; -} - -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_rate { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - #return( 0 ) ; - return( 0.196 ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - #print "tva_rate 0.2\n" ; - return( 0.2 ) ; - } - #print "tva_rate 0\n" ; - return( 0 ) ; -} - -sub tests_tva_rate { - ok( 0.196 == tva_rate( '2013_01_01' ), 'tva_rate: old 0.196' ) ; - ok( 0.196 == tva_rate( '2013_12_31' ), 'tva_rate: old 0.196' ) ; - ok( 0.2 == tva_rate( '2014_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2014_12_31' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_01_01' ), 'tva_rate: new 0.2' ) ; - ok( 0.2 == tva_rate( '2050_12_31' ), 'tva_rate: new 0.2' ) ; - return( 0 ) ; -} - - -sub tva_rate_str { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' gt $date_aaaa_mm_jj ) { - #print "tva_rate 0.196\n" ; - return( '19,60\%' ) ; - } - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - return( '20\%' ) ; - } - #print "tva_rate 0\n" ; - return( '' ) ; -} - -sub tests_tva_rate_str { - ok( '19,60\%' eq tva_rate_str( '2013_01_01' ), 'tva_rate_str: old 0.196' ) ; - ok( '19,60\%' eq tva_rate_str( '2013_12_31' ), 'tva_rate_str: old 0.196' ) ; - ok( '20\%' eq tva_rate_str( '2014_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2014_12_31' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2050_01_01' ), 'tva_rate_str: new 0.2' ) ; - ok( '20\%' eq tva_rate_str( '2050_12_31' ), 'tva_rate_str: new 0.2' ) ; - return( 0 ) ; -} - - -sub software_price { - my $date_aaaa_mm_jj = shift ; - - if ( '2014_01_01' le $date_aaaa_mm_jj ) { - return( 50 ) ; - } - return( 0 ) ; -} - - -sub tests_software_price { - ok( 50 == software_price( '2014_01_01' ), 'software_price: 2014_01_01 => 50 ' ) ; - ok( 0 == software_price( '2000_01_01' ), 'software_price: 2000_01_01 => 0' ) ; - return( 0 ) ; -} - -sub tva_line_one_button_for_the_software { - - my $A = shift ; - - if ( 'imapsync' eq $A->{Titre_de_l_objet} - or 'imapsync.exe' eq $A->{Titre_de_l_objet} - or 'imapsync source' eq $A->{Titre_de_l_objet} - or 'imapsync source code' eq $A->{Titre_de_l_objet} - - ) { - if ( - ( 'individual' eq $A->{client_type} ) - or - ( 'France' eq $A->{Pays} ) - ) { - $A->{montant_HT_EUR_logi_ass} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_logi} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_logi_exo} = $A->{Montant2} ; - } - } - -} - -sub tva_line_one_button_for_the_support { - - my $A = shift ; - - if ( 'support' eq $A->{object_type} ) { - if ( - ( 'individual' eq $A->{client_type} ) - or - ( 'France' eq $A->{Pays} ) - or - ( '2013_02_19' gt $A->{date_aaaa_mm_jj} ) - ) - { - $A->{montant_HT_EUR_sup} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_sup} = $A->{Montant2} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_sup_exo} = $A->{Montant2} ; - } - } -} - -sub button_type { - my $A = shift ; - - if ( - 'imapsync all' eq $A->{Titre_de_l_objet} - or - 'imapsync any' eq $A->{Titre_de_l_objet} - ) { - $A->{button_type} = 'mixed' ; - }else{ - $A->{button_type} = 'single' ; - } -} - -sub tva_line_one_button_for_support_and_software { - - my $A = shift ; - - $A->{Montant2_logi} = software_price( $A->{date_aaaa_mm_jj} ) ; - $A->{Montant2_supp} = $A->{Montant2} - $A->{Montant2_logi} ; - - if ( 'mixed' eq $A->{button_type} ) { - if ( 'individual' eq $A->{client_type} - or - 'France' eq $A->{Pays} - ) - { - $A->{montant_HT_EUR_sup} = $A->{Montant2_supp} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_sup} = $A->{Montant2_supp} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - $A->{montant_HT_EUR_logi_ass} = $A->{Montant2_logi} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) ; - $A->{montant_TVA_EUR_logi} = $A->{Montant2_logi} / ( 1 + tva_rate( $A->{date_aaaa_mm_jj} ) ) * tva_rate( $A->{date_aaaa_mm_jj} ) ; - }else{ - $A->{montant_HT_EUR_logi_exo} = $A->{Montant2_logi} ; - $A->{montant_HT_EUR_sup_exo} = $A->{Montant2_supp} ; - } - } -} - - -sub tva_line { - - my $A = shift ; - - $A->{montant_HT_EUR_logi_exo} = $A->{montant_HT_EUR_logi_ass} = $A->{montant_TVA_EUR_logi} = 0 ; - $A->{montant_HT_EUR_sup} = $A->{montant_TVA_EUR_sup} = $A->{montant_HT_EUR_sup_exo} = 0 ; - - client_type( $A ) ; - object_type( $A ) ; - button_type( $A ) ; - $A->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $A->{Date} ) ; - $A->{Montant2} = $A->{Montant2}/$usdeur if 'USD' eq $A->{Devise} ; - - tva_line_one_button_for_the_software( $A ) ; - tva_line_one_button_for_the_support( $A ) ; - tva_line_one_button_for_support_and_software( $A ) ; - return( ) ; -} - - -sub tva_stuff_one_button_for_support_xor_software { - - my $F = shift ; - - if ( not ( 'software' eq $F->{object_type} - or 'support' eq $F->{object_type} - ) ) { - return( ) ; - } - - if ( ( 'individual' eq $F->{clientTypeEN}) - or - ( 'France' eq $F->{Pays} ) - ) { - $F->{priceHT} = sprintf('%2.2f', $F->{Hors_taxe} / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) ) ; - $F->{priceBHT} = '' ; - $F->{priceZHT} = $F->{priceHT} ; - $F->{tvaFR} = tva_rate_str( $F->{date_aaaa_mm_jj} ) ; - $F->{priceZTVA} = sprintf('%2.2f', $F->{Hors_taxe} / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) * tva_rate( $F->{date_aaaa_mm_jj} ) ) ; - $F->{priceZTTC} = sprintf('%2.2f', $F->{Hors_taxe}) ; - $F->{HTorTTC} = 'TTC' ; - $F->{messageTVAFR} = '' ; - $F->{messageTVAEN} = '' ; - }else{ - $F->{priceHT} = sprintf('%2.2f', $F->{Hors_taxe}) ; - $F->{priceBHT} = '' ; - $F->{priceZHT} = $F->{priceHT} ; - $F->{tvaFR} = '' ; - $F->{priceZTVA} = 'néant (none)' ; - $F->{priceZTTC} = $F->{priceHT} ; - $F->{HTorTTC} = 'HT' ; - $F->{messageTVAFR} = 'Exonération de TVA, articles 259 et 262 du Code Général des Impôts'; - $F->{messageTVAEN} = '(VAT tax-exempt, articles 259 and 262 of French General Tax Code)'; - } - - foreach my $price ( $F->{priceHT}, $F->{priceBHT}, $F->{priceZHT}, - $F->{priceZTVA}, $F->{priceZTTC} ) { - $price =~ s{\.}{, } ; - } - - return( ) ; -} - -sub tva_stuff_one_button_for_support_and_software { - - my $F = shift ; - - if ( not ( 'software + support' eq $F->{object_type} ) ) { - return( ) ; - } - - my $amountZ = $F->{Hors_taxe} ; - my $amountA = software_price( $F->{date_aaaa_mm_jj} ) ; - my $amountB = $amountZ - $amountA ; - - if ( ( 'individual' eq $F->{clientTypeEN}) - or - ( 'France' eq $F->{Pays} ) - ) { - $F->{priceHT} = sprintf('%2.2f', $amountA / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) ) ; - $F->{priceBHT} = sprintf('%2.2f', $amountB / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) ) ; - $F->{priceZHT} = $F->{Hors_taxe} ; - $F->{tvaFR} = tva_rate_str( $F->{date_aaaa_mm_jj} ) ; - $F->{priceZTVA} = sprintf('%2.2f', $F->{Hors_taxe} / ( 1 + tva_rate( $F->{date_aaaa_mm_jj} ) ) * tva_rate( $F->{date_aaaa_mm_jj} ) ) ; - $F->{priceZTTC} = sprintf('%2.2f', $F->{Hors_taxe}) ; - $F->{HTorTTC} = 'TTC' ; - $F->{messageTVAFR} = '' ; - $F->{messageTVAEN} = '' ; - }else{ - $F->{priceHT} = sprintf('%2.2f', $amountA ) ; - $F->{priceBHT} = sprintf('%2.2f', $amountB ) ; - $F->{priceZHT} = $F->{Hors_taxe} ; - $F->{tvaFR} = '' ; - $F->{priceZTVA} = 'néant (none)' ; - $F->{priceZTTC} = $F->{Hors_taxe} ; - $F->{HTorTTC} = 'HT' ; - $F->{messageTVAFR} = 'Exonération de TVA, articles 259 et 262 du Code Général des Impôts'; - $F->{messageTVAEN} = '(VAT tax-exempt, articles 259 and 262 of French General Tax Code)'; - } - - foreach my $price ( $F->{priceHT}, $F->{priceBHT}, $F->{priceZHT}, - $F->{priceZTVA}, $F->{priceZTTC} ) { - $price =~ s{\.}{, } ; - } - - return( ) ; -} - - - -sub tva_stuff { - my $F = shift ; - - $F->{priceTTCusd} = '' ; - $F->{Hors_taxe} =~ s{,}{.} ; - - $F->{date_aaaa_mm_jj} = date_aaaa_mm_jj( $F->{Date} ) ; - - tva_stuff_one_button_for_support_xor_software( $F ) ; - tva_stuff_one_button_for_support_and_software( $F ) ; - return( ) ; -} - -sub client_type { - my $F = shift ; - - $F->{client_type} = 'professional' ; - $F->{clientTypeEN} = 'professional' ; - $F->{clientTypeFR} = 'professionnel' ; - - if ('imapsync usage' eq $F->{Nom_Option_1} and 'individual' eq $F->{Valeur_Option_1} ) { - $F->{client_type} = 'individual' ; - $F->{clientTypeEN} = 'individual' ; - $F->{clientTypeFR} = 'individuel' ; - }elsif ('imapsync usage' eq $F->{Nom_Option_1} and 'professional' eq $F->{Valeur_Option_1} ) { - $F->{client_type} = 'professional' ; - $F->{clientTypeEN} = 'professional' ; - $F->{clientTypeFR} = 'professionnel' ; - }elsif('usage' eq $F->{Nom_Option_2} and 'individual' eq $F->{Option_2_Valeur} ) { - $F->{client_type} = 'individual' ; - $F->{clientTypeEN} = 'individual' ; - $F->{clientTypeFR} = 'individuel' ; - } - - return( ) ; -} - -sub build_address { - my $F = shift ; - - my $addr = " -=========================================================== -Nom $F->{Nom} -Adresse_1 $F->{Adresse_1} -Adresse_2_district_quartier $F->{Adresse_2_district_quartier} -Ville Code_postal $F->{Ville} $F->{Code_postal} -Etat_Province $F->{Etat_Province} -Pays $F->{Pays} -" ; - #print $addr ; - - my @address ; - $F->{Nom} = '' if ( $F->{Nom} =~ m/^\s+$/ ) ; - my( $Nom1, $Nom2 ) = cut( $F->{Nom}, 42 ) ; - push( @address, $Nom1 ) if $Nom1 ; - #push( @address, $Nom2 ) if $Nom2 ; - push( @address, $F->{Adresse_1} ) if $F->{Adresse_1} ; - push( @address, $F->{Adresse_2_district_quartier} ) if $F->{Adresse_2_district_quartier} ; - push( @address, "$F->{Ville} $F->{Code_postal}" ) if ( $F->{Ville} or $F->{Code_postal} ) ; - push( @address, $F->{Etat_Province} ) if $F->{Etat_Province} ; - push( @address, $F->{Pays}, ) if $F->{Pays} ; - - - $F->{clientAdrA} = shift( @address ) || '' ; - $F->{clientAdrB} = shift( @address ) || '' ; - $F->{clientAdrC} = shift( @address ) || '' ; - $F->{clientAdrD} = shift( @address ) || '' ; - $F->{clientAdrE} = shift( @address ) || '' ; - $F->{clientAdrF} = shift( @address ) || '' ; - - return( ) ; -} - - -sub cut { - my $string = shift ; - my $offset = shift ; - return( $string, '' ) if length( $string ) < $offset ; - my $first = substr( $string, 0, $offset ) ; - my $last = substr( $string, $offset ) ; - - return( $first, $last ) ; -} - -sub tests_cut { - my( $aa, $bb ) = cut("123456789", 4 ) ; - ok( '1234' eq $aa, 'cut 123456789 4 => first 1234' ) ; - ok( '56789' eq $bb, 'cut 123456789 4 => last 56789' ) ; -} diff --git a/W/paypal_reply/paypal_build_invoices b/W/paypal_reply/paypal_build_invoices index a183ba7..2026731 100755 --- a/W/paypal_reply/paypal_build_invoices +++ b/W/paypal_reply/paypal_build_invoices @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: paypal_build_invoices,v 1.88 2015/03/26 01:56:35 gilles Exp gilles $ +# $Id: paypal_build_invoices,v 1.94 2015/07/15 00:55:25 gilles Exp gilles $ # usage: sh paypal_build_invoices /g/var/paypal_invoices/???? @@ -62,8 +62,14 @@ cp /home/gilles/public_html/AGIL/factures/000/facture_imapsync-000.tex /g/var/pa #/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 3809 /g/paypal/paypal_2015_01_complet.csv #/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 3877 /g/paypal/paypal_2015_02_complet.csv #/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 3957 /g/paypal/virements_2015_03.csv +#/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 3959 /g/paypal/paypal_2015_03_complet.csv +#/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 4031 /g/paypal/paypal_2015_04_complet.csv +#/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 4085 /g/paypal/paypal_2015_05_complet.csv +#/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 4139 /g/paypal/paypal_2015_06_complet.csv -/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 3959 /g/paypal/paypal_2015_03_complet.csv +set -x +/g/public_html/imapsync/W/paypal_reply/paypal_bilan --write_invoices --first_in 4196 /g/paypal/paypal_2015_07_complet.csv +set +x @@ -120,11 +126,14 @@ cp /home/gilles/public_html/AGIL/factures/000/facture_imapsync-000.tex /g/var/pa : /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 3691 /g/paypal/paypal_2014_11_complet.csv : /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 3750 /g/paypal/paypal_2014_12_complet.csv : /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 3809 /g/paypal/paypal_2015_01_complet.csv +: /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 3877 /g/paypal/paypal_2015_02_complet.csv +: /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 3959 /g/paypal/paypal_2015_03_complet.csv +: /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 4031 /g/paypal/paypal_2015_04_complet.csv +: /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 4085 /g/paypal/paypal_2015_05_complet.csv +: /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 4139 /g/paypal/paypal_2015_06_complet.csv set -x -: /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 3877 /g/paypal/paypal_2015_02_complet.csv -#: /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 3957 /g/paypal/virements_2015_03.csv -: /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 3959 /g/paypal/paypal_2015_03_complet.csv +: /g/public_html/imapsync/W/paypal_reply/paypal_bilan --first_in 4196 /g/paypal/paypal_2015_07_complet.csv set +x # La totale @@ -134,7 +143,7 @@ set +x 1330 1331 1332 1333 1334 1652 1653 2131 2132 2295 2296 2297 2298 2625 2626 2970 2971 2972 3093 3296 3411 3412 3450 3451 3614 3615 3616 3617 -3807 3808 3957 3958' \ +3807 3808 3957 3958 4030' \ /g/paypal/paypal_201?_??_complet.csv #set -v @@ -143,7 +152,7 @@ set +x 1330 1331 1332 1333 1334 1652 1653 2131 2132 2295 2296 2297 2298 2625 2626 2970 2971 2972 3093 3296 3411 3412 3450 3451 3614 3615 3616 3617 -3807 3808 3957 3958' \ +3807 3808 3957 3958 4030' \ /g/paypal/paypal_201?_??_complet.csv #set +v @@ -176,8 +185,17 @@ set +x /g/paypal/paypal_2014_??_complet.csv #set +v +#echo 2015 : ( from 3809 to ???? ) EUR +#set -v +: /g/public_html/imapsync/W/paypal_reply/paypal_bilan \ + --first_in 3809 --avoid_numbers '3807 3808 3957 3958 4030' \ + /g/paypal/paypal_2015_??_complet.csv +#set +v -echo 'sh paypal_build_invoices /g/var/paypal_invoices/3???' + + + +echo 'sh paypal_build_invoices /g/var/paypal_invoices/4???' # USD de 147 à 340 # EUR de 341 à ... diff --git a/W/perlcritic_2.out b/W/perlcritic_2.out index 2c572b2..fab5a20 100644 --- a/W/perlcritic_2.out +++ b/W/perlcritic_2.out @@ -1,4 +1,4 @@ -Main code has high complexity score (381) at line 1, column 1. Consider refactoring. (Severity: 3) +Main code has high complexity score (387) at line 1, column 1. Consider refactoring. (Severity: 3) Missing "REQUIRED ARGUMENTS" section in POD at line 16, column 1. See pages 133,138 of PBP. (Severity: 2) Missing "DIAGNOSTICS" section in POD at line 16, column 1. See pages 133,138 of PBP. (Severity: 2) Missing "CONFIGURATION" section in POD at line 16, column 1. See pages 133,138 of PBP. (Severity: 2) @@ -6,734 +6,736 @@ Missing "DEPENDENCIES" section in POD at line 16, column 1. See pages 133,138 o Missing "INCOMPATIBILITIES" section in POD at line 16, column 1. See pages 133,138 of PBP. (Severity: 2) Missing "BUGS AND LIMITATIONS" section in POD at line 16, column 1. See pages 133,138 of PBP. (Severity: 2) Missing "LICENSE AND COPYRIGHT" section in POD at line 16, column 1. See pages 133,138 of PBP. (Severity: 2) -Magic punctuation variable $| used at line 584, column 3. See page 79 of PBP. (Severity: 2) -64 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 759, column 10. Unnamed numeric literals make code less maintainable. (Severity: 2) -50 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 775, column 54. Unnamed numeric literals make code less maintainable. (Severity: 2) -Postfix control "if" used at line 778, column 23. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 786, column 111. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 797, column 65. See page 53 of PBP. (Severity: 2) -5 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 825, column 48. Unnamed numeric literals make code less maintainable. (Severity: 2) -5 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 826, column 48. Unnamed numeric literals make code less maintainable. (Severity: 2) -Postfix control "if" used at line 835, column 15. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 836, column 21. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 842, column 25. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 850, column 24. See pages 93,94 of PBP. (Severity: 2) -Magic punctuation variable $! used in interpolated string at line 859, column 40. See page 79 of PBP. (Severity: 2) -Postfix control "if" used at line 860, column 27. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 871, column 17. See pages 93,94 of PBP. (Severity: 2) -100 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 874, column 13. Unnamed numeric literals make code less maintainable. (Severity: 2) -100 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 875, column 13. Unnamed numeric literals make code less maintainable. (Severity: 2) -993 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 878, column 24. Unnamed numeric literals make code less maintainable. (Severity: 2) -143 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 878, column 30. Unnamed numeric literals make code less maintainable. (Severity: 2) -993 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 881, column 24. Unnamed numeric literals make code less maintainable. (Severity: 2) -143 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 881, column 30. Unnamed numeric literals make code less maintainable. (Severity: 2) -Postfix control "if" used at line 883, column 31. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 884, column 12. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 898, column 5. See pages 93,94 of PBP. (Severity: 2) -Long number not separated with underscores at line 1010, column 20. See page 59 of PBP. (Severity: 2) -Postfix control "unless" used at line 1012, column 43. See pages 96,97 of PBP. (Severity: 2) -Literal line breaks in a string at line 1028, column 1. See pages 60,61 of PBP. (Severity: 3) -Literal line breaks in a string at line 1040, column 1. See pages 60,61 of PBP. (Severity: 3) -Quotes used with a string containing no non-whitespace characters at line 1051, column 19. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 1052, column 50. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1054, column 22. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1055, column 22. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1065, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1076, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1086, column 26. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1097, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1107, column 28. See page 53 of PBP. (Severity: 2) -Postfix control "unless" used at line 1135, column 43. See pages 96,97 of PBP. (Severity: 2) -Postfix control "unless" used at line 1137, column 43. See pages 96,97 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1140, column 34. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1141, column 34. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 1212, column 33. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/x" flag at line 1212, column 33. See page 236 of PBP. (Severity: 3) -Regular expression without "/m" flag at line 1212, column 33. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 1221, column 33. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/x" flag at line 1221, column 33. See page 236 of PBP. (Severity: 3) -Regular expression without "/m" flag at line 1221, column 33. See page 237 of PBP. (Severity: 2) -"grep" used in boolean context at line 1238, column 11. See pages 71,72 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 1238, column 18. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/x" flag at line 1238, column 18. See page 236 of PBP. (Severity: 3) -Regular expression without "/m" flag at line 1238, column 18. See page 237 of PBP. (Severity: 2) -Literal line breaks in a string at line 1312, column 1. See pages 60,61 of PBP. (Severity: 3) -Postfix control "if" used at line 1333, column 3. See pages 93,94 of PBP. (Severity: 2) -Literal line breaks in a string at line 1345, column 1. See pages 60,61 of PBP. (Severity: 3) -Postfix control "if" used at line 1355, column 17. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1358, column 34. See pages 93,94 of PBP. (Severity: 2) -"unless" block used at line 1412, column 3. See page 97 of PBP. (Severity: 2) -"unless" block used at line 1418, column 3. See page 97 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1450, column 50. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1451, column 50. See page 53 of PBP. (Severity: 2) -Double-sigil dereference at line 1461, column 39. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 1463, column 50. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 1473, column 49. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 1474, column 30. See page 228 of PBP. (Severity: 2) -Postfix control "if" used at line 1492, column 57. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1502, column 77. See pages 93,94 of PBP. (Severity: 2) -Double-sigil dereference at line 1505, column 2. See page 228 of PBP. (Severity: 2) -Postfix control "if" used at line 1510, column 5. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1514, column 3. See pages 93,94 of PBP. (Severity: 2) -"unless" block used at line 1517, column 2. See page 97 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1518, column 21. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1519, column 54. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 1555, column 79. See pages 93,94 of PBP. (Severity: 2) -Double-sigil dereference at line 1559, column 2. See page 228 of PBP. (Severity: 2) -Postfix control "if" used at line 1564, column 3. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1568, column 3. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1598, column 10. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1618, column 33. See pages 93,94 of PBP. (Severity: 2) -"unless" block used at line 1619, column 4. See page 97 of PBP. (Severity: 2) -Postfix control "if" used at line 1627, column 39. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1631, column 38. See pages 93,94 of PBP. (Severity: 2) -"unless" block used at line 1640, column 4. See page 97 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1642, column 45. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 1643, column 31. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 1643, column 31. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 1645, column 7. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1646, column 32. See pages 93,94 of PBP. (Severity: 2) -"unless" block used at line 1647, column 5. See page 97 of PBP. (Severity: 2) -Postfix control "if" used at line 1655, column 52. See pages 93,94 of PBP. (Severity: 2) -"unless" block used at line 1656, column 4. See page 97 of PBP. (Severity: 2) -Postfix control "if" used at line 1665, column 39. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1669, column 38. See pages 93,94 of PBP. (Severity: 2) -"unless" block used at line 1678, column 4. See page 97 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1679, column 49. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 1680, column 31. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 1680, column 31. See page 237 of PBP. (Severity: 2) -"unless" block used at line 1681, column 5. See page 97 of PBP. (Severity: 2) -Postfix control "if" used at line 1710, column 70. See pages 93,94 of PBP. (Severity: 2) -Code structure is deeply nested at line 1711, column 41. Consider refactoring. (Severity: 3) -"unless" block used at line 1711, column 41. See page 97 of PBP. (Severity: 2) -Postfix control "if" used at line 1722, column 39. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1726, column 38. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1790, column 47. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 1791, column 59. See pages 93,94 of PBP. (Severity: 2) -"unless" block used at line 1793, column 4. See page 97 of PBP. (Severity: 2) -Postfix control "if" used at line 1796, column 23. See pages 93,94 of PBP. (Severity: 2) -"unless" block used at line 1830, column 3. See page 97 of PBP. (Severity: 2) -"unless" block used at line 1834, column 3. See page 97 of PBP. (Severity: 2) -Postfix control "if" used at line 1854, column 30. See pages 93,94 of PBP. (Severity: 2) -Literal line breaks in a string at line 1859, column 1. See pages 60,61 of PBP. (Severity: 3) -Postfix control "unless" used at line 1866, column 20. See pages 96,97 of PBP. (Severity: 2) -Postfix control "unless" used at line 1867, column 20. See pages 96,97 of PBP. (Severity: 2) -Postfix control "if" used at line 1869, column 22. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1872, column 111. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1873, column 33. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1874, column 17. See pages 93,94 of PBP. (Severity: 2) -Subroutine "errors_incr" does not end with "return" at line 1881, column 1. See page 197 of PBP. (Severity: 4) -Quotes used with a string containing no non-whitespace characters at line 1884, column 27. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 1884, column 42. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 1887, column 24. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1894, column 20. See page 53 of PBP. (Severity: 2) -Subroutine "tests_live_result" does not end with "return" at line 1906, column 1. See page 197 of PBP. (Severity: 4) -Reused variable name in lexical scope: $nb_errors at line 1907, column 2. Invent unique variable names. (Severity: 3) -Subroutine "foldersizesatend" does not end with "return" at line 1915, column 1. See page 197 of PBP. (Severity: 4) -Too many arguments at line 1941, column 1. See page 182 of PBP. (Severity: 3) -Quotes used with a string containing no non-whitespace characters at line 1951, column 58. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1952, column 58. See page 53 of PBP. (Severity: 2) -Too many arguments at line 1959, column 1. See page 182 of PBP. (Severity: 3) -Too many arguments at line 1969, column 1. See page 182 of PBP. (Severity: 3) -Quotes used with a string containing no non-whitespace characters at line 1984, column 28. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1985, column 28. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1996, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 1997, column 26. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2008, column 28. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 2016, column 17. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 2016, column 17. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2026, column 55. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2027, column 74. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 2032, column 58. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2064, column 23. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2092, column 77. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2095, column 65. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2098, column 73. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2101, column 77. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2104, column 76. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2107, column 68. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2110, column 73. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2113, column 67. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2116, column 77. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2119, column 79. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2122, column 71. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2125, column 65. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2128, column 67. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2131, column 75. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2134, column 59. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2137, column 87. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2140, column 69. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2143, column 67. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2146, column 69. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 2161, column 15. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 2161, column 15. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2173, column 5. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2180, column 5. See page 53 of PBP. (Severity: 2) -Too many arguments at line 2216, column 1. See page 182 of PBP. (Severity: 3) -Magic punctuation variable $@ used in interpolated string at line 2227, column 17. See page 79 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2244, column 35. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2247, column 35. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 2261, column 14. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 2273, column 14. See pages 93,94 of PBP. (Severity: 2) -Too many arguments at line 2277, column 1. See page 182 of PBP. (Severity: 3) -Postfix control "if" used at line 2292, column 35. See pages 93,94 of PBP. (Severity: 2) -Magic punctuation variable $@ used in interpolated string at line 2310, column 17. See page 79 of PBP. (Severity: 2) -Subroutine "authenticate_imap" with high complexity score (21) at line 2338, column 1. Consider refactoring. (Severity: 3) -Too many arguments at line 2338, column 1. See page 182 of PBP. (Severity: 3) -Quotes used with a string containing no non-whitespace characters at line 2349, column 38. See page 53 of PBP. (Severity: 2) -Postfix control "unless" used at line 2352, column 51. See pages 96,97 of PBP. (Severity: 2) -Postfix control "if" used at line 2356, column 33. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 2357, column 33. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 2358, column 35. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 2360, column 32. See pages 93,94 of PBP. (Severity: 2) -"unless" block used at line 2364, column 2. See page 97 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2375, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2418, column 40. See page 53 of PBP. (Severity: 2) -Too many arguments at line 2442, column 1. See page 182 of PBP. (Severity: 3) -Postfix control "if" used at line 2467, column 41. See pages 93,94 of PBP. (Severity: 2) -Numeric escapes in interpolated string at line 2480, column 30. See pages 54,55 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2482, column 41. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 2515, column 51. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/x" flag at line 2515, column 51. See page 236 of PBP. (Severity: 3) -Regular expression without "/m" flag at line 2515, column 51. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 2518, column 26. See pages 93,94 of PBP. (Severity: 2) -Backtick operator used at line 2523, column 12. Use IPC::Open3 instead. (Severity: 3) -"unless" block used at line 2545, column 2. See page 97 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2553, column 112. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 2575, column 32. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 2575, column 32. See page 237 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2588, column 65. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2591, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2594, column 39. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2603, column 82. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2612, column 32. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2612, column 45. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2612, column 61. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2615, column 22. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 2618, column 39. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2629, column 41. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2642, column 29. See page 53 of PBP. (Severity: 2) -Magic punctuation variable $0 used in interpolated string at line 2648, column 5. See page 79 of PBP. (Severity: 2) -Subroutine "is_valid_directory" does not end with "return" at line 2653, column 1. See page 197 of PBP. (Severity: 4) -Close filehandles as soon as possible after opening them at line 2673, column 2. See page 209 of PBP. (Severity: 4) -Return value of "close" ignored at line 2679, column 2. Check the return value of "close" for success. (Severity: 2) -Subroutine "remove_tmp_files" does not end with "return" at line 2684, column 1. See page 197 of PBP. (Severity: 4) -"die" used instead of "croak" at line 2698, column 2. See page 283 of PBP. (Severity: 3) -Magic punctuation variable $0 used in interpolated string at line 2703, column 13. See page 79 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2711, column 14. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2713, column 79. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2714, column 79. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2725, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2726, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2727, column 6. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2729, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2730, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2731, column 6. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2733, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2734, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2737, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2738, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2741, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2742, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2743, column 6. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2745, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2746, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2747, column 6. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2755, column 14. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2763, column 6. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2764, column 31. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2789, column 31. See page 53 of PBP. (Severity: 2) -Always unpack @_ first at line 2799, column 1. See page 178 of PBP. (Severity: 4) -Regular expression without "/s" flag at line 2806, column 15. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/x" flag at line 2806, column 15. See page 236 of PBP. (Severity: 3) -Regular expression without "/m" flag at line 2806, column 15. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 2807, column 15. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/x" flag at line 2807, column 15. See page 236 of PBP. (Severity: 3) -Regular expression without "/m" flag at line 2807, column 15. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 2808, column 15. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/x" flag at line 2808, column 15. See page 236 of PBP. (Severity: 3) -Regular expression without "/m" flag at line 2808, column 15. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2817, column 21. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 2834, column 31. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/x" flag at line 2834, column 31. See page 236 of PBP. (Severity: 3) -Regular expression without "/m" flag at line 2834, column 31. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2847, column 21. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2871, column 22. See page 53 of PBP. (Severity: 2) -Reused variable name in lexical scope: $imap2 at line 2894, column 9. Invent unique variable names. (Severity: 3) -Regular expression without "/s" flag at line 2913, column 25. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/x" flag at line 2913, column 25. See page 236 of PBP. (Severity: 3) -Regular expression without "/m" flag at line 2913, column 25. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 2916, column 20. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/x" flag at line 2916, column 20. See page 236 of PBP. (Severity: 3) -Regular expression without "/m" flag at line 2916, column 20. See page 237 of PBP. (Severity: 2) -Mixed high and low-precedence booleans at line 2917, column 13. See page 70 of PBP. (Severity: 4) -Quotes used with a string containing no non-whitespace characters at line 2917, column 26. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 2923, column 22. See page 53 of PBP. (Severity: 2) -List of quoted literal words at line 2973, column 17. Use 'qw()' instead. (Severity: 2) -List of quoted literal words at line 2974, column 17. Use 'qw()' instead. (Severity: 2) -Double-sigil dereference at line 3039, column 28. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 3043, column 26. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 3052, column 36. See page 228 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3103, column 32. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3104, column 37. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3213, column 50. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3223, column 21. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3231, column 38. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3232, column 38. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3232, column 42. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3234, column 6. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3234, column 30. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3234, column 34. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3234, column 38. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3235, column 46. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3235, column 50. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3236, column 46. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3236, column 51. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3237, column 48. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3237, column 53. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3238, column 48. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3238, column 53. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3239, column 48. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3239, column 53. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3240, column 50. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3240, column 55. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3242, column 50. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3242, column 55. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3244, column 50. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3244, column 55. See page 53 of PBP. (Severity: 2) -Numeric escapes in interpolated string at line 3254, column 12. See pages 54,55 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 3257, column 14. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 3257, column 14. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 3258, column 14. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 3258, column 14. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 3259, column 14. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 3259, column 14. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 3260, column 21. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 3260, column 21. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 3260, column 30. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3260, column 49. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3260, column 74. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3267, column 27. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3268, column 11. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3269, column 11. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3280, column 4. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3280, column 28. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3287, column 4. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3287, column 28. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3302, column 4. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3302, column 28. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3309, column 11. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3310, column 11. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3311, column 4. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3311, column 28. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3320, column 14. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3325, column 11. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3326, column 11. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3328, column 14. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 3344, column 13. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 3344, column 13. See page 237 of PBP. (Severity: 2) -Postfix control "unless" used at line 3350, column 4. See pages 96,97 of PBP. (Severity: 2) -Use 'eq' or hash instead of fixed-pattern regexps at line 3350, column 62. See pages 271,272 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 3350, column 62. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 3350, column 62. See page 237 of PBP. (Severity: 2) -Expression form of "eval" at line 3356, column 13. See page 161 of PBP. (Severity: 5) -Magic punctuation variable $@ used at line 3358, column 49. See page 79 of PBP. (Severity: 2) -Magic punctuation variable $@ used in interpolated string at line 3359, column 14. See page 79 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3367, column 28. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3367, column 32. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3367, column 57. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3368, column 28. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 3376, column 42. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 3376, column 42. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3377, column 17. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3377, column 21. See page 53 of PBP. (Severity: 2) -"unless" block used at line 3406, column 3. See page 97 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3407, column 22. See page 53 of PBP. (Severity: 2) -Double-sigil dereference at line 3420, column 3. See page 228 of PBP. (Severity: 2) -Postfix control "if" used at line 3420, column 35. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3425, column 71. See page 53 of PBP. (Severity: 2) -Magic punctuation variable $@ used in interpolated string at line 3425, column 71. See page 79 of PBP. (Severity: 2) -Quotes used with a noisy string at line 3428, column 100. See page 53 of PBP. (Severity: 2) -Magic punctuation variable $@ used in interpolated string at line 3428, column 100. See page 79 of PBP. (Severity: 2) -Double-sigil dereference at line 3430, column 15. See page 228 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3474, column 5. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3474, column 23. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3478, column 41. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3537, column 5. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3548, column 5. See page 53 of PBP. (Severity: 2) +Magic punctuation variable $| used at line 468, column 3. See page 79 of PBP. (Severity: 2) +64 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 645, column 10. Unnamed numeric literals make code less maintainable. (Severity: 2) +50 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 661, column 54. Unnamed numeric literals make code less maintainable. (Severity: 2) +Postfix control "if" used at line 664, column 23. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 672, column 111. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 683, column 65. See page 53 of PBP. (Severity: 2) +5 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 711, column 48. Unnamed numeric literals make code less maintainable. (Severity: 2) +5 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 712, column 48. Unnamed numeric literals make code less maintainable. (Severity: 2) +Postfix control "if" used at line 721, column 15. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 722, column 21. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 728, column 25. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 736, column 24. See pages 93,94 of PBP. (Severity: 2) +Magic punctuation variable $! used in interpolated string at line 745, column 40. See page 79 of PBP. (Severity: 2) +Postfix control "if" used at line 746, column 27. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 757, column 17. See pages 93,94 of PBP. (Severity: 2) +100 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 760, column 13. Unnamed numeric literals make code less maintainable. (Severity: 2) +100 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 761, column 13. Unnamed numeric literals make code less maintainable. (Severity: 2) +993 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 764, column 24. Unnamed numeric literals make code less maintainable. (Severity: 2) +143 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 764, column 30. Unnamed numeric literals make code less maintainable. (Severity: 2) +993 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 767, column 24. Unnamed numeric literals make code less maintainable. (Severity: 2) +143 is not one of the allowed literal values (0, 1, 2). Use the Readonly or Const::Fast module or the "constant" pragma instead at line 767, column 30. Unnamed numeric literals make code less maintainable. (Severity: 2) +Postfix control "if" used at line 769, column 31. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 770, column 12. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 784, column 5. See pages 93,94 of PBP. (Severity: 2) +Long number not separated with underscores at line 900, column 20. See page 59 of PBP. (Severity: 2) +Postfix control "unless" used at line 902, column 43. See pages 96,97 of PBP. (Severity: 2) +Literal line breaks in a string at line 918, column 1. See pages 60,61 of PBP. (Severity: 3) +Literal line breaks in a string at line 930, column 1. See pages 60,61 of PBP. (Severity: 3) +Quotes used with a string containing no non-whitespace characters at line 941, column 19. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 942, column 50. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 944, column 22. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 945, column 22. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 957, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 968, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 978, column 26. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 989, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 999, column 28. See page 53 of PBP. (Severity: 2) +Postfix control "unless" used at line 1027, column 43. See pages 96,97 of PBP. (Severity: 2) +Postfix control "unless" used at line 1029, column 43. See pages 96,97 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1032, column 34. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1033, column 34. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 1112, column 33. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/x" flag at line 1112, column 33. See page 236 of PBP. (Severity: 3) +Regular expression without "/m" flag at line 1112, column 33. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 1121, column 33. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/x" flag at line 1121, column 33. See page 236 of PBP. (Severity: 3) +Regular expression without "/m" flag at line 1121, column 33. See page 237 of PBP. (Severity: 2) +"grep" used in boolean context at line 1138, column 11. See pages 71,72 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 1138, column 18. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/x" flag at line 1138, column 18. See page 236 of PBP. (Severity: 3) +Regular expression without "/m" flag at line 1138, column 18. See page 237 of PBP. (Severity: 2) +Literal line breaks in a string at line 1212, column 1. See pages 60,61 of PBP. (Severity: 3) +Postfix control "if" used at line 1233, column 3. See pages 93,94 of PBP. (Severity: 2) +Literal line breaks in a string at line 1245, column 1. See pages 60,61 of PBP. (Severity: 3) +Postfix control "if" used at line 1255, column 17. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1258, column 34. See pages 93,94 of PBP. (Severity: 2) +"unless" block used at line 1312, column 3. See page 97 of PBP. (Severity: 2) +"unless" block used at line 1318, column 3. See page 97 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1350, column 50. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1351, column 50. See page 53 of PBP. (Severity: 2) +Double-sigil dereference at line 1361, column 39. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 1363, column 50. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 1373, column 49. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 1374, column 30. See page 228 of PBP. (Severity: 2) +Postfix control "if" used at line 1392, column 57. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1402, column 77. See pages 93,94 of PBP. (Severity: 2) +Double-sigil dereference at line 1405, column 2. See page 228 of PBP. (Severity: 2) +Postfix control "if" used at line 1410, column 5. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1415, column 3. See pages 93,94 of PBP. (Severity: 2) +"unless" block used at line 1418, column 2. See page 97 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1419, column 21. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1420, column 54. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 1456, column 79. See pages 93,94 of PBP. (Severity: 2) +Double-sigil dereference at line 1460, column 2. See page 228 of PBP. (Severity: 2) +Postfix control "if" used at line 1465, column 3. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1470, column 3. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1500, column 10. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1520, column 33. See pages 93,94 of PBP. (Severity: 2) +"unless" block used at line 1521, column 4. See page 97 of PBP. (Severity: 2) +Postfix control "if" used at line 1529, column 39. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1533, column 38. See pages 93,94 of PBP. (Severity: 2) +"unless" block used at line 1542, column 4. See page 97 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1544, column 45. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 1545, column 31. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 1545, column 31. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 1547, column 7. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1548, column 32. See pages 93,94 of PBP. (Severity: 2) +"unless" block used at line 1549, column 5. See page 97 of PBP. (Severity: 2) +Postfix control "if" used at line 1557, column 52. See pages 93,94 of PBP. (Severity: 2) +"unless" block used at line 1558, column 4. See page 97 of PBP. (Severity: 2) +Postfix control "if" used at line 1567, column 39. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1571, column 38. See pages 93,94 of PBP. (Severity: 2) +"unless" block used at line 1580, column 4. See page 97 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1581, column 49. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 1582, column 31. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 1582, column 31. See page 237 of PBP. (Severity: 2) +"unless" block used at line 1583, column 5. See page 97 of PBP. (Severity: 2) +Postfix control "if" used at line 1612, column 70. See pages 93,94 of PBP. (Severity: 2) +Code structure is deeply nested at line 1613, column 41. Consider refactoring. (Severity: 3) +"unless" block used at line 1613, column 41. See page 97 of PBP. (Severity: 2) +Postfix control "if" used at line 1624, column 39. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1628, column 38. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1692, column 47. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 1693, column 59. See pages 93,94 of PBP. (Severity: 2) +"unless" block used at line 1695, column 4. See page 97 of PBP. (Severity: 2) +Postfix control "if" used at line 1698, column 23. See pages 93,94 of PBP. (Severity: 2) +"unless" block used at line 1732, column 3. See page 97 of PBP. (Severity: 2) +"unless" block used at line 1736, column 3. See page 97 of PBP. (Severity: 2) +Postfix control "if" used at line 1756, column 30. See pages 93,94 of PBP. (Severity: 2) +Literal line breaks in a string at line 1761, column 1. See pages 60,61 of PBP. (Severity: 3) +Postfix control "unless" used at line 1768, column 20. See pages 96,97 of PBP. (Severity: 2) +Postfix control "unless" used at line 1769, column 20. See pages 96,97 of PBP. (Severity: 2) +Postfix control "if" used at line 1771, column 22. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1774, column 111. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1775, column 33. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1776, column 17. See pages 93,94 of PBP. (Severity: 2) +Subroutine "errors_incr" does not end with "return" at line 1783, column 1. See page 197 of PBP. (Severity: 4) +Quotes used with a string containing no non-whitespace characters at line 1786, column 27. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 1786, column 42. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 1789, column 24. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1796, column 20. See page 53 of PBP. (Severity: 2) +Subroutine "tests_live_result" does not end with "return" at line 1808, column 1. See page 197 of PBP. (Severity: 4) +Reused variable name in lexical scope: $nb_errors at line 1809, column 2. Invent unique variable names. (Severity: 3) +Subroutine "foldersizesatend" does not end with "return" at line 1817, column 1. See page 197 of PBP. (Severity: 4) +Too many arguments at line 1843, column 1. See page 182 of PBP. (Severity: 3) +Quotes used with a string containing no non-whitespace characters at line 1853, column 58. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1854, column 58. See page 53 of PBP. (Severity: 2) +Too many arguments at line 1861, column 1. See page 182 of PBP. (Severity: 3) +Too many arguments at line 1871, column 1. See page 182 of PBP. (Severity: 3) +Quotes used with a string containing no non-whitespace characters at line 1886, column 28. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1887, column 28. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1898, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1899, column 26. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1910, column 28. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 1918, column 17. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 1918, column 17. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1928, column 55. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1929, column 74. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 1934, column 58. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 1966, column 23. See page 53 of PBP. (Severity: 2) +Subroutine "modules_VERSION" with high complexity score (21) at line 1989, column 1. Consider refactoring. (Severity: 3) +Quotes used with a noisy string at line 1994, column 77. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 1997, column 65. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2000, column 73. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2003, column 77. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2006, column 76. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2009, column 68. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2012, column 73. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2015, column 67. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2018, column 77. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2021, column 79. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2024, column 71. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2027, column 65. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2030, column 67. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2033, column 75. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2036, column 59. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2039, column 87. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2042, column 69. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2045, column 67. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2048, column 69. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2051, column 73. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 2066, column 15. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 2066, column 15. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2078, column 5. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2085, column 5. See page 53 of PBP. (Severity: 2) +Too many arguments at line 2121, column 1. See page 182 of PBP. (Severity: 3) +Magic punctuation variable $@ used in interpolated string at line 2132, column 17. See page 79 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2149, column 35. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2152, column 35. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 2166, column 14. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 2178, column 14. See pages 93,94 of PBP. (Severity: 2) +Too many arguments at line 2182, column 1. See page 182 of PBP. (Severity: 3) +Postfix control "if" used at line 2197, column 35. See pages 93,94 of PBP. (Severity: 2) +Magic punctuation variable $@ used in interpolated string at line 2215, column 17. See page 79 of PBP. (Severity: 2) +Subroutine "authenticate_imap" with high complexity score (21) at line 2243, column 1. Consider refactoring. (Severity: 3) +Too many arguments at line 2243, column 1. See page 182 of PBP. (Severity: 3) +Quotes used with a string containing no non-whitespace characters at line 2254, column 38. See page 53 of PBP. (Severity: 2) +Postfix control "unless" used at line 2257, column 51. See pages 96,97 of PBP. (Severity: 2) +Postfix control "if" used at line 2261, column 33. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 2262, column 33. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 2263, column 35. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 2265, column 32. See pages 93,94 of PBP. (Severity: 2) +"unless" block used at line 2269, column 2. See page 97 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2280, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2323, column 40. See page 53 of PBP. (Severity: 2) +Too many arguments at line 2347, column 1. See page 182 of PBP. (Severity: 3) +Postfix control "if" used at line 2372, column 41. See pages 93,94 of PBP. (Severity: 2) +Numeric escapes in interpolated string at line 2385, column 30. See pages 54,55 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2387, column 41. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 2420, column 51. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/x" flag at line 2420, column 51. See page 236 of PBP. (Severity: 3) +Regular expression without "/m" flag at line 2420, column 51. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 2423, column 26. See pages 93,94 of PBP. (Severity: 2) +Backtick operator used at line 2428, column 12. Use IPC::Open3 instead. (Severity: 3) +"unless" block used at line 2450, column 2. See page 97 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2458, column 112. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 2480, column 32. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 2480, column 32. See page 237 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2493, column 65. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2496, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2499, column 39. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2508, column 82. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2517, column 32. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2517, column 45. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2517, column 61. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2520, column 22. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 2523, column 39. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2534, column 41. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2547, column 29. See page 53 of PBP. (Severity: 2) +Magic punctuation variable $0 used in interpolated string at line 2553, column 5. See page 79 of PBP. (Severity: 2) +Subroutine "is_valid_directory" does not end with "return" at line 2558, column 1. See page 197 of PBP. (Severity: 4) +Close filehandles as soon as possible after opening them at line 2578, column 2. See page 209 of PBP. (Severity: 4) +Return value of "close" ignored at line 2584, column 2. Check the return value of "close" for success. (Severity: 2) +Subroutine "remove_tmp_files" does not end with "return" at line 2589, column 1. See page 197 of PBP. (Severity: 4) +"die" used instead of "croak" at line 2603, column 2. See page 283 of PBP. (Severity: 3) +Magic punctuation variable $0 used in interpolated string at line 2608, column 13. See page 79 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2616, column 14. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2618, column 79. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2619, column 79. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2630, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2631, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2632, column 6. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2634, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2635, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2636, column 6. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2638, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2639, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2642, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2643, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2646, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2647, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2648, column 6. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2650, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2651, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2652, column 6. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2660, column 14. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2668, column 6. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2669, column 31. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2694, column 31. See page 53 of PBP. (Severity: 2) +Always unpack @_ first at line 2704, column 1. See page 178 of PBP. (Severity: 4) +Regular expression without "/s" flag at line 2711, column 15. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/x" flag at line 2711, column 15. See page 236 of PBP. (Severity: 3) +Regular expression without "/m" flag at line 2711, column 15. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 2712, column 15. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/x" flag at line 2712, column 15. See page 236 of PBP. (Severity: 3) +Regular expression without "/m" flag at line 2712, column 15. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 2713, column 15. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/x" flag at line 2713, column 15. See page 236 of PBP. (Severity: 3) +Regular expression without "/m" flag at line 2713, column 15. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2722, column 21. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 2739, column 31. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/x" flag at line 2739, column 31. See page 236 of PBP. (Severity: 3) +Regular expression without "/m" flag at line 2739, column 31. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2752, column 21. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2776, column 22. See page 53 of PBP. (Severity: 2) +Reused variable name in lexical scope: $imap2 at line 2799, column 9. Invent unique variable names. (Severity: 3) +Regular expression without "/s" flag at line 2818, column 25. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/x" flag at line 2818, column 25. See page 236 of PBP. (Severity: 3) +Regular expression without "/m" flag at line 2818, column 25. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 2821, column 20. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/x" flag at line 2821, column 20. See page 236 of PBP. (Severity: 3) +Regular expression without "/m" flag at line 2821, column 20. See page 237 of PBP. (Severity: 2) +Mixed high and low-precedence booleans at line 2822, column 13. See page 70 of PBP. (Severity: 4) +Quotes used with a string containing no non-whitespace characters at line 2822, column 26. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 2828, column 22. See page 53 of PBP. (Severity: 2) +List of quoted literal words at line 2880, column 17. Use 'qw()' instead. (Severity: 2) +List of quoted literal words at line 2881, column 17. Use 'qw()' instead. (Severity: 2) +Double-sigil dereference at line 2946, column 28. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 2950, column 26. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 2959, column 36. See page 228 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3010, column 32. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3011, column 37. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3120, column 50. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3130, column 21. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3138, column 38. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3139, column 38. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3139, column 42. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3141, column 6. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3141, column 30. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3141, column 34. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3141, column 38. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3142, column 46. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3142, column 50. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3143, column 46. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3143, column 51. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3144, column 48. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3144, column 53. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3145, column 48. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3145, column 53. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3146, column 48. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3146, column 53. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3147, column 50. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3147, column 55. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3149, column 50. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3149, column 55. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3151, column 50. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3151, column 55. See page 53 of PBP. (Severity: 2) +Numeric escapes in interpolated string at line 3161, column 12. See pages 54,55 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 3164, column 14. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 3164, column 14. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 3165, column 14. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 3165, column 14. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 3166, column 14. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 3166, column 14. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 3167, column 21. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 3167, column 21. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 3167, column 30. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3167, column 49. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3167, column 74. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3174, column 27. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3175, column 11. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3176, column 11. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3187, column 4. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3187, column 28. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3194, column 4. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3194, column 28. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3209, column 4. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3209, column 28. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3216, column 11. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3217, column 11. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3218, column 4. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3218, column 28. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3227, column 14. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3232, column 11. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3233, column 11. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3235, column 14. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 3251, column 13. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 3251, column 13. See page 237 of PBP. (Severity: 2) +Postfix control "unless" used at line 3257, column 4. See pages 96,97 of PBP. (Severity: 2) +Use 'eq' or hash instead of fixed-pattern regexps at line 3257, column 62. See pages 271,272 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 3257, column 62. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 3257, column 62. See page 237 of PBP. (Severity: 2) +Expression form of "eval" at line 3263, column 13. See page 161 of PBP. (Severity: 5) +Magic punctuation variable $@ used at line 3265, column 49. See page 79 of PBP. (Severity: 2) +Magic punctuation variable $@ used in interpolated string at line 3266, column 14. See page 79 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3274, column 28. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3274, column 32. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3274, column 57. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3275, column 28. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 3283, column 42. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 3283, column 42. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3284, column 17. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3284, column 21. See page 53 of PBP. (Severity: 2) +"unless" block used at line 3313, column 3. See page 97 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3314, column 22. See page 53 of PBP. (Severity: 2) +Double-sigil dereference at line 3327, column 3. See page 228 of PBP. (Severity: 2) +Postfix control "if" used at line 3327, column 35. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3332, column 71. See page 53 of PBP. (Severity: 2) +Magic punctuation variable $@ used in interpolated string at line 3332, column 71. See page 79 of PBP. (Severity: 2) +Quotes used with a noisy string at line 3336, column 83. See page 53 of PBP. (Severity: 2) +Magic punctuation variable $@ used in interpolated string at line 3336, column 83. See page 79 of PBP. (Severity: 2) +Double-sigil dereference at line 3338, column 15. See page 228 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3382, column 5. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3382, column 23. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3386, column 41. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3445, column 5. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3456, column 5. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3456, column 23. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3457, column 5. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3471, column 5. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3471, column 23. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3473, column 5. See page 53 of PBP. (Severity: 2) +Expression form of "eval" at line 3489, column 13. See page 161 of PBP. (Severity: 5) +Magic punctuation variable $@ used at line 3491, column 45. See page 79 of PBP. (Severity: 2) +Magic punctuation variable $@ used in interpolated string at line 3492, column 10. See page 79 of PBP. (Severity: 2) +Magic punctuation variable $@ used in interpolated string at line 3503, column 14. See page 79 of PBP. (Severity: 2) +Magic punctuation variable $@ used in interpolated string at line 3505, column 14. See page 79 of PBP. (Severity: 2) +Double-sigil dereference at line 3506, column 37. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 3506, column 54. See page 228 of PBP. (Severity: 2) +"unless" block used at line 3512, column 4. See page 97 of PBP. (Severity: 2) +Magic punctuation variable $@ used in interpolated string at line 3515, column 16. See page 79 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3526, column 5. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3536, column 5. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 3544, column 17. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 3544, column 17. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 3547, column 28. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 3547, column 28. See page 237 of PBP. (Severity: 2) Quotes used with a string containing no non-whitespace characters at line 3548, column 23. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3549, column 5. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3563, column 5. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3563, column 23. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3565, column 5. See page 53 of PBP. (Severity: 2) -Expression form of "eval" at line 3581, column 13. See page 161 of PBP. (Severity: 5) -Magic punctuation variable $@ used at line 3583, column 45. See page 79 of PBP. (Severity: 2) -Magic punctuation variable $@ used in interpolated string at line 3584, column 10. See page 79 of PBP. (Severity: 2) -Magic punctuation variable $@ used in interpolated string at line 3595, column 14. See page 79 of PBP. (Severity: 2) -Magic punctuation variable $@ used in interpolated string at line 3597, column 14. See page 79 of PBP. (Severity: 2) -Double-sigil dereference at line 3598, column 37. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 3598, column 54. See page 228 of PBP. (Severity: 2) -"unless" block used at line 3604, column 4. See page 97 of PBP. (Severity: 2) -Magic punctuation variable $@ used in interpolated string at line 3607, column 16. See page 79 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3618, column 5. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3628, column 5. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 3636, column 17. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 3636, column 17. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 3639, column 28. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 3639, column 28. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3640, column 23. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3645, column 17. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3651, column 6. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 3664, column 21. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 3664, column 21. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3665, column 44. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3668, column 24. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 3676, column 21. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 3676, column 21. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3677, column 40. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3680, column 24. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 3702, column 67. See pages 93,94 of PBP. (Severity: 2) -Subroutine "select_msgs" does not end with "return" at line 3722, column 1. See page 197 of PBP. (Severity: 4) -Long number not separated with underscores at line 3806, column 63. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 3807, column 63. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 3828, column 45. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 3831, column 46. See page 59 of PBP. (Severity: 2) -Double-sigil dereference at line 3842, column 9. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 3843, column 9. See page 228 of PBP. (Severity: 2) -"unless" block used at line 3846, column 3. See page 97 of PBP. (Severity: 2) -"unless" block used at line 3847, column 3. See page 97 of PBP. (Severity: 2) -Subroutine "tests_msgs_from_maxmin" does not end with "return" at line 3861, column 1. See page 197 of PBP. (Severity: 4) -Postfix control "if" used at line 3909, column 22. See pages 93,94 of PBP. (Severity: 2) -Subroutine "copy_message" with high complexity score (25) at line 3938, column 1. Consider refactoring. (Severity: 3) -Too many arguments at line 3938, column 1. See page 182 of PBP. (Severity: 3) -Quotes used with a string containing no non-whitespace characters at line 3945, column 54. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3946, column 61. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 3956, column 41. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 3957, column 95. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 3999, column 19. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 3999, column 35. See page 53 of PBP. (Severity: 2) -Too many arguments at line 4016, column 1. See page 182 of PBP. (Severity: 3) -Too many arguments at line 4050, column 1. See page 182 of PBP. (Severity: 3) -Quotes used with a string containing no non-whitespace characters at line 4055, column 60. See page 53 of PBP. (Severity: 2) -"unless" block used at line 4057, column 2. See page 97 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4059, column 21. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4061, column 25. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 4064, column 34. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a noisy string at line 4120, column 3. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 4123, column 49. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4131, column 16. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 4153, column 15. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 4153, column 15. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 4158, column 37. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 4159, column 64. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4166, column 16. See page 53 of PBP. (Severity: 2) -Subroutine "tests_subject" does not end with "return" at line 4177, column 1. See page 197 of PBP. (Severity: 4) -Quotes used with a string containing no non-whitespace characters at line 4178, column 6. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4178, column 21. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4218, column 6. See page 53 of PBP. (Severity: 2) -Too many arguments at line 4240, column 1. See page 182 of PBP. (Severity: 3) -Quotes used with a string containing no non-whitespace characters at line 4249, column 63. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 4261, column 20. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 4261, column 20. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 4279, column 75. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 4279, column 75. See page 237 of PBP. (Severity: 2) -Subroutine "sleep_if_needed" does not end with "return" at line 4299, column 1. See page 197 of PBP. (Severity: 4) -Reused variable name in lexical scope: $total_bytes_transferred at line 4300, column 2. Invent unique variable names. (Severity: 3) -Reused variable name in lexical scope: $nb_msg_transferred at line 4300, column 2. Invent unique variable names. (Severity: 3) -Reused variable name in lexical scope: $nb_msg_transferred at line 4312, column 9. Invent unique variable names. (Severity: 3) -Reused variable name in lexical scope: $maxmessagespersecond at line 4312, column 9. Invent unique variable names. (Severity: 3) -Reused variable name in lexical scope: $total_bytes_transferred at line 4333, column 9. Invent unique variable names. (Severity: 3) -Reused variable name in lexical scope: $maxbytespersecond at line 4333, column 9. Invent unique variable names. (Severity: 3) -Postfix control "if" used at line 4361, column 28. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4369, column 10. See page 53 of PBP. (Severity: 2) -Double-sigil dereference at line 4402, column 2. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 4402, column 22. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 4403, column 2. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 4403, column 22. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 4405, column 26. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 4462, column 37. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 4463, column 37. See page 228 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 4476, column 23. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 4476, column 23. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 4496, column 23. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 4496, column 23. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4570, column 35. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4570, column 46. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4570, column 57. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4570, column 68. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4570, column 79. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4571, column 35. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4571, column 46. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4571, column 57. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4571, column 68. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4571, column 79. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4571, column 90. See page 53 of PBP. (Severity: 2) -Double-sigil dereference at line 4575, column 37. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 4576, column 37. See page 228 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4618, column 32. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4618, column 43. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4618, column 54. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4618, column 65. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4618, column 76. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4619, column 32. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4619, column 43. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4619, column 54. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4619, column 65. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4619, column 76. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4619, column 87. See page 53 of PBP. (Severity: 2) -Double-sigil dereference at line 4622, column 34. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 4623, column 34. See page 228 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 4638, column 16. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 4638, column 16. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4651, column 47. See page 53 of PBP. (Severity: 2) -Double-sigil dereference at line 4683, column 78. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 4684, column 21. See page 228 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4687, column 102. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 4696, column 29. See page 53 of PBP. (Severity: 2) -Magic punctuation variable $! used in interpolated string at line 4696, column 29. See page 79 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4735, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4736, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4740, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4741, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4742, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4786, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4787, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4788, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4792, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4793, column 24. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4794, column 24. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 4817, column 38. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 4824, column 40. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a noisy string at line 4828, column 43. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 4829, column 45. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4883, column 33. See page 53 of PBP. (Severity: 2) -Hard tabs used at line 4918, column 10. See page 20 of PBP. (Severity: 3) -Quotes used with a string containing no non-whitespace characters at line 4953, column 43. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4954, column 44. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4955, column 48. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 4960, column 6. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4960, column 28. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4960, column 32. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4960, column 36. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4960, column 40. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4961, column 35. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4961, column 39. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 4961, column 43. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 4968, column 25. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 4969, column 25. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 4985, column 21. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 4985, column 21. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 4987, column 20. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 4987, column 20. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 5001, column 31. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 5006, column 32. See pages 93,94 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 5017, column 13. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 5017, column 13. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 5023, column 5. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 5023, column 32. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 5023, column 36. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 5024, column 46. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 5025, column 54. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 5028, column 54. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 5029, column 60. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 5050, column 15. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 5051, column 15. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 5067, column 15. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 5068, column 15. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 5071, column 15. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 5080, column 15. See page 53 of PBP. (Severity: 2) -Expression form of "eval" at line 5522, column 13. See page 161 of PBP. (Severity: 5) -Magic punctuation variable $@ used at line 5524, column 38. See page 79 of PBP. (Severity: 2) -Magic punctuation variable $@ used in interpolated string at line 5525, column 10. See page 79 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 5551, column 21. See page 53 of PBP. (Severity: 2) -Numeric escapes in interpolated string at line 5560, column 21. See pages 54,55 of PBP. (Severity: 2) -Numeric escapes in interpolated string at line 5565, column 21. See pages 54,55 of PBP. (Severity: 2) -Long number not separated with underscores at line 5717, column 16. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 5728, column 16. See page 59 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 5757, column 22. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/x" flag at line 5757, column 22. See page 236 of PBP. (Severity: 3) -Regular expression without "/m" flag at line 5757, column 22. See page 237 of PBP. (Severity: 2) -Magic punctuation variable $@ used at line 5758, column 8. See page 79 of PBP. (Severity: 2) -Magic punctuation variable $@ used in interpolated string at line 5758, column 21. See page 79 of PBP. (Severity: 2) -Expression form of "eval" at line 5762, column 13. See page 161 of PBP. (Severity: 5) -Magic punctuation variable $@ used at line 5765, column 24. See page 79 of PBP. (Severity: 2) -Magic punctuation variable $@ used in interpolated string at line 5766, column 10. See page 79 of PBP. (Severity: 2) -Long number not separated with underscores at line 5782, column 46. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 5783, column 46. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 5785, column 46. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 5786, column 46. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 5788, column 46. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 5789, column 46. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 5791, column 46. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 5792, column 46. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 5794, column 46. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 5795, column 46. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 5797, column 49. See page 59 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 5806, column 23. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 5852, column 65. See pages 93,94 of PBP. (Severity: 2) -Too many arguments at line 5926, column 1. See page 182 of PBP. (Severity: 3) -Double-sigil dereference at line 5930, column 29. See page 228 of PBP. (Severity: 2) -Double-sigil dereference at line 5941, column 43. See page 228 of PBP. (Severity: 2) -Postfix control "unless" used at line 5964, column 29. See pages 96,97 of PBP. (Severity: 2) -Double-sigil dereference at line 5990, column 29. See page 228 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6001, column 30. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6001, column 30. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6016, column 24. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6016, column 24. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6019, column 24. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6019, column 24. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6022, column 24. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6022, column 24. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6025, column 24. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6025, column 24. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6028, column 24. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6028, column 24. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6031, column 98. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6031, column 98. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6043, column 37. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6043, column 41. See page 53 of PBP. (Severity: 2) -Numeric escapes in interpolated string at line 6049, column 51. See pages 54,55 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6059, column 21. See page 53 of PBP. (Severity: 2) -Magic punctuation variable $! used in interpolated string at line 6061, column 52. See page 79 of PBP. (Severity: 2) -Return value of "close" ignored at line 6063, column 9. Check the return value of "close" for success. (Severity: 2) -Magic punctuation variable $! used in interpolated string at line 6072, column 46. See page 79 of PBP. (Severity: 2) -Return value of "close" ignored at line 6074, column 2. Check the return value of "close" for success. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6075, column 14. See page 53 of PBP. (Severity: 2) -Magic punctuation variable $! used in interpolated string at line 6081, column 70. See page 79 of PBP. (Severity: 2) -Return value of "close" ignored at line 6083, column 2. Check the return value of "close" for success. (Severity: 2) -Always unpack @_ first at line 6088, column 1. See page 178 of PBP. (Severity: 4) -Backtick operator used at line 6095, column 4. Use IPC::Open3 instead. (Severity: 3) -Subroutine "tests_pipemess" does not end with "return" at line 6112, column 1. See page 197 of PBP. (Severity: 4) -Postfix control "if" used at line 6115, column 31. See pages 93,94 of PBP. (Severity: 2) -List of quoted literal words at line 6120, column 47. Use 'qw()' instead. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6123, column 28. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 6128, column 27. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6141, column 28. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6158, column 21. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6158, column 21. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6182, column 24. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6182, column 24. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6191, column 29. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6191, column 29. See page 237 of PBP. (Severity: 2) -Magic punctuation variable $0 used at line 6198, column 18. See page 79 of PBP. (Severity: 2) -Return value of "close" ignored at line 6221, column 2. Check the return value of "close" for success. (Severity: 2) -Magic punctuation variable $! used in interpolated string at line 6241, column 20. See page 79 of PBP. (Severity: 2) -Magic punctuation variable $@ used at line 6255, column 23. See page 79 of PBP. (Severity: 2) -Magic punctuation variable $@ used at line 6257, column 7. See page 79 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6257, column 13. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6257, column 13. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6272, column 20. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6274, column 11. See page 53 of PBP. (Severity: 2) -Backtick operator used at line 6301, column 12. Use IPC::Open3 instead. (Severity: 3) -Backtick operator used at line 6321, column 11. Use IPC::Open3 instead. (Severity: 3) -String delimiter used with "split" at line 6326, column 28. Express it as a regex instead. (Severity: 2) -Quotes used with a noisy string at line 6326, column 34. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 6356, column 34. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 6368, column 31. See pages 93,94 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6400, column 17. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6400, column 17. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6409, column 17. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6409, column 17. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6447, column 13. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6450, column 17. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6450, column 17. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 6453, column 16. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6453, column 30. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 6454, column 22. See pages 93,94 of PBP. (Severity: 2) -Split long regexps into smaller qr// chunks at line 6459, column 12. See page 261 of PBP. (Severity: 3) -Regular expression without "/s" flag at line 6459, column 12. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6459, column 12. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 6471, column 38. See pages 93,94 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6471, column 72. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6471, column 72. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 6472, column 38. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 6474, column 46. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 6478, column 30. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 6480, column 34. See pages 93,94 of PBP. (Severity: 2) -Split long regexps into smaller qr// chunks at line 6485, column 12. See page 261 of PBP. (Severity: 3) -Regular expression without "/s" flag at line 6485, column 12. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6485, column 12. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6501, column 19. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6501, column 19. See page 237 of PBP. (Severity: 2) -Split long regexps into smaller qr// chunks at line 6514, column 12. See page 261 of PBP. (Severity: 3) -Regular expression without "/s" flag at line 6514, column 12. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6514, column 12. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 6520, column 29. See pages 93,94 of PBP. (Severity: 2) -Split long regexps into smaller qr// chunks at line 6526, column 12. See page 261 of PBP. (Severity: 3) -Regular expression without "/s" flag at line 6526, column 12. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6526, column 12. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6537, column 12. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6537, column 12. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6558, column 5. See page 53 of PBP. (Severity: 2) -Double-sigil dereference at line 6611, column 33. See page 228 of PBP. (Severity: 2) -Expression form of "eval" at line 6632, column 43. See page 161 of PBP. (Severity: 5) -Expression form of "eval" at line 6636, column 45. See page 161 of PBP. (Severity: 5) -Postfix control "if" used at line 6641, column 34. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 6642, column 36. See pages 93,94 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6656, column 33. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6656, column 33. See page 237 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6657, column 36. See page 53 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6695, column 27. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6695, column 27. See page 237 of PBP. (Severity: 2) -Use 'eq' or hash instead of fixed-pattern regexps at line 6699, column 36. See pages 271,272 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6699, column 36. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6699, column 36. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6701, column 31. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6701, column 31. See page 237 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 6707, column 34. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6707, column 34. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 6710, column 65. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6836, column 17. See page 53 of PBP. (Severity: 2) -Split long regexps into smaller qr// chunks at line 6841, column 20. See page 261 of PBP. (Severity: 3) -Regular expression without "/s" flag at line 6841, column 20. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 6841, column 20. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 6847, column 28. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a noisy string at line 6847, column 33. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 6848, column 28. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a noisy string at line 6848, column 33. See page 53 of PBP. (Severity: 2) -Long number not separated with underscores at line 6881, column 55. See page 59 of PBP. (Severity: 2) -"$i" is declared but not used at line 6900, column 9. Unused variables clutter code and make it harder to read. (Severity: 3) -Quotes used with a string containing no non-whitespace characters at line 6911, column 28. See page 53 of PBP. (Severity: 2) -Long number not separated with underscores at line 6919, column 40. See page 59 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6932, column 14. See page 53 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6933, column 32. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 6944, column 66. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a string containing no non-whitespace characters at line 6946, column 26. See page 53 of PBP. (Severity: 2) -Magic variable "$ENV" should be assigned as "local" at line 6947, column 12. See pages 81,82 of PBP. (Severity: 4) -Postfix control "unless" used at line 6948, column 16. See pages 96,97 of PBP. (Severity: 2) -Long number not separated with underscores at line 6952, column 58. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 6953, column 58. See page 59 of PBP. (Severity: 2) -Long number not separated with underscores at line 6954, column 69. See page 59 of PBP. (Severity: 2) -Magic variable "$ENV" should be assigned as "local" at line 6955, column 12. See pages 81,82 of PBP. (Severity: 4) -Postfix control "unless" used at line 6956, column 16. See pages 96,97 of PBP. (Severity: 2) -Test without a label at line 6962, column 2. Add a label argument to all Test::More functions. (Severity: 3) -Test without a label at line 6963, column 2. Add a label argument to all Test::More functions. (Severity: 3) -Reused variable name in lexical scope: $logfile at line 6968, column 2. Invent unique variable names. (Severity: 3) -Subroutine "teelaunch" does not end with "return" at line 6975, column 1. See page 197 of PBP. (Severity: 4) -Reused variable name in lexical scope: $logfile at line 6976, column 2. Invent unique variable names. (Severity: 3) -Magic punctuation variable $! used in interpolated string at line 6977, column 36. See page 79 of PBP. (Severity: 2) -Close filehandles as soon as possible after opening them at line 6979, column 2. See page 209 of PBP. (Severity: 4) -"die" used instead of "croak" at line 6980, column 7. See page 283 of PBP. (Severity: 3) -Magic punctuation variable $! used in interpolated string at line 6980, column 12. See page 79 of PBP. (Severity: 2) -Magic variable "*STDERR" should be assigned as "local" at line 6982, column 10. See pages 81,82 of PBP. (Severity: 4) -Double-sigil dereference at line 6982, column 12. See page 228 of PBP. (Severity: 2) -One-argument "select" used at line 6983, column 2. See page 224 of PBP. (Severity: 4) -Quotes used with a string containing no non-whitespace characters at line 6989, column 25. See page 53 of PBP. (Severity: 2) -Postfix control "if" used at line 6990, column 43. See pages 93,94 of PBP. (Severity: 2) -Quotes used with a noisy string at line 6991, column 54. See page 53 of PBP. (Severity: 2) -Quotes used with a noisy string at line 6991, column 60. See page 53 of PBP. (Severity: 2) -Magic punctuation variable $0 used in interpolated here-document at line 6992, column 15. See page 79 of PBP. (Severity: 2) -Numeric escapes in interpolated string at line 7269, column 21. See pages 54,55 of PBP. (Severity: 2) -Regular expression without "/s" flag at line 7274, column 16. See pages 240,241 of PBP. (Severity: 2) -Regular expression without "/m" flag at line 7274, column 16. See page 237 of PBP. (Severity: 2) -Postfix control "if" used at line 7431, column 51. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 7447, column 12. See pages 93,94 of PBP. (Severity: 2) -Postfix control "if" used at line 7451, column 32. See pages 93,94 of PBP. (Severity: 2) -Postfix control "unless" used at line 7454, column 30. See pages 96,97 of PBP. (Severity: 2) -Postfix control "if" used at line 7457, column 16. See pages 93,94 of PBP. (Severity: 2) -Subroutine "testslive" does not end with "return" at line 7462, column 1. See page 197 of PBP. (Severity: 4) -Postfix control "if" used at line 7473, column 32. See pages 93,94 of PBP. (Severity: 2) -Return value of eval not tested at line 7484, column 17. You can't depend upon the value of $@/$EVAL_ERROR to tell whether an eval failed. (Severity: 3) -Postfix control "if" used at line 7496, column 32. See pages 93,94 of PBP. (Severity: 2) -Return value of eval not tested at line 7523, column 17. You can't depend upon the value of $@/$EVAL_ERROR to tell whether an eval failed. (Severity: 3) -Postfix control "if" used at line 7573, column 33. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3553, column 17. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3559, column 6. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 3572, column 21. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 3572, column 21. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3573, column 44. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3576, column 24. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 3584, column 21. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 3584, column 21. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3585, column 40. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3588, column 24. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 3610, column 67. See pages 93,94 of PBP. (Severity: 2) +Subroutine "select_msgs" does not end with "return" at line 3630, column 1. See page 197 of PBP. (Severity: 4) +Long number not separated with underscores at line 3716, column 63. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 3717, column 63. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 3738, column 45. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 3741, column 46. See page 59 of PBP. (Severity: 2) +Double-sigil dereference at line 3752, column 9. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 3753, column 9. See page 228 of PBP. (Severity: 2) +"unless" block used at line 3756, column 3. See page 97 of PBP. (Severity: 2) +"unless" block used at line 3757, column 3. See page 97 of PBP. (Severity: 2) +Subroutine "tests_msgs_from_maxmin" does not end with "return" at line 3771, column 1. See page 197 of PBP. (Severity: 4) +Postfix control "if" used at line 3819, column 22. See pages 93,94 of PBP. (Severity: 2) +Subroutine "copy_message" with high complexity score (25) at line 3848, column 1. Consider refactoring. (Severity: 3) +Too many arguments at line 3848, column 1. See page 182 of PBP. (Severity: 3) +Quotes used with a string containing no non-whitespace characters at line 3855, column 54. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3856, column 61. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 3866, column 41. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 3867, column 95. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 3909, column 19. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3909, column 35. See page 53 of PBP. (Severity: 2) +Too many arguments at line 3926, column 1. See page 182 of PBP. (Severity: 3) +Too many arguments at line 3960, column 1. See page 182 of PBP. (Severity: 3) +Quotes used with a string containing no non-whitespace characters at line 3965, column 60. See page 53 of PBP. (Severity: 2) +"unless" block used at line 3967, column 2. See page 97 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3969, column 21. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 3971, column 25. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 3974, column 34. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4030, column 3. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4033, column 49. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4041, column 16. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 4063, column 15. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 4063, column 15. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 4068, column 37. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 4069, column 64. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4076, column 16. See page 53 of PBP. (Severity: 2) +Subroutine "tests_subject" does not end with "return" at line 4087, column 1. See page 197 of PBP. (Severity: 4) +Quotes used with a string containing no non-whitespace characters at line 4088, column 6. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4088, column 21. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4128, column 6. See page 53 of PBP. (Severity: 2) +Too many arguments at line 4150, column 1. See page 182 of PBP. (Severity: 3) +Quotes used with a string containing no non-whitespace characters at line 4159, column 63. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 4171, column 20. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 4171, column 20. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 4189, column 75. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 4189, column 75. See page 237 of PBP. (Severity: 2) +Subroutine "sleep_if_needed" does not end with "return" at line 4211, column 1. See page 197 of PBP. (Severity: 4) +Reused variable name in lexical scope: $total_bytes_transferred at line 4212, column 2. Invent unique variable names. (Severity: 3) +Reused variable name in lexical scope: $nb_msg_transferred at line 4212, column 2. Invent unique variable names. (Severity: 3) +Reused variable name in lexical scope: $nb_msg_transferred at line 4224, column 9. Invent unique variable names. (Severity: 3) +Reused variable name in lexical scope: $maxmessagespersecond at line 4224, column 9. Invent unique variable names. (Severity: 3) +Reused variable name in lexical scope: $total_bytes_transferred at line 4245, column 9. Invent unique variable names. (Severity: 3) +Reused variable name in lexical scope: $maxbytespersecond at line 4245, column 9. Invent unique variable names. (Severity: 3) +Postfix control "if" used at line 4273, column 28. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4281, column 10. See page 53 of PBP. (Severity: 2) +Double-sigil dereference at line 4314, column 2. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 4314, column 22. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 4315, column 2. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 4315, column 22. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 4317, column 26. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 4374, column 37. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 4375, column 37. See page 228 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 4388, column 23. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 4388, column 23. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 4408, column 23. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 4408, column 23. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4482, column 35. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4482, column 46. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4482, column 57. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4482, column 68. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4482, column 79. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4483, column 35. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4483, column 46. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4483, column 57. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4483, column 68. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4483, column 79. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4483, column 90. See page 53 of PBP. (Severity: 2) +Double-sigil dereference at line 4487, column 37. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 4488, column 37. See page 228 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4530, column 32. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4530, column 43. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4530, column 54. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4530, column 65. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4530, column 76. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4531, column 32. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4531, column 43. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4531, column 54. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4531, column 65. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4531, column 76. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4531, column 87. See page 53 of PBP. (Severity: 2) +Double-sigil dereference at line 4534, column 34. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 4535, column 34. See page 228 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 4550, column 16. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 4550, column 16. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4563, column 47. See page 53 of PBP. (Severity: 2) +Double-sigil dereference at line 4595, column 78. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 4596, column 21. See page 228 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4599, column 102. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4608, column 29. See page 53 of PBP. (Severity: 2) +Magic punctuation variable $! used in interpolated string at line 4608, column 29. See page 79 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4647, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4648, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4652, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4653, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4654, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4698, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4699, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4700, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4704, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4705, column 24. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4706, column 24. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 4729, column 38. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 4736, column 40. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4740, column 43. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4741, column 45. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4795, column 33. See page 53 of PBP. (Severity: 2) +Hard tabs used at line 4830, column 10. See page 20 of PBP. (Severity: 3) +Quotes used with a string containing no non-whitespace characters at line 4865, column 43. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4866, column 44. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4867, column 48. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4872, column 6. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4872, column 28. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4872, column 32. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4872, column 36. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4872, column 40. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4873, column 35. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4873, column 39. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4873, column 43. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4880, column 25. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4881, column 25. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 4897, column 21. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 4897, column 21. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 4899, column 20. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 4899, column 20. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 4913, column 31. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 4918, column 32. See pages 93,94 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 4929, column 13. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 4929, column 13. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4935, column 5. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4935, column 32. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4935, column 36. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4936, column 46. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4937, column 54. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4940, column 54. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 4941, column 60. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4962, column 15. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4963, column 15. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4979, column 15. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4980, column 15. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4983, column 15. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 4992, column 15. See page 53 of PBP. (Severity: 2) +Expression form of "eval" at line 5434, column 13. See page 161 of PBP. (Severity: 5) +Magic punctuation variable $@ used at line 5436, column 38. See page 79 of PBP. (Severity: 2) +Magic punctuation variable $@ used in interpolated string at line 5437, column 10. See page 79 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 5463, column 21. See page 53 of PBP. (Severity: 2) +Numeric escapes in interpolated string at line 5472, column 21. See pages 54,55 of PBP. (Severity: 2) +Numeric escapes in interpolated string at line 5477, column 21. See pages 54,55 of PBP. (Severity: 2) +Long number not separated with underscores at line 5629, column 16. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 5640, column 16. See page 59 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 5669, column 22. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/x" flag at line 5669, column 22. See page 236 of PBP. (Severity: 3) +Regular expression without "/m" flag at line 5669, column 22. See page 237 of PBP. (Severity: 2) +Magic punctuation variable $@ used at line 5670, column 8. See page 79 of PBP. (Severity: 2) +Magic punctuation variable $@ used in interpolated string at line 5670, column 21. See page 79 of PBP. (Severity: 2) +Expression form of "eval" at line 5674, column 13. See page 161 of PBP. (Severity: 5) +Magic punctuation variable $@ used at line 5677, column 24. See page 79 of PBP. (Severity: 2) +Magic punctuation variable $@ used in interpolated string at line 5678, column 10. See page 79 of PBP. (Severity: 2) +Long number not separated with underscores at line 5694, column 46. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 5695, column 46. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 5697, column 46. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 5698, column 46. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 5700, column 46. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 5701, column 46. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 5703, column 46. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 5704, column 46. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 5706, column 46. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 5707, column 46. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 5709, column 49. See page 59 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 5718, column 23. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 5764, column 65. See pages 93,94 of PBP. (Severity: 2) +Too many arguments at line 5838, column 1. See page 182 of PBP. (Severity: 3) +Double-sigil dereference at line 5842, column 29. See page 228 of PBP. (Severity: 2) +Double-sigil dereference at line 5853, column 43. See page 228 of PBP. (Severity: 2) +Postfix control "unless" used at line 5876, column 29. See pages 96,97 of PBP. (Severity: 2) +Double-sigil dereference at line 5902, column 29. See page 228 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 5913, column 30. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 5913, column 30. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 5928, column 24. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 5928, column 24. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 5931, column 24. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 5931, column 24. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 5934, column 24. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 5934, column 24. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 5937, column 24. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 5937, column 24. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 5940, column 24. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 5940, column 24. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 5943, column 98. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 5943, column 98. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 5955, column 37. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 5955, column 41. See page 53 of PBP. (Severity: 2) +Numeric escapes in interpolated string at line 5961, column 51. See pages 54,55 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 5971, column 21. See page 53 of PBP. (Severity: 2) +Magic punctuation variable $! used in interpolated string at line 5973, column 52. See page 79 of PBP. (Severity: 2) +Return value of "close" ignored at line 5975, column 9. Check the return value of "close" for success. (Severity: 2) +Magic punctuation variable $! used in interpolated string at line 5984, column 46. See page 79 of PBP. (Severity: 2) +Return value of "close" ignored at line 5986, column 2. Check the return value of "close" for success. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 5987, column 14. See page 53 of PBP. (Severity: 2) +Magic punctuation variable $! used in interpolated string at line 5993, column 70. See page 79 of PBP. (Severity: 2) +Return value of "close" ignored at line 5995, column 2. Check the return value of "close" for success. (Severity: 2) +Always unpack @_ first at line 6000, column 1. See page 178 of PBP. (Severity: 4) +Backtick operator used at line 6007, column 4. Use IPC::Open3 instead. (Severity: 3) +Subroutine "tests_pipemess" does not end with "return" at line 6024, column 1. See page 197 of PBP. (Severity: 4) +Postfix control "if" used at line 6027, column 31. See pages 93,94 of PBP. (Severity: 2) +List of quoted literal words at line 6032, column 47. Use 'qw()' instead. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6035, column 28. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 6040, column 27. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6053, column 28. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6070, column 21. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6070, column 21. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6094, column 24. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6094, column 24. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6103, column 29. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6103, column 29. See page 237 of PBP. (Severity: 2) +Magic punctuation variable $0 used at line 6110, column 18. See page 79 of PBP. (Severity: 2) +Return value of "close" ignored at line 6133, column 2. Check the return value of "close" for success. (Severity: 2) +Magic punctuation variable $! used in interpolated string at line 6153, column 20. See page 79 of PBP. (Severity: 2) +Magic punctuation variable $@ used at line 6167, column 23. See page 79 of PBP. (Severity: 2) +Magic punctuation variable $@ used at line 6169, column 7. See page 79 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6169, column 13. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6169, column 13. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6184, column 20. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6186, column 11. See page 53 of PBP. (Severity: 2) +Backtick operator used at line 6213, column 12. Use IPC::Open3 instead. (Severity: 3) +Backtick operator used at line 6233, column 11. Use IPC::Open3 instead. (Severity: 3) +String delimiter used with "split" at line 6238, column 28. Express it as a regex instead. (Severity: 2) +Quotes used with a noisy string at line 6238, column 34. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 6268, column 34. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 6280, column 31. See pages 93,94 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6312, column 17. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6312, column 17. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6321, column 17. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6321, column 17. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6361, column 13. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6364, column 17. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6364, column 17. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 6367, column 16. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6367, column 30. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 6368, column 22. See pages 93,94 of PBP. (Severity: 2) +Split long regexps into smaller qr// chunks at line 6373, column 12. See page 261 of PBP. (Severity: 3) +Regular expression without "/s" flag at line 6373, column 12. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6373, column 12. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 6385, column 38. See pages 93,94 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6385, column 72. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6385, column 72. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 6386, column 38. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 6388, column 46. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 6392, column 30. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 6394, column 34. See pages 93,94 of PBP. (Severity: 2) +Split long regexps into smaller qr// chunks at line 6399, column 12. See page 261 of PBP. (Severity: 3) +Regular expression without "/s" flag at line 6399, column 12. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6399, column 12. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6415, column 19. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6415, column 19. See page 237 of PBP. (Severity: 2) +Split long regexps into smaller qr// chunks at line 6428, column 12. See page 261 of PBP. (Severity: 3) +Regular expression without "/s" flag at line 6428, column 12. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6428, column 12. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 6434, column 29. See pages 93,94 of PBP. (Severity: 2) +Split long regexps into smaller qr// chunks at line 6440, column 12. See page 261 of PBP. (Severity: 3) +Regular expression without "/s" flag at line 6440, column 12. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6440, column 12. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6451, column 12. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6451, column 12. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6472, column 5. See page 53 of PBP. (Severity: 2) +Double-sigil dereference at line 6525, column 33. See page 228 of PBP. (Severity: 2) +Expression form of "eval" at line 6546, column 43. See page 161 of PBP. (Severity: 5) +Expression form of "eval" at line 6550, column 45. See page 161 of PBP. (Severity: 5) +Postfix control "if" used at line 6555, column 34. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 6556, column 36. See pages 93,94 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6570, column 33. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6570, column 33. See page 237 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6571, column 36. See page 53 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6609, column 27. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6609, column 27. See page 237 of PBP. (Severity: 2) +Use 'eq' or hash instead of fixed-pattern regexps at line 6613, column 36. See pages 271,272 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6613, column 36. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6613, column 36. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6615, column 31. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6615, column 31. See page 237 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 6621, column 34. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6621, column 34. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 6624, column 65. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6750, column 17. See page 53 of PBP. (Severity: 2) +Split long regexps into smaller qr// chunks at line 6755, column 20. See page 261 of PBP. (Severity: 3) +Regular expression without "/s" flag at line 6755, column 20. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 6755, column 20. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 6761, column 28. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a noisy string at line 6761, column 33. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 6762, column 28. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a noisy string at line 6762, column 33. See page 53 of PBP. (Severity: 2) +Long number not separated with underscores at line 6795, column 55. See page 59 of PBP. (Severity: 2) +"$i" is declared but not used at line 6814, column 9. Unused variables clutter code and make it harder to read. (Severity: 3) +Quotes used with a string containing no non-whitespace characters at line 6825, column 28. See page 53 of PBP. (Severity: 2) +Long number not separated with underscores at line 6833, column 40. See page 59 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6846, column 14. See page 53 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6847, column 32. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 6858, column 66. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a string containing no non-whitespace characters at line 6860, column 26. See page 53 of PBP. (Severity: 2) +Magic variable "$ENV" should be assigned as "local" at line 6861, column 12. See pages 81,82 of PBP. (Severity: 4) +Postfix control "unless" used at line 6862, column 16. See pages 96,97 of PBP. (Severity: 2) +Long number not separated with underscores at line 6866, column 58. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 6867, column 58. See page 59 of PBP. (Severity: 2) +Long number not separated with underscores at line 6868, column 69. See page 59 of PBP. (Severity: 2) +Magic variable "$ENV" should be assigned as "local" at line 6869, column 12. See pages 81,82 of PBP. (Severity: 4) +Postfix control "unless" used at line 6870, column 16. See pages 96,97 of PBP. (Severity: 2) +Test without a label at line 6876, column 2. Add a label argument to all Test::More functions. (Severity: 3) +Test without a label at line 6877, column 2. Add a label argument to all Test::More functions. (Severity: 3) +Reused variable name in lexical scope: $logfile at line 6882, column 2. Invent unique variable names. (Severity: 3) +Subroutine "teelaunch" does not end with "return" at line 6889, column 1. See page 197 of PBP. (Severity: 4) +Reused variable name in lexical scope: $logfile at line 6890, column 2. Invent unique variable names. (Severity: 3) +Magic punctuation variable $! used in interpolated string at line 6891, column 36. See page 79 of PBP. (Severity: 2) +Close filehandles as soon as possible after opening them at line 6893, column 2. See page 209 of PBP. (Severity: 4) +"die" used instead of "croak" at line 6894, column 7. See page 283 of PBP. (Severity: 3) +Magic punctuation variable $! used in interpolated string at line 6894, column 12. See page 79 of PBP. (Severity: 2) +Magic variable "*STDERR" should be assigned as "local" at line 6896, column 10. See pages 81,82 of PBP. (Severity: 4) +Double-sigil dereference at line 6896, column 12. See page 228 of PBP. (Severity: 2) +One-argument "select" used at line 6897, column 2. See page 224 of PBP. (Severity: 4) +Quotes used with a string containing no non-whitespace characters at line 6903, column 25. See page 53 of PBP. (Severity: 2) +Postfix control "if" used at line 6904, column 43. See pages 93,94 of PBP. (Severity: 2) +Quotes used with a noisy string at line 6905, column 54. See page 53 of PBP. (Severity: 2) +Quotes used with a noisy string at line 6905, column 60. See page 53 of PBP. (Severity: 2) +Magic punctuation variable $0 used in interpolated here-document at line 6906, column 15. See page 79 of PBP. (Severity: 2) +Numeric escapes in interpolated string at line 7194, column 21. See pages 54,55 of PBP. (Severity: 2) +Regular expression without "/s" flag at line 7199, column 16. See pages 240,241 of PBP. (Severity: 2) +Regular expression without "/m" flag at line 7199, column 16. See page 237 of PBP. (Severity: 2) +Postfix control "if" used at line 7358, column 51. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 7372, column 12. See pages 93,94 of PBP. (Severity: 2) +Postfix control "if" used at line 7376, column 32. See pages 93,94 of PBP. (Severity: 2) +Postfix control "unless" used at line 7379, column 30. See pages 96,97 of PBP. (Severity: 2) +Postfix control "if" used at line 7382, column 16. See pages 93,94 of PBP. (Severity: 2) +Subroutine "testslive" does not end with "return" at line 7387, column 1. See page 197 of PBP. (Severity: 4) +Postfix control "if" used at line 7398, column 32. See pages 93,94 of PBP. (Severity: 2) +Return value of eval not tested at line 7409, column 17. You can't depend upon the value of $@/$EVAL_ERROR to tell whether an eval failed. (Severity: 3) +Postfix control "if" used at line 7421, column 32. See pages 93,94 of PBP. (Severity: 2) +Return value of eval not tested at line 7448, column 17. You can't depend upon the value of $@/$EVAL_ERROR to tell whether an eval failed. (Severity: 3) +Postfix control "if" used at line 7498, column 33. See pages 93,94 of PBP. (Severity: 2) diff --git a/W/perlcritic_3.out b/W/perlcritic_3.out index 6490704..b590406 100644 --- a/W/perlcritic_3.out +++ b/W/perlcritic_3.out @@ -1,86 +1,87 @@ -Main code has high complexity score (381) at line 1, column 1. Consider refactoring. (Severity: 3) -Literal line breaks in a string at line 1028, column 1. See pages 60,61 of PBP. (Severity: 3) -Literal line breaks in a string at line 1040, column 1. See pages 60,61 of PBP. (Severity: 3) -Regular expression without "/x" flag at line 1212, column 33. See page 236 of PBP. (Severity: 3) -Regular expression without "/x" flag at line 1221, column 33. See page 236 of PBP. (Severity: 3) -Regular expression without "/x" flag at line 1238, column 18. See page 236 of PBP. (Severity: 3) -Literal line breaks in a string at line 1312, column 1. See pages 60,61 of PBP. (Severity: 3) -Literal line breaks in a string at line 1345, column 1. See pages 60,61 of PBP. (Severity: 3) -Code structure is deeply nested at line 1711, column 41. Consider refactoring. (Severity: 3) -Literal line breaks in a string at line 1859, column 1. See pages 60,61 of PBP. (Severity: 3) -Subroutine "errors_incr" does not end with "return" at line 1881, column 1. See page 197 of PBP. (Severity: 4) -Subroutine "tests_live_result" does not end with "return" at line 1906, column 1. See page 197 of PBP. (Severity: 4) -Reused variable name in lexical scope: $nb_errors at line 1907, column 2. Invent unique variable names. (Severity: 3) -Subroutine "foldersizesatend" does not end with "return" at line 1915, column 1. See page 197 of PBP. (Severity: 4) -Too many arguments at line 1941, column 1. See page 182 of PBP. (Severity: 3) -Too many arguments at line 1959, column 1. See page 182 of PBP. (Severity: 3) -Too many arguments at line 1969, column 1. See page 182 of PBP. (Severity: 3) -Too many arguments at line 2216, column 1. See page 182 of PBP. (Severity: 3) -Too many arguments at line 2277, column 1. See page 182 of PBP. (Severity: 3) -Subroutine "authenticate_imap" with high complexity score (21) at line 2338, column 1. Consider refactoring. (Severity: 3) -Too many arguments at line 2338, column 1. See page 182 of PBP. (Severity: 3) -Too many arguments at line 2442, column 1. See page 182 of PBP. (Severity: 3) -Regular expression without "/x" flag at line 2515, column 51. See page 236 of PBP. (Severity: 3) -Backtick operator used at line 2523, column 12. Use IPC::Open3 instead. (Severity: 3) -Subroutine "is_valid_directory" does not end with "return" at line 2653, column 1. See page 197 of PBP. (Severity: 4) -Close filehandles as soon as possible after opening them at line 2673, column 2. See page 209 of PBP. (Severity: 4) -Subroutine "remove_tmp_files" does not end with "return" at line 2684, column 1. See page 197 of PBP. (Severity: 4) -"die" used instead of "croak" at line 2698, column 2. See page 283 of PBP. (Severity: 3) -Always unpack @_ first at line 2799, column 1. See page 178 of PBP. (Severity: 4) -Regular expression without "/x" flag at line 2806, column 15. See page 236 of PBP. (Severity: 3) -Regular expression without "/x" flag at line 2807, column 15. See page 236 of PBP. (Severity: 3) -Regular expression without "/x" flag at line 2808, column 15. See page 236 of PBP. (Severity: 3) -Regular expression without "/x" flag at line 2834, column 31. See page 236 of PBP. (Severity: 3) -Reused variable name in lexical scope: $imap2 at line 2894, column 9. Invent unique variable names. (Severity: 3) -Regular expression without "/x" flag at line 2913, column 25. See page 236 of PBP. (Severity: 3) -Regular expression without "/x" flag at line 2916, column 20. See page 236 of PBP. (Severity: 3) -Mixed high and low-precedence booleans at line 2917, column 13. See page 70 of PBP. (Severity: 4) -Expression form of "eval" at line 3356, column 13. See page 161 of PBP. (Severity: 5) -Expression form of "eval" at line 3581, column 13. See page 161 of PBP. (Severity: 5) -Subroutine "select_msgs" does not end with "return" at line 3722, column 1. See page 197 of PBP. (Severity: 4) -Subroutine "tests_msgs_from_maxmin" does not end with "return" at line 3861, column 1. See page 197 of PBP. (Severity: 4) -Subroutine "copy_message" with high complexity score (25) at line 3938, column 1. Consider refactoring. (Severity: 3) -Too many arguments at line 3938, column 1. See page 182 of PBP. (Severity: 3) -Too many arguments at line 4016, column 1. See page 182 of PBP. (Severity: 3) -Too many arguments at line 4050, column 1. See page 182 of PBP. (Severity: 3) -Subroutine "tests_subject" does not end with "return" at line 4177, column 1. See page 197 of PBP. (Severity: 4) -Too many arguments at line 4240, column 1. See page 182 of PBP. (Severity: 3) -Subroutine "sleep_if_needed" does not end with "return" at line 4299, column 1. See page 197 of PBP. (Severity: 4) -Reused variable name in lexical scope: $total_bytes_transferred at line 4300, column 2. Invent unique variable names. (Severity: 3) -Reused variable name in lexical scope: $nb_msg_transferred at line 4300, column 2. Invent unique variable names. (Severity: 3) -Reused variable name in lexical scope: $nb_msg_transferred at line 4312, column 9. Invent unique variable names. (Severity: 3) -Reused variable name in lexical scope: $maxmessagespersecond at line 4312, column 9. Invent unique variable names. (Severity: 3) -Reused variable name in lexical scope: $total_bytes_transferred at line 4333, column 9. Invent unique variable names. (Severity: 3) -Reused variable name in lexical scope: $maxbytespersecond at line 4333, column 9. Invent unique variable names. (Severity: 3) -Hard tabs used at line 4918, column 10. See page 20 of PBP. (Severity: 3) -Expression form of "eval" at line 5522, column 13. See page 161 of PBP. (Severity: 5) -Regular expression without "/x" flag at line 5757, column 22. See page 236 of PBP. (Severity: 3) -Expression form of "eval" at line 5762, column 13. See page 161 of PBP. (Severity: 5) -Too many arguments at line 5926, column 1. See page 182 of PBP. (Severity: 3) -Always unpack @_ first at line 6088, column 1. See page 178 of PBP. (Severity: 4) -Backtick operator used at line 6095, column 4. Use IPC::Open3 instead. (Severity: 3) -Subroutine "tests_pipemess" does not end with "return" at line 6112, column 1. See page 197 of PBP. (Severity: 4) -Backtick operator used at line 6301, column 12. Use IPC::Open3 instead. (Severity: 3) -Backtick operator used at line 6321, column 11. Use IPC::Open3 instead. (Severity: 3) -Split long regexps into smaller qr// chunks at line 6459, column 12. See page 261 of PBP. (Severity: 3) -Split long regexps into smaller qr// chunks at line 6485, column 12. See page 261 of PBP. (Severity: 3) -Split long regexps into smaller qr// chunks at line 6514, column 12. See page 261 of PBP. (Severity: 3) -Split long regexps into smaller qr// chunks at line 6526, column 12. See page 261 of PBP. (Severity: 3) -Expression form of "eval" at line 6632, column 43. See page 161 of PBP. (Severity: 5) -Expression form of "eval" at line 6636, column 45. See page 161 of PBP. (Severity: 5) -Split long regexps into smaller qr// chunks at line 6841, column 20. See page 261 of PBP. (Severity: 3) -"$i" is declared but not used at line 6900, column 9. Unused variables clutter code and make it harder to read. (Severity: 3) -Magic variable "$ENV" should be assigned as "local" at line 6947, column 12. See pages 81,82 of PBP. (Severity: 4) -Magic variable "$ENV" should be assigned as "local" at line 6955, column 12. See pages 81,82 of PBP. (Severity: 4) -Test without a label at line 6962, column 2. Add a label argument to all Test::More functions. (Severity: 3) -Test without a label at line 6963, column 2. Add a label argument to all Test::More functions. (Severity: 3) -Reused variable name in lexical scope: $logfile at line 6968, column 2. Invent unique variable names. (Severity: 3) -Subroutine "teelaunch" does not end with "return" at line 6975, column 1. See page 197 of PBP. (Severity: 4) -Reused variable name in lexical scope: $logfile at line 6976, column 2. Invent unique variable names. (Severity: 3) -Close filehandles as soon as possible after opening them at line 6979, column 2. See page 209 of PBP. (Severity: 4) -"die" used instead of "croak" at line 6980, column 7. See page 283 of PBP. (Severity: 3) -Magic variable "*STDERR" should be assigned as "local" at line 6982, column 10. See pages 81,82 of PBP. (Severity: 4) -One-argument "select" used at line 6983, column 2. See page 224 of PBP. (Severity: 4) -Subroutine "testslive" does not end with "return" at line 7462, column 1. See page 197 of PBP. (Severity: 4) -Return value of eval not tested at line 7484, column 17. You can't depend upon the value of $@/$EVAL_ERROR to tell whether an eval failed. (Severity: 3) -Return value of eval not tested at line 7523, column 17. You can't depend upon the value of $@/$EVAL_ERROR to tell whether an eval failed. (Severity: 3) +Main code has high complexity score (387) at line 1, column 1. Consider refactoring. (Severity: 3) +Literal line breaks in a string at line 918, column 1. See pages 60,61 of PBP. (Severity: 3) +Literal line breaks in a string at line 930, column 1. See pages 60,61 of PBP. (Severity: 3) +Regular expression without "/x" flag at line 1112, column 33. See page 236 of PBP. (Severity: 3) +Regular expression without "/x" flag at line 1121, column 33. See page 236 of PBP. (Severity: 3) +Regular expression without "/x" flag at line 1138, column 18. See page 236 of PBP. (Severity: 3) +Literal line breaks in a string at line 1212, column 1. See pages 60,61 of PBP. (Severity: 3) +Literal line breaks in a string at line 1245, column 1. See pages 60,61 of PBP. (Severity: 3) +Code structure is deeply nested at line 1613, column 41. Consider refactoring. (Severity: 3) +Literal line breaks in a string at line 1761, column 1. See pages 60,61 of PBP. (Severity: 3) +Subroutine "errors_incr" does not end with "return" at line 1783, column 1. See page 197 of PBP. (Severity: 4) +Subroutine "tests_live_result" does not end with "return" at line 1808, column 1. See page 197 of PBP. (Severity: 4) +Reused variable name in lexical scope: $nb_errors at line 1809, column 2. Invent unique variable names. (Severity: 3) +Subroutine "foldersizesatend" does not end with "return" at line 1817, column 1. See page 197 of PBP. (Severity: 4) +Too many arguments at line 1843, column 1. See page 182 of PBP. (Severity: 3) +Too many arguments at line 1861, column 1. See page 182 of PBP. (Severity: 3) +Too many arguments at line 1871, column 1. See page 182 of PBP. (Severity: 3) +Subroutine "modules_VERSION" with high complexity score (21) at line 1989, column 1. Consider refactoring. (Severity: 3) +Too many arguments at line 2121, column 1. See page 182 of PBP. (Severity: 3) +Too many arguments at line 2182, column 1. See page 182 of PBP. (Severity: 3) +Subroutine "authenticate_imap" with high complexity score (21) at line 2243, column 1. Consider refactoring. (Severity: 3) +Too many arguments at line 2243, column 1. See page 182 of PBP. (Severity: 3) +Too many arguments at line 2347, column 1. See page 182 of PBP. (Severity: 3) +Regular expression without "/x" flag at line 2420, column 51. See page 236 of PBP. (Severity: 3) +Backtick operator used at line 2428, column 12. Use IPC::Open3 instead. (Severity: 3) +Subroutine "is_valid_directory" does not end with "return" at line 2558, column 1. See page 197 of PBP. (Severity: 4) +Close filehandles as soon as possible after opening them at line 2578, column 2. See page 209 of PBP. (Severity: 4) +Subroutine "remove_tmp_files" does not end with "return" at line 2589, column 1. See page 197 of PBP. (Severity: 4) +"die" used instead of "croak" at line 2603, column 2. See page 283 of PBP. (Severity: 3) +Always unpack @_ first at line 2704, column 1. See page 178 of PBP. (Severity: 4) +Regular expression without "/x" flag at line 2711, column 15. See page 236 of PBP. (Severity: 3) +Regular expression without "/x" flag at line 2712, column 15. See page 236 of PBP. (Severity: 3) +Regular expression without "/x" flag at line 2713, column 15. See page 236 of PBP. (Severity: 3) +Regular expression without "/x" flag at line 2739, column 31. See page 236 of PBP. (Severity: 3) +Reused variable name in lexical scope: $imap2 at line 2799, column 9. Invent unique variable names. (Severity: 3) +Regular expression without "/x" flag at line 2818, column 25. See page 236 of PBP. (Severity: 3) +Regular expression without "/x" flag at line 2821, column 20. See page 236 of PBP. (Severity: 3) +Mixed high and low-precedence booleans at line 2822, column 13. See page 70 of PBP. (Severity: 4) +Expression form of "eval" at line 3263, column 13. See page 161 of PBP. (Severity: 5) +Expression form of "eval" at line 3489, column 13. See page 161 of PBP. (Severity: 5) +Subroutine "select_msgs" does not end with "return" at line 3630, column 1. See page 197 of PBP. (Severity: 4) +Subroutine "tests_msgs_from_maxmin" does not end with "return" at line 3771, column 1. See page 197 of PBP. (Severity: 4) +Subroutine "copy_message" with high complexity score (25) at line 3848, column 1. Consider refactoring. (Severity: 3) +Too many arguments at line 3848, column 1. See page 182 of PBP. (Severity: 3) +Too many arguments at line 3926, column 1. See page 182 of PBP. (Severity: 3) +Too many arguments at line 3960, column 1. See page 182 of PBP. (Severity: 3) +Subroutine "tests_subject" does not end with "return" at line 4087, column 1. See page 197 of PBP. (Severity: 4) +Too many arguments at line 4150, column 1. See page 182 of PBP. (Severity: 3) +Subroutine "sleep_if_needed" does not end with "return" at line 4211, column 1. See page 197 of PBP. (Severity: 4) +Reused variable name in lexical scope: $total_bytes_transferred at line 4212, column 2. Invent unique variable names. (Severity: 3) +Reused variable name in lexical scope: $nb_msg_transferred at line 4212, column 2. Invent unique variable names. (Severity: 3) +Reused variable name in lexical scope: $nb_msg_transferred at line 4224, column 9. Invent unique variable names. (Severity: 3) +Reused variable name in lexical scope: $maxmessagespersecond at line 4224, column 9. Invent unique variable names. (Severity: 3) +Reused variable name in lexical scope: $total_bytes_transferred at line 4245, column 9. Invent unique variable names. (Severity: 3) +Reused variable name in lexical scope: $maxbytespersecond at line 4245, column 9. Invent unique variable names. (Severity: 3) +Hard tabs used at line 4830, column 10. See page 20 of PBP. (Severity: 3) +Expression form of "eval" at line 5434, column 13. See page 161 of PBP. (Severity: 5) +Regular expression without "/x" flag at line 5669, column 22. See page 236 of PBP. (Severity: 3) +Expression form of "eval" at line 5674, column 13. See page 161 of PBP. (Severity: 5) +Too many arguments at line 5838, column 1. See page 182 of PBP. (Severity: 3) +Always unpack @_ first at line 6000, column 1. See page 178 of PBP. (Severity: 4) +Backtick operator used at line 6007, column 4. Use IPC::Open3 instead. (Severity: 3) +Subroutine "tests_pipemess" does not end with "return" at line 6024, column 1. See page 197 of PBP. (Severity: 4) +Backtick operator used at line 6213, column 12. Use IPC::Open3 instead. (Severity: 3) +Backtick operator used at line 6233, column 11. Use IPC::Open3 instead. (Severity: 3) +Split long regexps into smaller qr// chunks at line 6373, column 12. See page 261 of PBP. (Severity: 3) +Split long regexps into smaller qr// chunks at line 6399, column 12. See page 261 of PBP. (Severity: 3) +Split long regexps into smaller qr// chunks at line 6428, column 12. See page 261 of PBP. (Severity: 3) +Split long regexps into smaller qr// chunks at line 6440, column 12. See page 261 of PBP. (Severity: 3) +Expression form of "eval" at line 6546, column 43. See page 161 of PBP. (Severity: 5) +Expression form of "eval" at line 6550, column 45. See page 161 of PBP. (Severity: 5) +Split long regexps into smaller qr// chunks at line 6755, column 20. See page 261 of PBP. (Severity: 3) +"$i" is declared but not used at line 6814, column 9. Unused variables clutter code and make it harder to read. (Severity: 3) +Magic variable "$ENV" should be assigned as "local" at line 6861, column 12. See pages 81,82 of PBP. (Severity: 4) +Magic variable "$ENV" should be assigned as "local" at line 6869, column 12. See pages 81,82 of PBP. (Severity: 4) +Test without a label at line 6876, column 2. Add a label argument to all Test::More functions. (Severity: 3) +Test without a label at line 6877, column 2. Add a label argument to all Test::More functions. (Severity: 3) +Reused variable name in lexical scope: $logfile at line 6882, column 2. Invent unique variable names. (Severity: 3) +Subroutine "teelaunch" does not end with "return" at line 6889, column 1. See page 197 of PBP. (Severity: 4) +Reused variable name in lexical scope: $logfile at line 6890, column 2. Invent unique variable names. (Severity: 3) +Close filehandles as soon as possible after opening them at line 6893, column 2. See page 209 of PBP. (Severity: 4) +"die" used instead of "croak" at line 6894, column 7. See page 283 of PBP. (Severity: 3) +Magic variable "*STDERR" should be assigned as "local" at line 6896, column 10. See pages 81,82 of PBP. (Severity: 4) +One-argument "select" used at line 6897, column 2. See page 224 of PBP. (Severity: 4) +Subroutine "testslive" does not end with "return" at line 7387, column 1. See page 197 of PBP. (Severity: 4) +Return value of eval not tested at line 7409, column 17. You can't depend upon the value of $@/$EVAL_ERROR to tell whether an eval failed. (Severity: 3) +Return value of eval not tested at line 7448, column 17. You can't depend upon the value of $@/$EVAL_ERROR to tell whether an eval failed. (Severity: 3) diff --git a/W/prereq.Ubuntu b/W/prereq.Ubuntu index 11af8c9..e0e0a80 100644 --- a/W/prereq.Ubuntu +++ b/W/prereq.Ubuntu @@ -1,11 +1,11 @@ $SHELL says /bin/bash $0 gives ./INSTALL.d/prerequisites_imapsync -ps -ef gives gilles 14968 14967 0 04:58 pts/13 00:00:00 /bin/sh ./INSTALL.d/prerequisites_imapsync +ps -ef gives gilles 9123 9122 0 20:33 pts/28 00:00:00 /bin/sh ./INSTALL.d/prerequisites_imapsync Distributor ID: Ubuntu Description: Ubuntu 12.04.5 LTS Release: 12.04 Codename: precise -Linux petite 3.2.0-77-generic #114-Ubuntu SMP Tue Mar 10 17:25:28 UTC 2015 i686 i686 i386 GNU/Linux +Linux petite 3.2.0-84-generic #121-Ubuntu SMP Tue May 5 18:55:46 UTC 2015 i686 i686 i386 GNU/Linux Ok: Found Perl 5.14.2 Ok: Found Perl module Digest::HMAC_MD5 Ok: Found Perl module Authen::NTLM diff --git a/W/prereq.scandeps b/W/prereq.scandeps index 773f02a..1fdab08 100644 --- a/W/prereq.scandeps +++ b/W/prereq.scandeps @@ -72,12 +72,17 @@ Several options are mandatory. --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3. --exclude : or this one, etc. +--subfolder2 : Move whole host1 folders hierarchy under this + host2 folder . + It does it by adding two --regextrans2 options before + all others. Add --debug to see what's really going on. + --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. - Have in mind that --regextrans2 is applied after prefix + Have in mind that --regextrans2 is applied after prefix and separator inversion. --tmpdir : Where to store temporary files and subdirectories. @@ -95,8 +100,8 @@ Several options are mandatory. --prefix1 : Remove prefix to all destination folders (usually INBOX. or INBOX/ or an empty string "") you have to use --prefix1 if host1 imap server - does not have NAMESPACE capability, all other - cases are bad. + does not have NAMESPACE capability, so imapsync + suggests to use it. All other cases are bad. --prefix2 : Add prefix to all host2 folders. See --prefix1 --sep1 : Host1 separator in case NAMESPACE is not supported. --sep2 : Host2 separator in case NAMESPACE is not supported. @@ -106,6 +111,10 @@ Several options are mandatory. --skipmess is applied before --regexmess --skipmess : or this one, etc. +--pipemess : Apply this command to each message content before + the copy. +--pipemess : and this one, etc. + --disarmreadreceipts : Disarms read receipts (host2 Exchange issue) --regexmess : Apply the whole regex to each message before transfer. @@ -213,6 +222,7 @@ Several options are mandatory. --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. +--debugmemory : Debug mode showing memory consumption after each copy. --tests : Run non-regression tests. --testslive : Run a live test with test1.lamiral.info imap server. @@ -238,20 +248,23 @@ imapsync \ --host1 test1.lamiral.info --user1 test1 --password1 secret1 \ --host2 test2.lamiral.info --user2 test2 --password2 secret2 -Here is a [linux] system (Linux petite 3.2.0-77-generic #114-Ubuntu SMP Tue Mar 10 17:25:28 UTC 2015 i686) +Here is a [linux] system (Linux petite 3.2.0-84-generic #121-Ubuntu SMP Tue May 5 18:55:46 UTC 2015 i686) With perl 5.14.2 Mail::IMAPClient 3.30 -$Id: imapsync,v 1.637 2015/04/01 01:36:37 gilles Exp gilles $ +$Id: imapsync,v 1.644 2015/07/17 01:22:52 gilles Exp gilles $ This current imapsync is up to date Homepage: http://imapsync.lamiral.info/ +[MSG] No '/home/gilles/.cpanplus/custom-sources' dir, skipping custom sources +[MSG] No '/home/gilles/.cpanplus/custom-sources' dir, skipping custom sources +[MSG] No '/home/gilles/.cpanplus/custom-sources' dir, skipping custom sources 'Tie::Hash::NamedCapture' => '0.08', 'Authen::NTLM::DES' => '1.02', 'Authen::NTLM::MD4' => '1.02', 'IO::Compress::Gzip' => '2.048', -'IO::Uncompress::Gunzip' => '2.048', 'IO::Compress::Gzip::Constants' => '2.048', 'IO::Compress::Base::Common' => '2.048', +'IO::Uncompress::Gunzip' => '2.048', 'Compress::Raw::Zlib' => '2.048', 'Convert::ASN1::IO' => 'undef', 'Convert::ASN1::_decode' => 'undef', @@ -260,6 +273,7 @@ Homepage: http://imapsync.lamiral.info/ 'Crypt::SSLeay::X509' => 'undef', 'Crypt::SSLeay::CTX' => 'undef', 'Digest::HMAC' => '1.03', +'Encode::HanExtra' => '0.23', 'Cwd' => '3.33', 'HTML::Parser' => '3.69', 'HTTP::Cookies::Netscape' => '6.00', @@ -270,7 +284,6 @@ Homepage: http://imapsync.lamiral.info/ 'IO::Uncompress::Inflate' => '2.048', 'IO::Uncompress::RawInflate' => '2.048', 'HTTP::Message' => '6.01', -'Compress::Raw::Bzip2' => '2.048', 'File::GlobMapper' => '1.000', 'IO::Compress::Base' => '2.048', 'IO::Compress::Adapter::Bzip2' => '2.048', @@ -280,6 +293,7 @@ Homepage: http://imapsync.lamiral.info/ 'Socket6' => '0.23', 'IO::Socket::INET6' => '2.69', 'Net::SSLeay' => '1.42', +'Compress::Raw::Bzip2' => '2.048', 'IO::Uncompress::Adapter::Bunzip2' => '2.048', 'IO::Uncompress::Base' => '2.048', 'IO::Compress::Zlib::Constants' => '2.048', @@ -287,10 +301,11 @@ Homepage: http://imapsync.lamiral.info/ 'common::sense' => '3.4', 'Authen::NTLM' => '1.09', 'CPAN::Config' => 'undef', -'URI::data' => 'undef', -'URI::_idna' => 'undef', +'URI' => '1.59', 'URI::mailto' => 'undef', +'URI::_userpass' => 'undef', 'URI::_query' => 'undef', +'URI::data' => 'undef', 'URI::QueryParam' => 'undef', 'URI::Split' => 'undef', 'URI::_foreign' => 'undef', @@ -318,6 +333,8 @@ Homepage: http://imapsync.lamiral.info/ 'URI::file::Win32' => 'undef', 'URI::file::Unix' => 'undef', 'URI::file::Base' => 'undef', +'URI::sip' => '0.11', +'URI::_login' => 'undef', 'URI::_punycode' => '0.04', 'URI::IRI' => 'undef', 'URI::_ldap' => '1.12', @@ -325,19 +342,19 @@ Homepage: http://imapsync.lamiral.info/ 'URI::news' => 'undef', 'URI::rtsp' => 'undef', 'URI::Heuristic' => '4.20', -'URI::_userpass' => 'undef', -'URI::sip' => '0.11', -'URI::_login' => 'undef', +'URI::_idna' => 'undef', 'URI::_generic' => 'undef', -'URI' => '1.59', -'URI::_server' => 'undef', -'File::Listing' => '6.03', -'HTTP::Status' => '6.00', 'LWP::MediaTypes' => '6.01', -'HTTP::Negotiate' => '6.00', +'HTTP::Date' => '6.00', +'HTTP::Request' => '6.00', +'File::Listing' => '6.03', 'Net::HTTP' => '6.02', +'HTTP::Status' => '6.00', +'LWP::Protocol' => '6.00', +'HTTP::Response' => '6.01', 'Net::HTTPS' => '6.02', 'LWP::Debug' => 'undef', +'HTTP::Negotiate' => '6.00', 'Net::LDAP' => '0.43', 'Net::LDAP::LDIF' => '0.18', 'Mail::Internet' => '2.08', @@ -345,16 +362,12 @@ Homepage: http://imapsync.lamiral.info/ 'HTTP::Config' => '6.00', 'HTTP::Request::Common' => '6.00', 'LWP::ConnCache' => '6.02', -'HTTP::Headers' => '6.00', 'HTTP::Cookies' => '6.00', +'HTTP::Headers' => '6.00', 'Encode::Locale' => '1.02', 'HTTP::Headers::Util' => '6.00', 'LWP::MemberMixin' => 'undef', 'LWP' => '6.03', -'HTTP::Date' => '6.00', -'HTTP::Request' => '6.00', -'LWP::Protocol' => '6.00', -'HTTP::Response' => '6.01', 'Compress::Zlib' => '2.048', 'Mail::IMAPClient::MessageSet' => 'undef', 'Digest::HMAC_MD5' => '1.01', @@ -389,20 +402,23 @@ Homepage: http://imapsync.lamiral.info/ 'Test::Builder::Module' => '0.98', 'URI::WithBase' => '2.20', 'URI::file' => '4.21', +'URI::_server' => 'undef', 'Unicode::CharName' => '1.07', 'Data::Uniqid' => '0.12', 'Digest::HMAC_SHA1' => '1.03', 'File::Copy::Recursive' => '0.38', 'IO::Tee' => '0.64', -'JSON::XS::Boolean' => 'undef', +'JSON' => '2.53', 'Term::ReadKey' => '2.30', 'Test::More' => '0.98', 'Unicode::String' => '2.09', 'File::Spec::Unix' => '3.33', 'File::Spec' => '3.33', +'JSON::XS::Boolean' => 'undef', 'JSON::XS' => '2.32', 'LWP::UserAgent' => '6.03', 'HTML::Entities' => '3.69', +'URI::Escape' => '3.31', 'LWP::Authen::Digest' => 'undef', 'LWP::Authen::Ntlm' => '6.00', 'LWP::Protocol::GHTTP' => 'undef', @@ -418,9 +434,8 @@ Homepage: http://imapsync.lamiral.info/ 'LWP::Protocol::nntp' => 'undef', 'LWP::Protocol::nogo' => 'undef', 'LWP::Authen::Basic' => 'undef', -'URI::http' => 'undef', 'URI::URL' => '5.04', +'URI::http' => 'undef', 'LWP::Protocol::http' => 'undef', 'LWP::Protocol::ldap' => '1.11', 'IO::Socket::SSL' => '1.53', -'URI::Escape' => '3.31', diff --git a/W/test3.bat b/W/test3.bat index 9027570..c7d4656 100644 --- a/W/test3.bat +++ b/W/test3.bat @@ -1,5 +1,5 @@ -@REM $Id: test3.bat,v 1.19 2015/03/15 03:02:58 gilles Exp gilles $ +@REM $Id: test3.bat,v 1.20 2015/05/11 01:08:57 gilles Exp gilles $ cd /D %~dp0 @REM \$1 must be $1 on Windows @@ -12,14 +12,20 @@ cd /D %~dp0 @REM perl .\imapsync --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi ^ @REM --nofoldersizes --regextrans2 "s,INBOX\\yop\\(.*),OLDBOX\\$1," --prefix1 "" --sep1 "." --sep2 "\\" --prefix2 "" --justfolders --dry --debug -.\imapsync.exe ^ - --host1 p --user1 tata ^ - --passfile1 secret.tata ^ - --host2 imap-mail.outlook.com --ssl2 --user2 gilles.lamiral@outlook.com ^ - --passfile2 secret.outlook.com ^ - --folder INBOX --usecache --regextrans2 "s/INBOX/tata/" +@REM .\imapsync.exe --host1 p --user1 tata --passfile1 secret.tata --host2 imap-mail.outlook.com --ssl2 --user2 gilles.lamiral@outlook.com ^ +@REM --passfile2 secret.outlook.com --folder INBOX --usecache --regextrans2 "s/INBOX/tata/" + +@REM Change all " to _ +@REM --justfolders --nofoldersizes --dry --regextrans2 s,\^",_,g +@REM perl .\imapsync --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi ^ +@REM --justfolders --nofoldersizes --dry --regextrans2 "s,(/|^) +,$1,g" --regextrans2 "s, +(/|$),$1,g" + +perl .\imapsync --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi ^ + --justfolders --subfolder2 SUB2 + + @EXIT diff --git a/W/test_cook_exe.bat b/W/test_cook_exe.bat old mode 100755 new mode 100644 index 351fd50..8d4e6fd --- a/W/test_cook_exe.bat +++ b/W/test_cook_exe.bat @@ -1,4 +1,4 @@ -REM $Id: test_exe.bat,v 1.11 2014/05/22 10:13:34 gilles Exp gilles $ +REM $Id: test_cook_exe.bat,v 1.1 2015/04/02 23:38:23 gilles Exp gilles $ cd /D %~dp0 diff --git a/W/test_cook_src.bat b/W/test_cook_src.bat old mode 100755 new mode 100644 index ed35a73..a493ac6 --- a/W/test_cook_src.bat +++ b/W/test_cook_src.bat @@ -1,4 +1,4 @@ -REM $Id: test_exe.bat,v 1.11 2014/05/22 10:13:34 gilles Exp gilles $ +REM $Id: test_cook_src.bat,v 1.1 2015/04/02 23:38:16 gilles Exp gilles $ cd /D %~dp0 diff --git a/W/test_exe_2.bat b/W/test_exe_2.bat index 2cd0e85..5554415 100644 --- a/W/test_exe_2.bat +++ b/W/test_exe_2.bat @@ -1,6 +1,6 @@ @REM -@REM $Id: test_exe_2.bat,v 1.6 2015/03/20 03:11:22 gilles Exp gilles $ +@REM $Id: test_exe_2.bat,v 1.8 2015/06/27 20:00:55 gilles Exp gilles $ @REM cd C:\msys\1.0\home\Admin\imapsync cd /D %~dp0 @@ -15,4 +15,9 @@ cd /D %~dp0 @REM --dry --nofoldersizes --regextrans2 "s,(.*),\L$1," --justfolders @REM .\imapsync.exe --testslive -perl .\imapsync --tests +@REM perl .\imapsync --tests + +@REM .\imapsync.exe --testslive --authmech2 XOAUTH2 +@REM .\imapsync.exe --host1 p --user1 tata --passfile1 secret.tata --host2 imap.gmail.com --ssl2 --user2 gilles.lamiral@gmail.com --passfile2 secret.gilles_gmail --authmech2 XOAUTH2 + +.\imapsync.exe --host1 mail2.name-services.com --user1 jessica@champlaindoor.com --passfile1 secret.mail2World --host2 mail.emailsrvr.com --user2 jessica@champlaindoor.com --passfile2 secret.mail2World --sep1 / --prefix1 "" --noabletosearch --fetch_hash_set "1:*" --delete2duplicates diff --git a/W/test_reg.bat b/W/test_reg.bat new file mode 100644 index 0000000..c0e0754 --- /dev/null +++ b/W/test_reg.bat @@ -0,0 +1,14 @@ + +REM $Id: test_reg.bat,v 1.3 2015/05/11 01:08:05 gilles Exp gilles $ + +cd /D %~dp0 + +perl ./imapsync --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi ^ + --justfolders --dry --nofoldersizes ^ + --regextrans2 "s/\./_/g" + +@REM --regextrans2 "s,${h2_prefix}(.*),${h2_prefix}old_mail${h2_sep}$1," ^ +@REM --regextrans2 "s,^INBOX$,${h2_prefix}old_mail${h2_sep}INBOX," + + +@REM --regextrans2 "s,(.*),old_mail/$1," diff --git a/W/test_tests.bat b/W/test_tests.bat old mode 100755 new mode 100644 index 4613a11..848ac9f --- a/W/test_tests.bat +++ b/W/test_tests.bat @@ -1,10 +1,11 @@ @REM -@REM $Id: test_exe_2.bat,v 1.6 2015/03/20 03:11:22 gilles Exp gilles $ +@REM $Id: test_tests.bat,v 1.2 2015/06/27 20:01:16 gilles Exp gilles $ @REM cd C:\msys\1.0\home\Admin\imapsync cd /D %~dp0 +perl .\imapsync --modules_version perl .\imapsync --tests -@REM @PAUSE \ No newline at end of file +@REM @PAUSE diff --git a/imapsync b/imapsync index bac4c89..36f364e 100755 --- a/imapsync +++ b/imapsync @@ -22,7 +22,7 @@ Synchronises mailboxes between two imap servers. Good at IMAP migration. More than 52 different IMAP server softwares supported with success, few failures. -$Revision: 1.637 $ +$Revision: 1.644 $ =head1 SYNOPSIS @@ -375,123 +375,7 @@ and then forget it. =head1 IMAP SERVERS -Failure stories reported in the past with the following 6 imap servers. -Maybe last imapsync release can run successfully with them. -Don't hesitate to have a try, It's been a long time since last failure occured, -I will help you and make efforts to switch them to the success list, -that's my job. - - - 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). - - (2011) MDaemon 12.0.3 as host2 but MDaemon is supported as host1. - MDaemon is simply buggy with the APPEND IMAP command with - any IMAP email client. - - Hotmail since hotmail.com does not provide IMAP access - - Outlook.com since outlook.com does not provide IMAP access - -Success stories reported with the following 62 imap servers -(software names are in alphabetic order): - - - 1und1 H mimap1 84498 [host1] H mibap4 95231 [host1] - - a1.net imap.a1.net IMAP4 Ready [host1] - - Apple Server 10.6 Snow Leopard [host1] - - Archiveopteryx 2.03, 2.04, 2.09, 2.10 [host2], 3.0.0 [host2] - (OSL 3.0) http://www.archiveopteryx.org/ - - Atmail 6.x [host1] - - Axigen Mail Server Version 8.0.0 - - 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.3, 2.2.6, 2.2.10, 2.2.12, 2.2.13, - 2.3-alpha (OSI Approved), 2.3.1, 2.3.7, 2.3.16 - (http://asg.web.cmu.edu/cyrus/) - - David Tobit V8 (proprietary Message system). - - Deerfield VisNetic MailServer 5.8.6 [host1] (http://www.deerfield.net/products/visnetic-mailserver/) - - DBMail 1.2.1, 2.0.4, 2.0.9, 2.2rc1 (GPL) (http://www.dbmail.org/). - 2.0.7 seems buggy. - - DBOX 2.41 System [host1] (http://www.dbox.handshake.de/). - - 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], 8.5.3 [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 - - FirtClass 9 [host1] Read the FAQ! (http://www.firstclass.com/) - - FTGate (http://www.ftgate.com/) - - Fusemail imap.fusemail.net:143 (https://www.fusemail.com/). - - Gimap (Gmail imap) - - GMX IMAP4 StreamProxy. - - Groupwise IMAP (Novell) 6.x and 7.0. Buggy so see the FAQ. - - hMailServer 5.40-B1950 [host12], 5.3.3 [host2], 4.4.1 [host1] (see FAQ) - - IceWarp Server 10.4.5 [host1] (http://www.icewarp.com/) - - iPlanet Messaging server 4.15, 5.1, 5.2 - - IMail 7.15 (Ipswitch/Win2003), 8.12, 11.03 [host1] - - Kerio 7.2.0 Patch 1 [host12], Kerio 8 [host1] - - Mail2World IMAP4 Server 2.5 [host1] (http://www.mail2world.com/) - - MailEnable 4.23 [host1] [host2], 4.26 [host1][host2], 5 [host1] - - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform), - 9.6.5 [host1], 12 [host2], 12.0.3 [host1], 12.5.5 [host1], - 13.5 [host2], 14.5 [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, 4.1.9-GA [host1] - - Netscape Mail Server 3.6 (Wintel !) - - Netscape Messaging Server 4.15 Patch 7 - - Office 365 [host1] [host2] - - OpenMail IMAP server B.07.00.k0 (Samsung Contact ?) - - OpenWave - - Oracle Beehive [host1] - - Parallels Plesk Panel 9.x [host2] 11.x [host2] (http://www.parallels.com/) - - Qualcomm Worldmail (NT) - - QQMail IMAP4Server [host1] [host2] https://en.mail.qq.com/ - - RackSpace hoster secure.emailsrvr.com:993 http://www.rackspace.com/ - - 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, 11.4.6 - - Sendmail Mail Store IMAP4rev1 (5.5.6/mstore-5-5-build-1874 [host1]. - - SmarterMail, Smarter Mail 5.0 Enterprise, Smarter Mail 5.5 [host1], - SmarterMail Professional 10.2 [host1], Smarter Mail 11.7 [host1][host2]. - - Softalk Workgroup Mail 7.6.4 [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, 6.3d-72 [host2] - - 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 - - Yahoo [host1] - - Zarafa 6,40,0,20653 [host1] (http://www.zarafa.com/) - - Zarafa ZCP 7.1.4 IMAP Gateway [host2] - - 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 - +See http://imapsync.lamiral.info/S/imapservers.shtml =head1 HUGE MIGRATION @@ -572,7 +456,7 @@ https://web.archive.org/web/20070202005121/http://www.imap.org/products/showall. Feedback (good or bad) will often be welcome. -$Id: imapsync,v 1.637 2015/04/01 01:36:37 gilles Exp gilles $ +$Id: imapsync,v 1.644 2015/07/17 01:22:52 gilles Exp gilles $ =cut @@ -624,6 +508,7 @@ my( @folder, @include, @exclude, @folderrec, @folderfirst, @folderlast, $prefix1, $prefix2, + $subfolder2, @regextrans2, @regexmess, @regexflag, @skipmess, @pipemess, $pipemesscheck, $flagsCase, $filterflags, $syncflagsaftercopy, $sep1, $sep2, @@ -709,13 +594,14 @@ my( $log, $logfile, $disarmreadreceipts, $mixfolders, $skipemptyfolders, + $fetch_hash_set, ); # main program # global variables initialisation -$rcs = '$Id: imapsync,v 1.637 2015/04/01 01:36:37 gilles Exp gilles $ '; +$rcs = '$Id: imapsync,v 1.644 2015/07/17 01:22:52 gilles Exp gilles $ '; $total_bytes_transferred = 0; $total_bytes_skipped = 0; @@ -791,8 +677,8 @@ $modules_version = defined( $modules_version ) ? $modules_version : 1 ; # The second line (ending with "1 ;") can stay active or be commented, # the result will be the same: no releasecheck by default. -$releasecheck = defined( $releasecheck ) ? $releasecheck : 0 ; -#$releasecheck = defined( $releasecheck ) ? $releasecheck : 1 ; +#$releasecheck = defined( $releasecheck ) ? $releasecheck : 0 ; +$releasecheck = defined( $releasecheck ) ? $releasecheck : 1 ; my $warn_release = ( $releasecheck ) ? check_last_release( ) : '' ; @@ -994,8 +880,12 @@ print "Info: imap connexions timeout is $timeout seconds\n"; $syncacls = (defined($syncacls)) ? $syncacls : 0 ; -$foldersizes = (defined($foldersizes)) ? $foldersizes : 1 ; -$foldersizesatend = (defined($foldersizesatend)) ? $foldersizesatend : $foldersizes ; + +# No folders sizes if --justfolders, unless really wanted. +if ( $justfolders and not defined( $foldersizes ) ) { $foldersizes = 0 ; } + +$foldersizes = ( defined( $foldersizes ) ) ? $foldersizes : 1 ; +$foldersizesatend = ( defined( $foldersizesatend ) ) ? $foldersizesatend : $foldersizes ; @@ -1054,6 +944,8 @@ $dry_message = "\t(not really since --dry mode)" if $dry ; $search1 ||= $search if ( $search ) ; $search2 ||= $search if ( $search ) ; + + if ( $disarmreadreceipts ) { push( @regexmess, 's{\A((?:[^\n]+\r\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims' ) ; } @@ -1175,6 +1067,14 @@ for ( @h2_folders_all ) { $h2_folders_all_UPPER{ uc( $_ ) } = 1 ; } ; + +if ( defined( $subfolder2 ) ) { + unshift( @regextrans2, + 's,^${h2_prefix}(.*),${h2_prefix}${subfolder2}${h2_sep}$1,', + 's,^INBOX$,${h2_prefix}${subfolder2}${h2_sep}INBOX,' + ) ; +} + if ( $fixInboxINBOX and ( my $reg = fix_Inbox_INBOX_mapping( \%h1_folders_all, \%h2_folders_all ) ) ) { #print "RRRRRR $reg\n" ; push( @regextrans2, $reg ) ; @@ -1510,7 +1410,8 @@ FOLDER: foreach my $h1_fold ( @h1_folders_wanted ) { if ( @h1_msgs ) ; }else{ my $uidnext = $imap1->uidnext( $h1_fold ) || $uidnext_default ; - $h1_fir_ref = $imap1->fetch_hash( "1:$uidnext", "FLAGS", "INTERNALDATE", "RFC822.SIZE", $h1_fir_ref ) + my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; + $h1_fir_ref = $imap1->fetch_hash( $fetch_hash_uids, "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"; @@ -1564,7 +1465,8 @@ FOLDER: foreach my $h1_fold ( @h1_folders_wanted ) { if (@h2_msgs) ; }else{ my $uidnext = $imap2->uidnext( $h2_fold ) || $uidnext_default ; - $h2_fir_ref = $imap2->fetch_hash( "1:$uidnext", "FLAGS", "INTERNALDATE", "RFC822.SIZE", $h2_fir_ref ) + my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; + $h2_fir_ref = $imap2->fetch_hash( $fetch_hash_uids, "FLAGS", "INTERNALDATE", "RFC822.SIZE", $h2_fir_ref ) if ( @h2_msgs ) ; } @@ -1622,7 +1524,7 @@ FOLDER: foreach my $h1_fold ( @h1_folders_wanted ) { } } my $cnt = scalar @h2_expunge ; - if( @h2_expunge ) { + if( @h2_expunge and not $expunge2 ) { print "uidexpunge $cnt message(s) $dry_message\n" ; $imap2->uidexpunge( \@h2_expunge ) if ! $dry ; } @@ -2146,6 +2048,9 @@ sub modules_VERSION { eval { require Data::Uniqid; $v = $Data::Uniqid::VERSION } or $v = "?" ; push ( @list_version, module_version_str( 'Data::Uniqid', $v ) ) ; + eval { require JSON::WebToken; $v = $JSON::WebToken::VERSION } or $v = "?" ; + push ( @list_version, module_version_str( 'JSON::WebToken', $v ) ) ; + return( @list_version ) ; } @@ -2505,8 +2410,8 @@ sub plainauth { sub xoauth2 { require JSON::WebToken; require LWP::UserAgent; - require HTML::Entities; - require JSON; + require HTML::Entities; + require JSON; my $code = shift; my $imap = shift; @@ -2641,8 +2546,8 @@ sub banner_imapsync { my @argv = @_ ; my $banner_imapsync = join("", '$RCSfile: imapsync,v $ ', - '$Revision: 1.637 $ ', - '$Date: 2015/04/01 01:36:37 $ ', + '$Revision: 1.644 $ ', + '$Date: 2015/07/17 01:22:52 $ ', "\n",localhost_info(), "\n", "Command line used:\n", "$0 ", command_line_nopassword( @argv ), "\n", @@ -2937,9 +2842,11 @@ sub create_folder { }else{ # dry mode, no folder so many imap will fail, assuming failure print "Created folder [$h2_fold] on host2 $dry_message\n" ; - print "Since --dry mode is on and folder [$h2_fold] on host2 does not exist yet, syncing messges will not be simulated.\n" - . "To simulate message syncing, use --justfolders without --dry to first create the missing folders then rerun the --dry sync.\n" ; - return( 0 ) ; + if ( ! $justfolders ) { + print "Since --dry mode is on and folder [$h2_fold] on host2 does not exist yet, syncing messages will not be simulated.\n" + . "To simulate message syncing, use --justfolders without --dry to first create the missing folders then rerun the --dry sync.\n" ; + } + return( 0 ) ; } } @@ -3354,7 +3261,7 @@ sub imap2_folder_name { foreach my $regextrans2 (@regextrans2) { my $h2_fold_before = $h2_fold; my $ret = eval( "\$h2_fold =~ $regextrans2 ; 1 ") ; - $debug and print "[$h2_fold_before] -> [$h2_fold] using re [$regextrans2]\n" ; + $debug and print "[$h2_fold_before] -> [$h2_fold] using regextrans2 [$regextrans2]\n" ; if ( not ( defined( $ret ) ) or $@ ) { die_clean("error: eval regextrans2 '$regextrans2': $@\n") ; } @@ -3425,7 +3332,8 @@ sub foldersizes { $imap->fetch_hash( \@msgs, "RFC822.SIZE", $hash_ref) or die_clean("$@" ) ; }else{ my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ; - $imap->fetch_hash( "1:$uidnext", "RFC822.SIZE", $hash_ref ) or die_clean( "$@" ) ; + my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; + $imap->fetch_hash( $fetch_hash_uids, "RFC822.SIZE", $hash_ref ) or die_clean( "$@" ) ; } for ( keys %$hash_ref ) { my $size = $hash_ref->{ $_ }->{ "RFC822.SIZE" } ; @@ -3781,7 +3689,9 @@ sub select_msgs_by_fetch { $debugdev and print "Calling fetch_hash()\n" ; my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ; - %fetch = %{$imap->fetch_hash( "1:$uidnext", "INTERNALDATE") } ; + my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; + %fetch = %{$imap->fetch_hash( $fetch_hash_uids, "INTERNALDATE") } ; + @msgs_all = sort { $a <=> $b } keys( %fetch ) ; $debugdev and print "Done fetch_hash()\n" ; @@ -4289,7 +4199,9 @@ sub append_message_on_host2 { } } else{ - $nb_msg_skipped_dry_mode += 1; + # NOOP to avoid timeout on large folders. + $imap2->noop( ) ; + $nb_msg_skipped_dry_mode += 1 ; $h1_nb_msg_processed +=1 ; } @@ -6176,7 +6088,7 @@ sub check_last_release { } sub imapsync_version { - my $rcs_imapsync = '$Id: imapsync,v 1.637 2015/04/01 01:36:37 gilles Exp gilles $ ' ; + my $rcs_imapsync = '$Id: imapsync,v 1.644 2015/07/17 01:22:52 gilles Exp gilles $ ' ; my $imapsync_version ; if ( $rcs_imapsync =~ m{,v\s+(\d+\.\d+)}xo ) { @@ -6435,6 +6347,8 @@ sub tests_memory_consumption { return( ) ; } + + sub good_date { # two incoming formats: # header Tue, 24 Aug 2010 16:00:00 +0200 @@ -7064,12 +6978,17 @@ Several options are mandatory. --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3. --exclude : or this one, etc. +--subfolder2 : Move whole host1 folders hierarchy under this + host2 folder . + It does it by adding two --regextrans2 options before + all others. Add --debug to see what's really going on. + --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. - Have in mind that --regextrans2 is applied after prefix + Have in mind that --regextrans2 is applied after prefix and separator inversion. --tmpdir : Where to store temporary files and subdirectories. @@ -7087,8 +7006,8 @@ Several options are mandatory. --prefix1 : Remove prefix to all destination folders (usually INBOX. or INBOX/ or an empty string "") you have to use --prefix1 if host1 imap server - does not have NAMESPACE capability, all other - cases are bad. + does not have NAMESPACE capability, so imapsync + suggests to use it. All other cases are bad. --prefix2 : Add prefix to all host2 folders. See --prefix1 --sep1 : Host1 separator in case NAMESPACE is not supported. --sep2 : Host2 separator in case NAMESPACE is not supported. @@ -7098,6 +7017,10 @@ Several options are mandatory. --skipmess is applied before --regexmess --skipmess : or this one, etc. +--pipemess : Apply this command to each message content before + the copy. +--pipemess : and this one, etc. + --disarmreadreceipts : Disarms read receipts (host2 Exchange issue) --regexmess : Apply the whole regex to each message before transfer. @@ -7205,6 +7128,7 @@ Several options are mandatory. --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. +--debugmemory : Debug mode showing memory consumption after each copy. --tests : Run non-regression tests. --testslive : Run a live test with test1.lamiral.info imap server. @@ -7258,6 +7182,7 @@ sub usage_complete { is the number of messages handled per request. default is like --split1 500. --split2 : same thing on host2. +--nofixInboxINBOX : Don't fix Inbox INBOX mapping. EOF return( ) ; } @@ -7285,8 +7210,7 @@ sub get_options { "debugimap1!" => \$debugimap1, "debugimap2!" => \$debugimap2, "debugdev!" => \$debugdev, - "debugmemory!" => \$debugmemory, - "debugmaxlinelength!" => \$debugmaxlinelength, + "debugmemory!" => \$debugmemory, "host1=s" => \$host1, "host2=s" => \$host2, "port1=i" => \$port1, @@ -7312,7 +7236,8 @@ sub get_options { "folderlast=s" => \@folderlast, "prefix1=s" => \$prefix1, "prefix2=s" => \$prefix2, - "fixslash2!" => \$fixslash2, + "subfolder2=s" => \$subfolder2, + "fixslash2!" => \$fixslash2, "fixInboxINBOX!" => \$fixInboxINBOX, "regextrans2=s" => \@regextrans2, "mixfolders!" => \$mixfolders, @@ -7413,6 +7338,7 @@ sub get_options { "maxlinelength=i" => \$maxlinelength, "maxlinelengthcmd=s" => \$maxlinelengthcmd, "minmaxlinelength=i" => \$minmaxlinelength, + "debugmaxlinelength!" => \$debugmaxlinelength, "fixcolonbug!" => \$fixcolonbug, "create_folder_old!" => \$create_folder_old, "maxmessagespersecond=f" => \$maxmessagespersecond, @@ -7423,6 +7349,7 @@ sub get_options { "logfile=s" => \$logfile, "errorsmax=i" => \$errorsmax, "errorsdump!" => \$errorsdump, + "fetch_hash_set=s" => \$fetch_hash_set, ) ; $debug and print "get options: [$opt_ret]\n" ; @@ -7434,13 +7361,11 @@ sub get_options { if ( $tests ) { $test_builder->no_ending( 0 ) ; my $ok = tests( ) ; - #print "tests returned $ok\n" ; exit ; } if ( $testsdebug ) { $test_builder->no_ending( 0 ) ; my $ok = testsdebug( ) ; - #print "testsdebug returned $ok\n" ; exit ; } diff --git a/index.shtml b/index.shtml index 3148d28..d312cbb 100644 --- a/index.shtml +++ b/index.shtml @@ -17,8 +17,6 @@ - - @@ -38,7 +36,7 @@
  • Discuss or search on the mailing-list
  • Documentation
  • News about imapsync and previous releases
    • -
  • List of the 62 imap server softwares supported by imapsync
    • +
  • List of the 63 imap server softwares supported by imapsync
  • Similar softwares and external services
    • @@ -448,7 +446,7 @@ alt="Viewable With Any Browser" /> This document last modified on -($Id: index.shtml,v 1.251 2015/03/29 17:22:13 gilles Exp gilles $)
    +($Id: index.shtml,v 1.252 2015/05/09 18:11:18 gilles Exp gilles $)
    Top of the page

    diff --git a/tests.sh b/tests.sh index 2bc12c3..57e9bc9 100644 --- a/tests.sh +++ b/tests.sh @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: tests.sh,v 1.255 2015/03/31 14:52:51 gilles Exp gilles $ +# $Id: tests.sh,v 1.258 2015/06/27 20:00:36 gilles Exp gilles $ # Example 1: # CMD_PERL='perl -I./W/Mail-IMAPClient-3.35/lib' sh -x tests.sh @@ -355,7 +355,17 @@ ll_star() { --folder 'INBOX.backstar\*' --dry --justfolders --debugimap1 --regextrans2 's#\\|\*#_#g' } -ll_doublequote() { +lks_trailing_space() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 ks.lamiral.info --user2 tata \ + --passfile2 ../../var/pass/secret.tata \ + --justfolders --ssl1 --ssl2 +} + + +lks_doublequote() { $CMD_PERL ./imapsync \ --host1 $HOST1 --user1 tata \ --passfile1 ../../var/pass/secret.tata \ @@ -364,7 +374,7 @@ ll_doublequote() { --folder 'INBOX."uni"' --debugimap2 --nofoldersizes --justfolders --ssl1 --ssl2 } -ll_doublequote_rev() { +lks_doublequote_rev() { $CMD_PERL ./imapsync \ --host1 ks.lamiral.info --user1 tata \ --passfile1 ../../var/pass/secret.tata \ @@ -808,6 +818,20 @@ ll_idatefromheader() { --idatefromheader --debug --dry } +ll_idatefromheader_barker() { + + # can_send && sendtestmessage + + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 imap.europe.secureserver.net --user2 test@alicebarkertest.com \ + --passfile2 ../../var/pass/secret.barker \ + --folder INBOX.oneemail2 --nofoldersizes \ + --debug --useheader ALL +} + + ll_folder_rev() { @@ -1589,6 +1613,20 @@ ll_regextrans2_slash() } + +ll_regextrans2_dot() +{ + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --justfolders \ + --folder 'INBOX.yop.yap' \ + --regextrans2 "s,\.,_,g" --dry +} + + ll_regextrans2_subfolder() { $CMD_PERL ./imapsync \ @@ -1600,9 +1638,51 @@ ll_regextrans2_subfolder() --nofoldersizes \ --folder 'INBOX.yop.yap' \ --prefix1 'INBOX.yop.' \ - --regextrans2 's,^${h2_prefix}(.*),${h2_prefix}FOO${h2_sep}$1,' --dry + --regextrans2 's,^${h2_prefix}(.*),${h2_prefix}FOO${h2_sep}$1,' \ + --regextrans2 's,^INBOX$,${h2_prefix}FOO${h2_sep}INBOX,' --dry } +ll_regextrans2_subfolder_02() +{ + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --justfolders \ + --nofoldersizes \ + --regextrans2 's,^${h2_prefix}(.*),${h2_prefix}FOO${h2_sep}$1,' \ + --regextrans2 's,^INBOX$,${h2_prefix}FOO${h2_sep}INBOX,' --dry +} + + + +ll_subfolder2() +{ + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --justfolders \ + --subfolder2 SUB +} + + + +ll_nochildren() +{ + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 w00d0310.kasserver.com --user2 m0331832 \ + --passfile2 ../../var/pass/secret.kasserver \ + --justfolders \ + --debugimap +} + + + ll_regextrans2_remove_space() @@ -2593,6 +2673,18 @@ msw2() { ssh Admin@c 'C:/msys/1.0/home/Admin/imapsync/test_exe.bat' } +ll_change_characters_doublequotes() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --justfolders --dry --nofoldersizes \ + --regextrans2 's,\",_,g' + +} + + ll_change_characters_gmail() { $CMD_PERL ./imapsync \ @@ -3419,6 +3511,16 @@ l_office365_justlogin() --justlogin } +l_office365_justlogin_2() +{ + $CMD_PERL ./imapsync \ + --host1 imap-mail.outlook.com --port1 993 --ssl1 --user1 gilles.lamiral@outlook.com \ + --passfile1 ../../var/pass/secret.outlook.com \ + --host2 outlook.office365.com --tls2 --user2 gilles.lamiral@outlook.com \ + --passfile2 ../../var/pass/secret.outlook.com \ + --justlogin +} + l_office365_bigfolders() @@ -3472,6 +3574,15 @@ l_exchange_maxline() # specific tests ########################## +mail2World() { + $CMD_PERL ./imapsync \ + --host1 mail2.name-services.com --user1 jessica@champlaindoor.com \ + --passfile1 ../../var/pass/secret.mail2World \ + --host2 mail.emailsrvr.com --user2 jessica@champlaindoor.com \ + --passfile2 ../../var/pass/secret.mail2World \ + --sep1 / --prefix1 "" \ + --noabletosearch --fetch_hash_set "1:*" --delete2 --expunge2 --expunge1 --useuid +} xgenplus() { $CMD_PERL ./imapsync \