From eca42f5d239be91da0b51554906e8ec895e1ab5f Mon Sep 17 00:00:00 2001 From: Peter Date: Mon, 9 Aug 2021 18:38:16 +0200 Subject: [PATCH] [Dovecot] Update imapsync to 2.148 (#4206) --- data/Dockerfiles/dovecot/imapsync | 4964 +++++++++++++++++++++-------- 1 file changed, 3703 insertions(+), 1261 deletions(-) diff --git a/data/Dockerfiles/dovecot/imapsync b/data/Dockerfiles/dovecot/imapsync index 4c941f44..07cf58e7 100755 --- a/data/Dockerfiles/dovecot/imapsync +++ b/data/Dockerfiles/dovecot/imapsync @@ -1,6 +1,6 @@ #!/usr/bin/env perl -# $Id: imapsync,v 1.977 2019/12/23 20:18:02 gilles Exp gilles $ +# $Id: imapsync,v 2.148 2021/07/22 14:21:09 gilles Exp gilles $ # structure # pod documentation # use pragmas @@ -25,7 +25,7 @@ and without duplicates. =head1 VERSION -This documentation refers to Imapsync $Revision: 1.977 $ +This documentation refers to Imapsync $Revision: 2.148 $ =head1 USAGE @@ -47,54 +47,82 @@ one another. Imapsync command is a tool allowing incremental and recursive imap transfers from one mailbox to another. If you don't understand the previous sentence, it's normal, -it's pedantic computer oriented jargon. +it's pedantic computer-oriented jargon. All folders are transferred, recursively, meaning the whole folder hierarchy is taken, all messages in them, -and all messages flags (\Seen \Answered \Flagged etc.) +and all message flags (\Seen \Answered \Flagged etc.) are synced too. Imapsync reduces the amount of data transferred by not transferring a given message if it already resides on the destination side. Messages that are on the destination side but not on the -source side stay as they are (see the --delete2 -option to have a strict sync). +source side stay as they are. See the --delete2 +option to have strict sync and delete them. -How imapsync knows a message is already on both sides? +How imapsync know a message is already on both sides? Same specific headers and the transfer is done only once. By default, the identification headers are "Message-Id:" and "Received:" lines -but this choice can be changed with the --useheader option. +but this choice can be changed with the --useheader option, +most often a duplicate problem is solved by using +--useheader "Message-Id" + All flags are preserved, unread messages will stay unread, read ones will stay read, deleted will stay deleted. +In the IMAP protocol, a deleted message is not really deleted, +it is marked \Deleted and can be undelete. Real destruction +comes with the EXPUNGE or UIDEXPUNGE IMAP commands. You can abort the transfer at any time and restart it later, imapsync works well with bad connections and interruptions, by design. On a terminal hit Ctr-c twice within two seconds -in order to abort the program. Hit Ctr-c just once makes +to abort the program. Hit Ctr-c just once makes imapsync reconnect to both imap servers. +How do you know the sync is finished and well done? +When imapsync ends by itself it mentions it with lines like those: + + Exiting with return value 0 (EX_OK: successful termination) 0/50 nb_errors/max_errors PID 301 + Removing pidfile /tmp/imapsync.pid + Log file is LOG_imapsync/2020_11_17_15_59_22_761_test1_test2.txt ( to change it, use --logfile filepath ; or use --nolog to turn off logging ) + +If you don't have those lines it means that either the sync process is still +running (or eventually hanging indefinitely) or that it ended without +a whisper, a strong kill -9 on Linux for example. + +If you have those final lines then it means the sync process is properly +finished. It may have encountered problems though. + +A good synchronization is mentioned by some lines above the last ones, especially +those three lines: + + The sync looks good, all 1745 identified messages in host1 are on host2. + There is no unidentified message on host1. + Detected 0 errors + + A classical scenario is synchronizing a mailbox B from another mailbox A where you just want to keep a strict copy of A in B. Strict meaning all messages in A will be in B but no more. -For this, option --delete2 has to be used, it deletes messages in host2 -folder B that are not in host1 folder A. If you also need to destroy +For this, option --delete2 can be used, it deletes messages in the host2 +folder B that are not in the host1 folder A. If you also need to destroy host2 folders that are not in host1 then use --delete2folders. See also --delete2foldersonly and --delete2foldersbutnot to set up exceptions -on folders to destroy. INBOX will never be destroy, it's a mandatory -folder in IMAP. +on folders to destroy. INBOX will never be destroyed, it's a mandatory +folder in IMAP so imapsync doesn't even try to remove it. A different scenario is to delete the messages from the source mailbox after a successful transfer, it can be a good feature when migrating mailboxes since messages will be only on one side. The source account will only have messages that are not on the destination yet, ie, -messages that arrived after a sync or that failed to be copied. +messages that arrived after a sync or that failed to be transferred. In that case, use the --delete1 option. Option --delete1 implies also -option --expunge1 so all messages marked deleted on host1 will be really -deleted. In IMAP protocol deleting a message does not really delete it, +the option --expunge1 so all messages marked deleted on host1 will be +deleted. In IMAP protocol deleting a message does not delete it, it marks it with the flag \Deleted, allowing an undelete. Expunging a folder removes, definitively, all the messages marked as \Deleted in this folder. @@ -115,17 +143,18 @@ Michael R. Elkins) for a 2 ways synchronization. usage: imapsync [options] The standard options are the six values forming the credentials. -Three values on each side are needed in order to log in into the IMAP -servers. These six values are a host, a username, and a password, two times. +Three values on each side are needed in order to login into the IMAP +servers. These six values are a hostname, a username, and a password, two times. Conventions used in the following descriptions of the options: str means string - int means integer + int means integer number + flo means float number reg means regular expression cmd means command - --dry : Makes imapsync doing nothing for real, just print what + --dry : Makes imapsync doing nothing for real; it just print what would be done without --dry. =head2 OPTIONS/credentials @@ -136,18 +165,18 @@ Conventions used in the following descriptions of the options: Optional since default ports are the well known ports imap/143 or imaps/993. --user1 str : User to login on host1. - --password1 str : Password for the user1. + --password1 str : Password of user1. --host2 str : "destination" imap server. --port2 int : Port to connect on host2. Optional --user2 str : User to login on host2. - --password2 str : Password for the user2. + --password2 str : Password of user2. --showpasswords : Shows passwords on output instead of "MASKED". Useful to restart a complete run by just reading the command line used in the log, or to debug passwords. - It's not a secure practice at all. + It's not a secure practice at all! --passfile1 str : Password file for the user1. It must contain the password on the first line. This option avoids showing @@ -155,7 +184,10 @@ Conventions used in the following descriptions of the options: --passfile2 str : Password file for the user2. You can also pass the passwords in the environment variables -IMAPSYNC_PASSWORD1 and IMAPSYNC_PASSWORD2 +IMAPSYNC_PASSWORD1 and IMAPSYNC_PASSWORD2. If you don't pass +the user1 password via --password1 nor --passfile1 nor $IMAPSYNC_PASSWORD1 +then imapsync will prompt to enter the password on the terminal. +Same thing for user2 password. =head2 OPTIONS/encryption @@ -180,11 +212,16 @@ IMAPSYNC_PASSWORD1 and IMAPSYNC_PASSWORD2 --sslargs2 str : Pass any ssl parameter for host2 ssl or tls connection. See --sslargs1 - --timeout1 int : Connection timeout in seconds for host1. + --timeout1 flo : Connection timeout in seconds for host1. Default is 120 and 0 means no timeout at all. - --timeout2 int : Connection timeout in seconds for host2. + --timeout2 flo : Connection timeout in seconds for host2. Default is 120 and 0 means no timeout at all. + Caveat, under CGI context, you may encounter a timeout + from the webserver, killing imapsync and the imap connexions. + See the document INSTALL.OnlineUI.txt and search + for "Timeout" for how to deal with this issue. + =head2 OPTIONS/authentication @@ -205,6 +242,28 @@ IMAPSYNC_PASSWORD1 and IMAPSYNC_PASSWORD2 --domain1 str : Domain on host1 (NTLM authentication). --domain2 str : Domain on host2 (NTLM authentication). + --oauthaccesstoken1 str : The access token to authenticate with OAUTH2. + It will be combined with the --user1 value to form the + string to pass with XOAUTH2 authentication. + The password given by --password1 or --passfile1 + is ignored. + Instead of the access token itself, the value can be a + file containing the access token on the first line. + If the value is a file, imapsync reads its first line + and take this line as the access token. The advantage + of the file is that if the access token changes then + imapsync can read it again when it needs to reconnect + during a run. + + + --oauthaccesstoken2 str : same thing as --oauthaccesstoken1 + + --oauthdirect1 str : The direct string to pass with XOAUTH2 authentication. + The password given by --password1 or --passfile1 and + the user given by --user1 are ignored. + + --oauthdirect2 str : same thing as oauthdirect1 + =head2 OPTIONS/folders @@ -241,6 +300,9 @@ IMAPSYNC_PASSWORD1 and IMAPSYNC_PASSWORD2 --f1f2 str1=str2 : Force folder str1 to be synced to str2, --f1f2 overrides --automap and --regextrans2. + Use several --f1f2 options to map several folders. + Option --f1f2 is a one to one only folder mapping, + str1 and str2 have to be full path folder names. --subfolder2 str : Syncs the whole host1 folders hierarchy under the host2 folder named str. @@ -285,7 +347,7 @@ IMAPSYNC_PASSWORD1 and IMAPSYNC_PASSWORD2 --regextrans2 reg : and this one. etc. When you play with the --regextrans2 option, first add also the safe options --dry --justfolders - Then, when happy, remove --dry for a run, then + Then, when happy, remove --dry for a run, then remove --justfolders for the next ones. Have in mind that --regextrans2 is applied after the automatic prefix and separator inversion. @@ -309,9 +371,11 @@ IMAPSYNC_PASSWORD1 and IMAPSYNC_PASSWORD2 Default is system specific, Unix is /tmp but /tmp is often too small and deleted at reboot. --tmpdir /var/tmp should be better. + --pidfile str : The file where imapsync pid is written, - it can be dirname/filename. - Default name is imapsync.pid in tmpdir. + it can be dirname/filename complete path. + The default name is imapsync.pid in tmpdir. + --pidfilelocking : Abort if pidfile already exists. Useful to avoid concurrent transfers on the same mailbox. @@ -329,7 +393,7 @@ The default logfile name is for example where: 2019_12_22_23_57_59_532 is nearly the date of the start - YYYY_MM_DD_HH_MM_SS_mmm + YYYY_MM_DD_HH_MM_SS_mmm year_month_day_hour_minute_seconde_millisecond and user1 user2 are the --user1 --user2 values. @@ -337,18 +401,18 @@ and user1 user2 are the --user1 --user2 values. =head2 OPTIONS/messages --skipmess reg : Skips messages matching the regex. - Example: 'm/[\x80-ff]/' # to avoid 8bits messages. + Example: 'm/[\x80-\xff]/' # to avoid 8bits messages. --skipmess is applied before --regexmess --skipmess reg : or this one, etc. --skipcrossduplicates : Avoid copying messages that are already copied - in another folder, good from Gmail to X when - X is not also Gmail. + in another folder, good from Gmail to XYZ when + XYZ is not also Gmail. Activated with --gmail1 unless --noskipcrossduplicates --debugcrossduplicates : Prints which messages (UIDs) are skipped with - --skipcrossduplicates (and in what other folders - they are). + --skipcrossduplicates and in what other folders + they are. --pipemess cmd : Apply this cmd command to each message content before the copy. @@ -364,20 +428,21 @@ and user1 user2 are the --user1 --user2 values. --disarmreadreceipts : Disarms read receipts (host2 Exchange issue) --regexmess reg : Apply the whole regex to each message before transfer. - Example: 's/\000/ /g' # to replace null by space. + Example: 's/\000/ /g' # to replace null characters + by spaces. --regexmess reg : and this one, etc. =head2 OPTIONS/labels -Gmail present labels as folders in imap. Imapsync can accelerate the sync +Gmail present labels as folders in imap. Imapsync can accelerate the sync by syncing X-GM-LABELS, it will avoid to transfer messages when they are -already on host2. +already on host2 in another folder. --synclabels : Syncs also Gmail labels when a message is copied to host2. Activated by default with --gmail1 --gmail2 unless --nosynclabels is added. - + --resynclabels : Resyncs Gmail labels when a message is already on host2. Activated by default with --gmail1 --gmail2 unless --noresynclabels is added. @@ -400,6 +465,9 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt May be useful when a user has already started to play with its host2 account. + --filterbuggyflags : Filter flags known to be buggy and generators of errors + "BAD Invalid system flag" or "NO APPEND Invalid flag list". + =head2 OPTIONS/deletions --delete1 : Deletes messages on host1 server after a successful @@ -424,16 +492,18 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt Useful with --delete1 since what remains on host1 is only what failed to be synced. - --delete2 : Delete messages in host2 that are not in - host1 server. Useful for backup or pre-sync. + --delete2 : Delete messages in the host2 account that are not in + the host1 account. Useful for backup or pre-sync. --delete2 implies --uidexpunge2 - --delete2duplicates : Delete messages in host2 that are duplicates. + --delete2duplicates : Deletes messages in host2 that are duplicates in host2. Works only without --useuid since duplicates are detected with an header part of each message. + NB: --delete2duplicates is far less violent than --delete2 + since it removes only duplicates. - --delete2folders : Delete folders in host2 that are not in host1 server. - For safety, first try it like this (it is safe): + --delete2folders : Delete folders in host2 that are not in host1. + For safety, first try it like this, it is safe: --delete2folders --dry --justfolders --nofoldersizes and see what folders will be deleted. @@ -455,10 +525,10 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt If you encounter problems with dates, see also: https://imapsync.lamiral.info/FAQ.d/FAQ.Dates.txt - --syncinternaldates : Sets the internal dates on host2 same as host1. + --syncinternaldates : Sets the internal dates on host2 as the same as host1. Turned on by default. Internal date is the date - a message arrived on a host (Unix mtime). - --idatefromheader : Sets the internal dates on host2 same as the + a message arrived on a host (Unix mtime usually). + --idatefromheader : Sets the internal dates on host2 as same as the ones in "Date:" headers. @@ -467,6 +537,7 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --maxsize int : Skip messages larger (or equal) than int bytes --minsize int : Skip messages smaller (or equal) than int bytes + --maxage int : Skip messages older than int days. final stats (skipped) don't count older messages see also --minage @@ -487,18 +558,30 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --search2 str : Same as --search but for selecting host2 messages only. So --search CRIT equals --search1 CRIT --search2 CRIT + --noabletosearch : Makes --minage and --maxage options use the internal + dates given by a FETCH imap command instead of the + "Date:" header. Internal date is the arrival date + in the mailbox. + --noabletosearch equals --noabletosearch1 --noabletosearch2 + + --noabletosearch1 : Like --noabletosearch but for host1 only. + --noabletosearch2 : Like --noabletosearch but for host2 only. + --maxlinelength int : skip messages with a line length longer than int bytes. RFC 2822 says it must be no more than 1000 bytes but real life servers and email clients do more. --useheader str : Use this header to compare messages on both sides. - Ex: Message-ID or Subject or Date. + Example: "Message-Id" or "Received" or "Date". --useheader str and this one, etc. - --usecache : Use cache to speed up next syncs. Not set by default. + --syncduplicates : Sync also duplicates. Off by default. + + --usecache : Use cache to speed up next syncs. Off by default. --nousecache : Do not use cache. Caveat: --useuid --nousecache creates duplicates on multiple runs. + --useuid : Use UIDs instead of headers as a criterion to recognize messages. Option --usecache is then implied unless --nousecache is used. @@ -516,6 +599,7 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --addheader adds a "Message-Id" header, like "Message-Id: 12345@imapsync", where 12345 is the imap UID of the message on the host1 folder. + Useful to sync folders "Sent" or "Draft". =head2 OPTIONS/debugging @@ -534,7 +618,7 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --tests : Run local non-regression tests. Exit code 0 means all ok. --testslive : Run a live test with test1.lamiral.info imap server. Useful to check the basics. Needs internet connection. - --testslive6 : Run a live test with ks2ipv6.lamiral.info imap server. + --testslive6 : Run a live test with ks6ipv6.lamiral.info imap server. Useful to check the ipv6 connectivity. Needs internet. @@ -543,8 +627,8 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --gmail1 : sets --host1 to Gmail and other options. See FAQ.Gmail.txt --gmail2 : sets --host2 to Gmail and other options. See FAQ.Gmail.txt - --office1 : sets --host1 to Office365 and other options. See FAQ.Exchange.txt - --office2 : sets --host2 to Office365 and other options. See FAQ.Exchange.txt + --office1 : sets --host1 to Office365 and other options. See FAQ.Office365.txt + --office2 : sets --host2 to Office365 and other options. See FAQ.Office365.txt --exchange1 : sets options for Exchange. See FAQ.Exchange.txt --exchange2 : sets options for Exchange. See FAQ.Exchange.txt @@ -555,13 +639,14 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt =head2 OPTIONS/behavior - --maxmessagespersecond int : limits the number of messages transferred per second. + --maxmessagespersecond flo : limits the average number of messages + transferred per second. --maxbytespersecond int : limits the average transfer rate per second. --maxbytesafter int : starts --maxbytespersecond limitation only after --maxbytesafter amount of data transferred. - --maxsleep int : do not sleep more than int seconds. + --maxsleep flo : do not sleep more than int seconds. On by default, 2 seconds max, like --maxsleep 2 --abort : terminates a previous call still running. @@ -570,13 +655,13 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --exitwhenover int : Stop syncing and exits when int total bytes transferred is reached. - --version : Print only software version. + --version : Print only the software version. --noreleasecheck : Do not check for any new imapsync release. --releasecheck : Check for new imapsync release. it's an http request to http://imapsync.lamiral.info/prj/imapsync/VERSION - --noid : Do not send/receive ID command to imap servers. + --noid : Do not send/receive IMAP "ID" command to imap servers. --justconnect : Just connect to both servers and print useful information. Need only --host1 and --host2 options. @@ -609,7 +694,7 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt =head1 SECURITY -You can use --passfile1 instead of --password1 to give the +You can use --passfile1 instead of --password1 to mention the password since it is safer. With --password1 option, on Linux, any user on your host can see the password by using the 'ps auxwwww' command. Using a variable (like IMAPSYNC_PASSWORD1) is also @@ -625,10 +710,10 @@ Imapsync activates ssl if the well known port imaps port (993) is open on the imap servers. If the imaps port is closed then it open a normal (clear) connection on port 143 but it looks for TLS support in the CAPABILITY list of the servers. If TLS is supported -then imapsync goes to encryption. +then imapsync goes to encryption with STARTTLS. If the automatic ssl and the tls detections fail then imapsync will -not protect against sniffing activities on the network, especially +not protect against sniffing activities on the network, especially for passwords. If you want to force ssl or tls just use --ssl1 --ssl2 or --tls1 --tls2 @@ -641,12 +726,14 @@ or at https://imapsync.lamiral.info/FAQ.d/FAQ.Security.txt Imapsync will exit with a 0 status (return code) if everything went good. Otherwise, it exits with a non-zero status. That's classical Unix behavior. Here is the list of the exit code values (an integer between 0 and 255). +In Bourne Shells, this exit code value can be retrieved within the variable +value "$?" if you read it just after the imapsync call. + The names reflect their meaning: =for comment egrep '^Readonly my.*\$EX' imapsync | egrep -o 'EX.*' | sed 's_^_ _' - EX_OK => 0 ; #/* successful termination */ EX_USAGE => 64 ; #/* command line usage error */ EX_NOINPUT => 66 ; #/* cannot open input */ @@ -654,6 +741,7 @@ egrep '^Readonly my.*\$EX' imapsync | egrep -o 'EX.*' | sed 's_^_ _' EX_SOFTWARE => 70 ; #/* internal software error */ EXIT_CATCH_ALL => 1 ; # Any other error EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num + EXIT_BY_FILE => 7 ; EXIT_PID_FILE_ERROR => 8 ; EXIT_CONNECTION_FAILURE => 10 ; EXIT_TLS_FAILURE => 12 ; @@ -661,8 +749,18 @@ egrep '^Readonly my.*\$EX' imapsync | egrep -o 'EX.*' | sed 's_^_ _' EXIT_SUBFOLDER1_NO_EXISTS => 21 ; EXIT_WITH_ERRORS => 111 ; EXIT_WITH_ERRORS_MAX => 112 ; + EXIT_OVERQUOTA => 113 ; + EXIT_ERR_APPEND => 114 ; + EXIT_ERR_FETCH => 115 ; + EXIT_ERR_CREATE => 116 ; + EXIT_ERR_SELECT => 117 ; + EXIT_TRANSFER_EXCEEDED => 118 ; + EXIT_ERR_APPEND_VIRUS => 119 ; EXIT_TESTS_FAILED => 254 ; # Like Test::More API - + EXIT_CONNECTION_FAILURE_HOST1 => 101 ; + EXIT_CONNECTION_FAILURE_HOST2 => 102 ; + EXIT_AUTHENTICATION_FAILURE_USER1 => 161 ; + EXIT_AUTHENTICATION_FAILURE_USER2 => 162 ; =head1 LICENSE AND COPYRIGHT @@ -688,11 +786,11 @@ Good feedback is always welcome. Bad feedback is very often welcome. Gilles LAMIRAL earns his living by writing, installing, -configuring and teaching free, open and often gratis +configuring and sometimes teaching free, open and often gratis software. Imapsync used to be "always gratis" but now it is only "often gratis" because imapsync is sold by its author, -a good way to maintain and support free open public -software over decades. +your servitor, a good way to maintain and support free open public +software tools over decades. =head1 BUGS AND LIMITATIONS @@ -745,8 +843,8 @@ https://imapsync.lamiral.info/examples/ and all Server releases 2000, 2003, 2008 and R2, 2012 and R2, 2016) as a standalone binary software called imapsync.exe, usually launched from a batch file in order to avoid always typing - the options. There is also a 64bit binary called imapsync_64bit.exe - + the options. There is also a 32bit binary called imapsync_32bit.exe + Imapsync works under OS X as a standalone binary software called imapsync_bin_Darwin @@ -783,8 +881,7 @@ Feel free to hack imapsync as the NOLIMIT license permits it. See also https://imapsync.lamiral.info/S/external.shtml for a better up to date list. -Last updated and verified on Sun Dec 8, 2019. - +List verified on Friday July 1, 2021. imapsync: https://github.com/imapsync/imapsync (this is an imapsync copy, sometimes delayed, with --noreleasecheck by default since release 1.592, 2014/05/22) imap_tools: https://web.archive.org/web/20161228145952/http://www.athensfbc.com/imap_tools/. The imap_tools code is now at https://github.com/andrewnimmo/rick-sanders-imap-tools @@ -792,6 +889,7 @@ Last updated and verified on Sun Dec 8, 2019. Doveadm-Sync: https://wiki2.dovecot.org/Tools/Doveadm/Sync ( Dovecot sync tool ) davmail: http://davmail.sourceforge.net/ offlineimap: http://offlineimap.org/ + fdm: https://github.com/nicm/fdm mbsync: http://isync.sourceforge.net/ mailsync: http://mailsync.sourceforge.net/ mailutil: https://www.washington.edu/imap/ part of the UW IMAP toolkit. (well, seems abandoned now) @@ -813,8 +911,8 @@ Last updated and verified on Sun Dec 8, 2019. imapbackup: https://github.com/rcarmo/imapbackup (A Python script for incremental backups of IMAP mailboxes) BitRecover email-backup 99 USD, 299 USD https://www.bitrecover.com/email-backup/. ImportExportTools: https://addons.thunderbird.net/en-us/thunderbird/addon/importexporttools/ ImportExportTools for Mozilla Thunderbird by Paolo Kaosmos. ImportExportTools does not do IMAP. - - + rximapmail: https://sourceforge.net/projects/rximapmail/ + CodeTwo: https://www.codetwo.com/ but CodeTwo does imap source to Office365 only. =head1 HISTORY @@ -825,7 +923,7 @@ away remote imap server, accessible by an often broken low-bandwidth ISDN link. I had to verify every mailbox was well transferred, all folders, all messages, -without wasting bandwidth or creating duplicates upon resyncs. The imapsync +without wasting bandwidth or creating duplicates upon resyncs. The imapsync design was made with the beautiful rsync command in mind. Imapsync started its life as a patch of the copy_folder.pl @@ -833,7 +931,7 @@ script. The script copy_folder.pl comes from the Mail-IMAPClient-2.1.3 perl module tarball source (more precisely in the examples/ directory of the Mail-IMAPClient tarball). -So many happened since then that I wonder +So many changes happened since then that I wonder if it remains any lines of the original copy_folder.pl in imapsync source code. @@ -847,9 +945,12 @@ copy_folder.pl in imapsync source code. use strict ; use warnings ; use Carp ; +use Cwd ; use Data::Dumper ; use Digest::HMAC_SHA1 qw( hmac_sha1 hmac_sha1_hex ) ; use Digest::MD5 qw( md5 md5_hex md5_base64 ) ; +use Encode ; +use Encode::IMAPUTF7 ; use English qw( -no_match_vars ) ; use Errno qw(EAGAIN EPIPE ECONNRESET) ; use Fcntl ; @@ -866,25 +967,23 @@ use IO::Socket::INET6 ; use IO::Socket::SSL ; use IO::Tee ; use IPC::Open3 'open3' ; +#use locale ; use Mail::IMAPClient 3.30 ; use MIME::Base64 ; use Pod::Usage qw(pod2usage) ; -use POSIX qw(uname SIGALRM :sys_wait_h) ; +use POSIX qw( uname SIGALRM :sys_wait_h ) ; use Sys::Hostname ; use Term::ReadKey ; use Test::More ; use Time::HiRes qw( time sleep ) ; use Time::Local ; use Unicode::String ; -use Cwd ; use Readonly ; use Sys::MemInfo ; use Regexp::Common ; use Text::ParseWords ; # for quotewords() use File::Tail ; -use Encode ; -use Encode::IMAPUTF7 ; local $OUTPUT_AUTOFLUSH = 1 ; @@ -918,6 +1017,7 @@ Readonly my $EX_SOFTWARE => 70 ; #/* internal software error */ # Mine Readonly my $EXIT_CATCH_ALL => 1 ; # Any other error Readonly my $EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num +Readonly my $EXIT_BY_FILE => 7 ; Readonly my $EXIT_PID_FILE_ERROR => 8 ; Readonly my $EXIT_CONNECTION_FAILURE => 10 ; Readonly my $EXIT_TLS_FAILURE => 12 ; @@ -925,10 +1025,22 @@ Readonly my $EXIT_AUTHENTICATION_FAILURE => 16 ; Readonly my $EXIT_SUBFOLDER1_NO_EXISTS => 21 ; Readonly my $EXIT_WITH_ERRORS => 111 ; Readonly my $EXIT_WITH_ERRORS_MAX => 112 ; +Readonly my $EXIT_OVERQUOTA => 113 ; +Readonly my $EXIT_ERR_APPEND => 114 ; +Readonly my $EXIT_ERR_FETCH => 115 ; +Readonly my $EXIT_ERR_CREATE => 116 ; +Readonly my $EXIT_ERR_SELECT => 117 ; +Readonly my $EXIT_TRANSFER_EXCEEDED => 118 ; +Readonly my $EXIT_ERR_APPEND_VIRUS => 119 ; Readonly my $EXIT_TESTS_FAILED => 254 ; # Like Test::More API +Readonly my $EXIT_CONNECTION_FAILURE_HOST1 => 101 ; +Readonly my $EXIT_CONNECTION_FAILURE_HOST2 => 102 ; +Readonly my $EXIT_AUTHENTICATION_FAILURE_USER1 => 161 ; +Readonly my $EXIT_AUTHENTICATION_FAILURE_USER2 => 162 ; + Readonly my %EXIT_TXT => ( $EX_OK => 'EX_OK: successful termination', @@ -939,6 +1051,7 @@ Readonly my %EXIT_TXT => ( $EXIT_CATCH_ALL => 'EXIT_CATCH_ALL', $EXIT_BY_SIGNAL => 'EXIT_BY_SIGNAL', + $EXIT_BY_FILE => 'EXIT_BY_FILE', $EXIT_PID_FILE_ERROR => 'EXIT_PID_FILE_ERROR' , $EXIT_CONNECTION_FAILURE => 'EXIT_CONNECTION_FAILURE', $EXIT_TLS_FAILURE => 'EXIT_TLS_FAILURE', @@ -946,7 +1059,37 @@ Readonly my %EXIT_TXT => ( $EXIT_SUBFOLDER1_NO_EXISTS => 'EXIT_SUBFOLDER1_NO_EXISTS', $EXIT_WITH_ERRORS => 'EXIT_WITH_ERRORS', $EXIT_WITH_ERRORS_MAX => 'EXIT_WITH_ERRORS_MAX', + $EXIT_OVERQUOTA => 'EXIT_OVERQUOTA', + $EXIT_ERR_APPEND => 'EXIT_ERR_APPEND', + $EXIT_ERR_APPEND_VIRUS => 'EXIT_ERR_APPEND_VIRUS', + $EXIT_ERR_FETCH => 'EXIT_ERR_FETCH', + $EXIT_ERR_CREATE => 'EXIT_ERR_CREATE', + $EXIT_ERR_SELECT => 'EXIT_ERR_SELECT', $EXIT_TESTS_FAILED => 'EXIT_TESTS_FAILED', + $EXIT_TRANSFER_EXCEEDED => 'EXIT_TRANSFER_EXCEEDED', + $EXIT_CONNECTION_FAILURE_HOST1 => 'EXIT_CONNECTION_FAILURE_HOST1', + $EXIT_CONNECTION_FAILURE_HOST2 => 'EXIT_CONNECTION_FAILURE_HOST2', + $EXIT_AUTHENTICATION_FAILURE_USER1 => 'EXIT_AUTHENTICATION_FAILURE_USER1', + $EXIT_AUTHENTICATION_FAILURE_USER2 => 'EXIT_AUTHENTICATION_FAILURE_USER2', +) ; + + +Readonly my %EXIT_VALUE_OF_ERR_TYPE => ( + ERR_APPEND_SIZE => $EXIT_ERR_APPEND, + ERR_OVERQUOTA => $EXIT_OVERQUOTA, + ERR_APPEND => $EXIT_ERR_APPEND, + ERR_APPEND_VIRUS => $EXIT_ERR_APPEND_VIRUS, + ERR_CREATE => $EXIT_ERR_CREATE, + ERR_SELECT => $EXIT_ERR_SELECT, + ERR_Host1_FETCH => $EXIT_ERR_FETCH, + ERR_UNCLASSIFIED => $EXIT_WITH_ERRORS, + ERR_NOTHING_REPORTED => $EXIT_WITH_ERRORS, + ERR_TRANSFER_EXCEEDED => $EXIT_TRANSFER_EXCEEDED, + ERR_CONNECTION_FAILURE_HOST1 => $EXIT_CONNECTION_FAILURE_HOST1, + ERR_CONNECTION_FAILURE_HOST2 => $EXIT_CONNECTION_FAILURE_HOST2, + ERR_AUTHENTICATION_FAILURE_USER1 => $EXIT_AUTHENTICATION_FAILURE_USER1, + ERR_AUTHENTICATION_FAILURE_USER2 => $EXIT_AUTHENTICATION_FAILURE_USER2, + ERR_EXIT_TLS_FAILURE => $EXIT_TLS_FAILURE, ) ; @@ -976,7 +1119,7 @@ Readonly my $RELEASE_NUMBER_EXAMPLE_2 => 42.4242 ; Readonly my $TCP_PING_TIMEOUT => 5 ; Readonly my $DEFAULT_TIMEOUT => 120 ; Readonly my $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND => 3 ; -Readonly my $DEFAULT_UIDNEXT => 999_999 ; + Readonly my $DEFAULT_BUFFER_SIZE => 4096 ; Readonly my $MAX_SLEEP => 2 ; # 2 seconds max for limiting too long sleeps from --maxbytespersecond and --maxmessagespersecond @@ -1029,15 +1172,13 @@ Readonly my $FORCE => 1 ; # global variables -# Currently working to finish with only $sync +# Currently working to finish with only $sync, $acc1, $acc2 # Not finished yet... my( - $sync, - $timestart_str, - $debugimap, $debugimap1, $debugimap2, $debugcontent, $debugflags, + $sync, $acc1, $acc2, + $debugcontent, $debugflags, $debuglist, $debugdev, $debugmaxlinelength, $debugcgi, - $domain1, $domain2, @include, @exclude, @folderrec, @folderfirst, @folderlast, @@ -1052,46 +1193,39 @@ my( %h2_folders_from_1_several, $prefix1, $prefix2, - @regexmess, @regexflag, @skipmess, @pipemess, $pipemesscheck, - $flagscase, $filterflags, $syncflagsaftercopy, + @regexmess, @skipmess, @pipemess, $pipemesscheck, + $syncflagsaftercopy, $syncinternaldates, $idatefromheader, - $syncacls, - $fastio1, $fastio2, + $minsize, $maxage, $minage, $search, - $skipheader, @useheader, %useheader, + @useheader, %useheader, $skipsize, $allowsizemismatch, $buffersize, $authmd5, $authmd51, $authmd52, $subscribed, $subscribe, $subscribeall, $help, - $justbanner, + $fast, $nb_msg_skipped_dry_mode, - $h1_nb_msg_duplicate, - $h2_nb_msg_duplicate, - $h2_nb_msg_noheader, - $h2_nb_msg_deleted, + $h2_nb_msg_noheader, $h1_bytes_processed, $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end, - $timeout, $timestart_int, $uid1, $uid2, - $authuser1, $authuser2, - $proxyauth1, $proxyauth2, - $authmech1, $authmech2, + + $split1, $split2, - $reconnectretry1, $reconnectretry2, - $max_msg_size_in_bytes, + $modulesversion, $delete2folders, $delete2foldersonly, $delete2foldersbutnot, $usecache, $debugcache, $cacheaftercopy, @@ -1101,7 +1235,6 @@ my( $fixInboxINBOX, $maxlinelength, $maxlinelengthcmd, $minmaxlinelength, - $uidnext_default, $fixcolonbug, $create_folder_old, $skipcrossduplicates, $debugcrossduplicates, @@ -1114,7 +1247,9 @@ my( $warn_release, ) ; -single_sync( ) ; +single_sync( $sync, $acc1, $acc2 ); + + sub single_sync { @@ -1122,21 +1257,36 @@ sub single_sync # main program # global variables initialization -# I'm currently removing all global variables except $sync -# passing each of them under $sync->{variable_name} +# I'm currently removing all global variables except $sync $acc1 $acc2 +# passing each of them under +# $sync->{variable_name} +# or $acc1->{variable_name} +# or $acc1->{variable_name} + +# +$acc1 = {} ; +$acc2 = {} ; +$sync->{ acc1 } = $acc1 ; +$sync->{ acc2 } = $acc2 ; + +$acc1->{ Side } = 'Host1' ; +$acc2->{ Side } = 'Host2' ; $sync->{timestart} = time ; # Is a float because of use Time::HiRres -$sync->{rcs} = q{$Id: imapsync,v 1.977 2019/12/23 20:18:02 gilles Exp gilles $} ; +$sync->{rcs} = q{$Id: imapsync,v 2.148 2021/07/22 14:21:09 gilles Exp gilles $} ; $sync->{ memory_consumption_at_start } = memory_consumption( ) || 0 ; + my @loadavg = loadavg( ) ; -$sync->{cpu_number} = cpu_number( ) ; -$sync->{loaddelay} = load_and_delay( $sync->{cpu_number}, @loadavg ) ; -$sync->{loadavg} = join( q{ }, $loadavg[ 0 ] ) +$sync->{ cpu_number } = cpu_number( ) ; +$sync->{ loaddelay } = load_and_delay( $sync->{ cpu_number }, @loadavg ) ; +$sync->{ loaddelay } = 0 ; + +$sync->{ loadavg } = join( q{ }, $loadavg[ 0 ] ) . " on $sync->{cpu_number} cores and " . ram_memory_info( ) ; @@ -1146,10 +1296,13 @@ $sync->{ total_bytes_transferred } = 0 ; $sync->{ total_bytes_skipped } = 0 ; $sync->{ nb_msg_transferred } = 0 ; $sync->{ nb_msg_skipped } = $nb_msg_skipped_dry_mode = 0 ; -$sync->{ h1_nb_msg_deleted } = 0 ; -$h2_nb_msg_deleted = 0 ; -$h1_nb_msg_duplicate = 0 ; -$h2_nb_msg_duplicate = 0 ; + +$sync->{ acc1 }->{ nb_msg_deleted } = 0 ; +$sync->{ acc2 }->{ nb_msg_deleted } = 0 ; + +$sync->{ acc1 }->{ nb_msg_duplicate } = 0 ; +$sync->{ acc2 }->{ nb_msg_duplicate } = 0 ; + $sync->{ h1_nb_msg_noheader } = 0 ; $h2_nb_msg_noheader = 0 ; @@ -1165,8 +1318,8 @@ $sync->{ h2_nb_msg_crossdup } = 0 ; #$h1_nb_msg_end = $h1_bytes_end = 0 ; #$h2_nb_msg_end = $h2_bytes_end = 0 ; -$sync->{nb_errors} = 0; -$max_msg_size_in_bytes = 0; +$sync->{ nb_errors } = 0; +$sync->{ biggest_message_transferred } = 0; %month_abrev = ( Jan => '00', @@ -1192,14 +1345,14 @@ cgibegin( $sync ) ; # In cgi context, printing must start by the header so we delay other prints by using output() storage my $options_good = get_options( $sync, @ARGV ) ; # Is it the first myprint? -docker_context( $sync ) ; cgibuildheader( $sync ) ; +docker_context( $sync ) ; + +print_output_if_needed( $sync ) ; + -myprint( output( $sync ) ) ; output_reset_with( $sync ) ; -# Old place for cgiload( $sync ) ; - # don't go on if options are not all known. if ( ! defined $options_good ) { exit $EX_USAGE ; } @@ -1214,7 +1367,7 @@ $sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} # just the version if ( $sync->{ version } ) { myprint( imapsync_version( $sync ), "\n" ) ; - exit 0 ; + return 0 ; } #$sync->{debugenv} = 1 ; @@ -1224,6 +1377,8 @@ load_modules( ) ; # after_get_options call usage and exit if --help or options were not well got after_get_options( $sync, $options_good ) ; +#local $ENV{TZ} = 'GMT' if ( under_cgi_context( $sync ) and 'MSWin32' ne $OSNAME ) ; +#output( $sync, localtime(time) . " " . gmtime(time) . "\n" ) ; # Under CGI environment, fix caveat emptor potential issues cgisetcontext( $sync ) ; @@ -1237,28 +1392,40 @@ sanitize( $sync ) ; $sync->{ tmpdir } ||= File::Spec->tmpdir( ) ; # Unit tests -testsexit( $sync ) ; +my $unittestssuite = unittestssuite( $sync ) ; + + +if ( condition_to_leave_after_tests( $sync ) ) +{ + return $unittestssuite ; +} # init live varaiables -testslive_init( $sync ) if ( $sync->{testslive} ) ; -testslive6_init( $sync ) if ( $sync->{testslive6} ) ; -# +if ( $sync->{ testslive } ) +{ + testslive_init( $sync ) ; +} -pidfile( $sync ) ; +if ( $sync->{ testslive6 } ) +{ + testslive6_init( $sync ) ; +} -# old abort place +define_pidfile( $sync ) ; +if ( $sync->{ abortbyfile } ) { $sync->{ abort } = 1 ; } install_signals( $sync ) ; -$sync->{log} = defined $sync->{log} ? $sync->{log} : 1 ; -$sync->{errorsdump} = defined $sync->{errorsdump} ? $sync->{errorsdump} : 1 ; -$sync->{errorsmax} = defined $sync->{errorsmax} ? $sync->{errorsmax} : $ERRORS_MAX ; +$sync->{ log } = defined $sync->{ log } ? $sync->{ log } : 1 ; +$sync->{ errorsdump } = defined $sync->{ errorsdump } ? $sync->{ errorsdump } : 1 ; +$sync->{ errorsmax } = defined $sync->{ errorsmax } ? $sync->{ errorsmax } : $ERRORS_MAX ; # log and output binmode STDOUT, ":encoding(UTF-8)" ; -if ( $sync->{log} ) { + +if ( $sync->{ log } ) { setlogfile( $sync ) ; teelaunch( $sync ) ; # now $sync->{tee} is a filehandle to STDOUT and the logfile @@ -1266,7 +1433,7 @@ if ( $sync->{log} ) { #binmode STDERR, ":encoding(UTF-8)" ; # STDERR goes to the same place: LOG and STDOUT (if logging is on) -# Useful only for --debugssl +# Useful only for --debugssl $sync->{tee} and local *STDERR = *${$sync->{tee}}{IO} ; @@ -1275,14 +1442,14 @@ $timestart_int = int( $sync->{timestart} ) ; $sync->{timebefore} = $sync->{timestart} ; -$timestart_str = localtime( $sync->{timestart} ) ; +$sync->{ timestart_str } = localtimez( $sync->{timestart} ) ; # The prints in the log starts here myprint( localhost_info( $sync ), "\n" ) ; -myprint( "Transfer started at $timestart_str\n" ) ; +myprint( "Transfer started at $sync->{ timestart_str }\n" ) ; myprint( "PID is $PROCESS_ID my PPID is ", mygetppid( ), "\n" ) ; -myprint( "Log file is $sync->{logfile} ( to change it, use --logfile path ; or use --nolog to turn off logging )\n" ) if ( $sync->{log} ) ; +announcelogfile( $sync ) ; myprint( "Load is " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $sync->{cpu_number} cores\n" ) ; #myprintf( "Memory consumption so far: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ; myprint( 'Current directory is ' . getcwd( ) . "\n" ) ; @@ -1296,11 +1463,13 @@ $warn_release = ( $sync->{releasecheck} ) ? check_last_release( ) : $STR_use_re $wholeheaderifneeded = defined $wholeheaderifneeded ? $wholeheaderifneeded : 1; -# Activate --usecache if --useuid is set and no --nousecache +# Activate --usecache if --useuid is set and there is no --nousecache $usecache = 1 if ( $useuid and ( ! defined $usecache ) ) ; $cacheaftercopy = 1 if ( $usecache and ( ! defined $cacheaftercopy ) ) ; -$sync->{ checkselectable } = defined $sync->{ checkselectable } ? $sync->{ checkselectable } : 1 ; + + + $sync->{ checkfoldersexist } = defined $sync->{ checkfoldersexist } ? $sync->{ checkfoldersexist } : 1 ; $checkmessageexists = defined $checkmessageexists ? $checkmessageexists : 0 ; $sync->{ expungeaftereach } = defined $sync->{ expungeaftereach } ? $sync->{ expungeaftereach } : 1 ; @@ -1312,6 +1481,7 @@ $sync->{abletosearch2} = defined $sync->{abletosearch2} ? $sync->{abletosear $checkmessageexists = 0 if ( not $sync->{abletosearch1} ) ; +$sync->{ trylogin } = defined $sync->{ trylogin } ? $sync->{ trylogin } : 1 ; $sync->{showpasswords} = defined $sync->{showpasswords} ? $sync->{showpasswords} : 0 ; $sync->{ fixslash2 } = defined $sync->{ fixslash2 } ? $sync->{ fixslash2 } : 1 ; $fixInboxINBOX = defined $fixInboxINBOX ? $fixInboxINBOX : 1 ; @@ -1335,19 +1505,18 @@ output_reset_with( $sync ) ; do_valid_directory( $sync->{ tmpdir } ) || croak "Error creating tmpdir $sync->{ tmpdir } : $OS_ERROR" ; -remove_pidfile_not_running( $sync->{pidfile} ) ; +remove_pidfile_not_running( $sync->{ pidfile } ) ; # if another imapsync is running then tail -f its logfile and exit # useful in cgi context if ( $sync->{ tail } and tail( $sync ) ) { - $sync->{nb_errors}++ ; exit_clean( $sync, $EX_OK, "Tail -f finished. Now finishing myself processus $PROCESS_ID\n" ) ; exit $EX_OK ; } if ( ! write_pidfile( $sync ) ) { - myprint( "Exiting with return value $EXIT_PID_FILE_ERROR ($EXIT_TXT{$EXIT_PID_FILE_ERROR}) $sync->{nb_errors}/$sync->{errorsmax} nb_errors/max_errors\n" ) ; + myprint( "Exiting with return value $EXIT_PID_FILE_ERROR ($EXIT_TXT{$EXIT_PID_FILE_ERROR}) $sync->{nb_errors}/$sync->{errorsmax} nb_errors/max_errors PID $PROCESS_ID\n" ) ; exit $EXIT_PID_FILE_ERROR ; } @@ -1357,18 +1526,22 @@ if ( ! write_pidfile( $sync ) ) { if ( $sync->{ abort } ) { abort( $sync ) ; + # well, the abort job is done, because even when not succeeded + # in aborting another run, this run has to end without doing any + # thing else + + exit $EX_OK ; } # simulong is just a loop printing some lines for xx seconds with option "--simulong xx". -if ( $sync->{ simulong } ) -{ - simulong( $sync->{ simulong } ) ; -} +simulong( $sync ) ; + # New place for cgiload 2019_03_03 # because I want to log it # Can break here if load is too heavy +# Have in mind the CGI header has already a 503 Service Unavailable cgiload( $sync ) ; @@ -1376,20 +1549,28 @@ $fixcolonbug = defined $fixcolonbug ? $fixcolonbug : 1 ; if ( $usecache and $fixcolonbug ) { tmpdir_fix_colon_bug( $sync ) } ; -$modulesversion and myprint( "Modules version list:\n", modulesversion(), "( use --no-modulesversion to turn off printing this Perl modules list )\n" ) ; +$modulesversion and myprint( "Modules version list ( use --no-modulesversion to turn off printing this Perl modules list ):\n", modulesversion(), "\n" ) ; check_lib_version( $sync ) or croak "imapsync needs perl lib Mail::IMAPClient release 3.30 or superior.\n"; -exit_clean( $sync, $EX_OK ) if ( $justbanner ) ; + +if ( $sync->{ justbanner } ) +{ + myprint( "Exiting because of --justbanner\n" ) ; + exit_clean( $sync, $EX_OK ) ; +} # turn on RFC standard flags correction like \SEEN -> \Seen -$flagscase = defined $flagscase ? $flagscase : 1 ; +$sync->{ flagscase } = defined $sync->{ flagscase } ? $sync->{ flagscase } : 1 ; # Use PERMANENTFLAGS if available -$filterflags = defined $filterflags ? $filterflags : 1 ; +$sync->{ filterflags } = defined $sync->{ filterflags } ? $sync->{ filterflags } : 1 ; + +filterbuggyflags( $sync ) ; + # sync flags just after an APPEND, some servers ignore the flags given in the APPEND # like MailEnable IMAP server. @@ -1412,13 +1593,18 @@ $split1 ||= $SPLIT ; $split2 ||= $SPLIT ; #$sync->{host1} || missing_option( $sync, '--host1' ) ; +$sync->{host1} = sanitize_host( $sync->{host1} ) ; $sync->{port1} ||= ( $sync->{ssl1} ) ? $IMAP_SSL_PORT : $IMAP_PORT ; #$sync->{host2} || missing_option( $sync, '--host2' ) ; +$sync->{host2} = sanitize_host( $sync->{host2} ) ; $sync->{port2} ||= ( $sync->{ssl2} ) ? $IMAP_SSL_PORT : $IMAP_PORT ; -$debugimap1 = $debugimap2 = 1 if ( $debugimap ) ; -$sync->{ debug } = 1 if ( $debugimap1 or $debugimap2 ) ; + +$acc1->{ debugimap } = $acc2->{ debugimap } = 1 if ( $sync->{ debugimap } ) ; +# Set on debug mode if one of the imap dialogs are in debug. +# imap dialog without the debug mode is scary and useless. +$sync->{ debug } = 1 if ( $acc1->{ debugimap } or $acc2->{ debugimap } ) ; # By default, don't take size to compare $skipsize = (defined $skipsize) ? $skipsize : 1; @@ -1455,6 +1641,7 @@ if ( $sync->{ssl1} or $sync->{ssl2} or $sync->{tls1} or $sync->{tls2}) { if ( $sync->{ssl1} ) { myprint( qq{Host1: SSL default mode is like --sslargs1 "SSL_verify_mode=$SSL_VERIFY_POLICY", meaning for host1 $SSL_VERIFY_STR{$SSL_VERIFY_POLICY}\n} ) ; myprint( 'Host1: Use --sslargs1 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " to have $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} of host1\n" ) ; + # $sync->{ acc1 }->{sslargs}->{SSL_verify_mode} } if ( $sync->{ssl2} ) { @@ -1516,8 +1703,11 @@ if ( ( $sync->{ delete2 } or $sync->{ delete2duplicates } ) and not defined $sy } if ( $sync->{ delete1 } and $sync->{ delete2 } ) { - myprint( "Warning: using --delete1 and --delete2 together is almost always a bad idea, exiting imapsync\n" ) ; - $sync->{nb_errors}++ ; + myprint( "Warning: using --delete1 and --delete2 together is almost always a bad idea. " + . "You should probably launch two runs, the first with --delete2 for a strict sync, " + . "then the second with --delete1 to remove messages from the source account. " + . "Exiting imapsync.\n" ) ; + $sync->{ nb_errors }++ ; exit_clean( $sync, $EX_USAGE ) ; } @@ -1540,44 +1730,48 @@ if ( defined $authmd5 and $authmd5 ) { } if ( defined $authmd51 and $authmd51 ) { - $authmech1 ||= 'CRAM-MD5'; + $acc1->{ authmech } ||= 'CRAM-MD5' ; } else{ - $authmech1 ||= $authuser1 ? 'PLAIN' : 'LOGIN'; + $acc1->{ authmech } ||= $acc1->{ authuser } ? 'PLAIN' : 'LOGIN' ; } if ( defined $authmd52 and $authmd52 ) { - $authmech2 ||= 'CRAM-MD5'; + $acc2->{ authmech } ||= 'CRAM-MD5'; } else{ - $authmech2 ||= $authuser2 ? 'PLAIN' : 'LOGIN'; + $acc2->{ authmech } ||= $acc2->{ authuser } ? 'PLAIN' : 'LOGIN'; } -$authmech1 = uc $authmech1; -$authmech2 = uc $authmech2; +$acc1->{ authmech } = uc $acc1->{ authmech } ; +$acc2->{ authmech } = uc $acc2->{ authmech } ; -if (defined $proxyauth1 && !$authuser1) { +if ( defined $acc1->{ proxyauth } && !$acc1->{ authuser } ) +{ missing_option( $sync, 'With --proxyauth1, --authuser1' ) ; } -if (defined $proxyauth2 && !$authuser2) { +if ( defined $acc2->{ proxyauth } && !$acc2->{ authuser } ) +{ missing_option( $sync, 'With --proxyauth2, --authuser2' ) ; } -#$authuser1 ||= $sync->{user1}; -#$authuser2 ||= $sync->{user2}; +myprint( "Host1: will try to use $acc1->{ authmech } authentication on host1\n") ; +myprint( "Host2: will try to use $acc2->{ authmech } authentication on host2\n") ; -myprint( "Host1: will try to use $authmech1 authentication on host1\n") ; -myprint( "Host2: will try to use $authmech2 authentication on host2\n") ; +$sync->{ timeout } = defined $sync->{ timeout } ?$sync->{ timeout } : $DEFAULT_TIMEOUT ; -$timeout = defined $timeout ? $timeout : $DEFAULT_TIMEOUT ; +$sync->{ acc1 }->{timeout} = defined $sync->{ acc1 }->{timeout} ? $sync->{ acc1 }->{timeout} : $sync->{ timeout } ; +myprint( "Host1: imap connection timeout is $sync->{ acc1 }->{timeout} seconds\n") ; +$sync->{ acc2 }->{timeout} = defined $sync->{ acc2 }->{timeout} ? $sync->{ acc2 }->{timeout} : $sync->{ timeout } ; +myprint( "Host2: imap connection timeout is $sync->{ acc2 }->{timeout} seconds\n" ) ; -$sync->{h1}->{timeout} = defined $sync->{h1}->{timeout} ? $sync->{h1}->{timeout} : $timeout ; -myprint( "Host1: imap connection timeout is $sync->{h1}->{timeout} seconds\n") ; -$sync->{h2}->{timeout} = defined $sync->{h2}->{timeout} ? $sync->{h2}->{timeout} : $timeout ; -myprint( "Host2: imap connection timeout is $sync->{h2}->{timeout} seconds\n" ) ; +if ( under_cgi_context( $sync ) ) +{ + myprint( "Under CGI context, a timeout can occur from the webserver, see https://imapsync.lamiral.info/INSTALL.d/INSTALL.OnlineUI.txt\n" ) ; +} -$syncacls = defined $syncacls ? $syncacls : 0 ; +$sync->{ syncacls } = defined $sync->{ syncacls } ? $sync->{ syncacls } : 0 ; # No folders sizes if --justfolders, unless really wanted. if ( @@ -1592,21 +1786,21 @@ if ( $sync->{ foldersizes } = ( defined $sync->{ foldersizes } ) ? $sync->{ foldersizes } : 1 ; $sync->{ foldersizesatend } = ( defined $sync->{ foldersizesatend } ) ? $sync->{ foldersizesatend } : $sync->{ foldersizes } ; +$sync->{ checknoabletosearch } = ( defined $sync->{ checknoabletosearch } ) ? $sync->{ checknoabletosearch } : 1 ; -$fastio1 = defined $fastio1 ? $fastio1 : 0 ; -$fastio2 = defined $fastio2 ? $fastio2 : 0 ; -$reconnectretry1 = defined $reconnectretry1 ? $reconnectretry1 : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; -$reconnectretry2 = defined $reconnectretry2 ? $reconnectretry2 : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; +$acc1->{ fastio } = defined $acc1->{ fastio } ? $acc1->{ fastio } : 0 ; +$acc2->{ fastio } = defined $acc2->{ fastio } ? $acc2->{ fastio } : 0 ; + + +$acc1->{ reconnectretry } = defined $acc1->{ reconnectretry } ? $acc1->{ reconnectretry } : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; +$acc2->{ reconnectretry } = defined $acc2->{ reconnectretry } ? $acc2->{ reconnectretry } : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; -# Since select_msgs() returns no messages when uidnext does not return something -# then $uidnext_default is never used. So I have to remove it. -$uidnext_default = $DEFAULT_UIDNEXT ; if ( ! @useheader ) { @useheader = qw( Message-Id Received ) ; } # Make a hash %useheader of each --useheader 'key' in uppercase -for ( @useheader ) { $useheader{ uc $_ } = undef } ; +for ( @useheader ) { $sync->{useheader}->{ uc $_ } = undef } ; #myprint( Data::Dumper->Dump( [ \%useheader ] ) ) ; #exit ; @@ -1617,6 +1811,10 @@ myprint( "Host2: IMAP server [$sync->{host2}] port [$sync->{port2}] user [$sync- get_password1( $sync ) ; get_password2( $sync ) ; +# --dry1 make imapsync not fetching messages from host1, it is on when --dry is on. +# Use --dry --nodry1 to make imapsync fetching messages from host1, +# It is useful when debugging transformation options like --pipemess or --regexmess +$sync->{dry1} = defined $sync->{dry1} ? $sync->{dry1} : $sync->{dry} ; $sync->{dry_message} = q{} ; if( $sync->{dry} ) { @@ -1626,7 +1824,8 @@ if( $sync->{dry} ) { $sync->{ search1 } ||= $search if ( $search ) ; $sync->{ search2 } ||= $search if ( $search ) ; -if ( $disarmreadreceipts ) { +if ( $disarmreadreceipts ) +{ push @regexmess, q{s{\A((?:[^\n]+\r\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims} ; } @@ -1688,9 +1887,9 @@ if ( @skipmess ) { myprint( "Ok with each --skipmess\n" ) ; } -if ( @regexflag ) { +if ( $sync->{ regexflag } ) { myprint( "Checking each --regexflag command with an space string.\n" ) ; - my $string = flags_regex( q{ } ) ; + my $string = regexflags( $sync, q{ } ) ; # string undef means one of the eval regex was bad. if ( not ( defined $string ) ) { $sync->{nb_errors}++ ; @@ -1701,33 +1900,26 @@ if ( @regexflag ) { myprint( "Ok with each --regexflag\n" ) ; } -$sync->{imap1} = login_imap( $sync->{host1}, $sync->{port1}, $sync->{user1}, $domain1, $sync->{password1}, - $debugimap1, $sync->{h1}->{timeout}, $fastio1, $sync->{ssl1}, $sync->{tls1}, - $authmech1, $authuser1, $reconnectretry1, - $proxyauth1, $uid1, $split1, 'Host1', $sync->{h1}, $sync ) ; +$sync->{imap1} = login_imap( $sync->{host1}, $sync->{port1}, $sync->{user1}, $sync->{password1}, + $sync->{ssl1}, $sync->{tls1}, + $uid1, $split1, $sync->{ acc1 }, $sync ) ; -$sync->{imap2} = login_imap( $sync->{host2}, $sync->{port2}, $sync->{user2}, $domain2, $sync->{password2}, - $debugimap2, $sync->{h2}->{timeout}, $fastio2, $sync->{ssl2}, $sync->{tls2}, - $authmech2, $authuser2, $reconnectretry2, - $proxyauth2, $uid2, $split2, 'Host2', $sync->{h2}, $sync ) ; +$sync->{imap2} = login_imap( $sync->{host2}, $sync->{port2}, $sync->{user2}, $sync->{password2}, + $sync->{ssl2}, $sync->{tls2}, + $uid2, $split2, $sync->{ acc2 }, $sync ) ; -$sync->{ debug } and myprint( 'Host1 Buffer I/O: ', $sync->{imap1}->Buffer(), "\n" ) ; -$sync->{ debug } and myprint( 'Host2 Buffer I/O: ', $sync->{imap2}->Buffer(), "\n" ) ; +$sync->{ debug } and $sync->{imap1} and myprint( 'Host1 Buffer I/O: ', $sync->{imap1}->Buffer(), "\n" ) ; +$sync->{ debug } and $sync->{imap2} and myprint( 'Host2 Buffer I/O: ', $sync->{imap2}->Buffer(), "\n" ) ; -if ( ! $sync->{imap1}->IsAuthenticated( ) ) +if ( ! $sync->{imap1} || ! $sync->{imap2} ) { - $sync->{nb_errors}++ ; - exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Not authenticated on host1\n" ) ; + exit_most_errors( $sync ) ; } + + myprint( "Host1: state Authenticated\n" ) ; - -if ( ! $sync->{imap2}->IsAuthenticated( ) ) -{ - $sync->{nb_errors}++ ; - exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Not authenticated on host2\n" ) ; -} myprint( "Host2: state Authenticated\n" ) ; myprint( 'Host1 capability once authenticated: ', join(q{ }, @{ $sync->{imap1}->capability() || [] }), "\n" ) ; @@ -1886,29 +2078,17 @@ if ( $sync->{ checkfoldersexist } ) { myprint( "Host1: Not checking that wanted folders exist. Remove --nocheckfoldersexist to get this check.\n" ) ; } +setcheckselectable( $sync ) ; -if ( $sync->{ checkselectable } ) { - my @h1_folders_wanted_selectable ; - myprint( "Host1: Checking wanted folders are selectable. Use --nocheckselectable to avoid this check.\n" ) ; - foreach my $folder ( @{ $sync->{h1_folders_wanted} } ) { - ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Checking $folder is selectable on host1\n" ) ; - # It does an imap command LIST "" $folder and then search for no \Noselect - if ( ! $sync->{imap1}->selectable( $folder ) ) { - myprint( "Host1: warning! ignoring folder $folder because it is not selectable\n" ) ; - }else{ - push @h1_folders_wanted_selectable, $folder ; - } - } - @{ $sync->{h1_folders_wanted} } = @h1_folders_wanted_selectable ; - ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( 'Host1: checking folders took ', timenext( $sync ), " s\n" ) ; -}else{ - myprint( "Host1: Not checking that wanted folders are selectable. Remove --nocheckselectable to get this check.\n" ) ; -} +checkselectable( $sync ) ; -# Old place of private_folders_separators_and_prefixes( ) call. -#private_folders_separators_and_prefixes( ) ; +# Bugfix OpenFind folders named like "kk \*123" are in fact "kk *123" (no \) +#foreach my $folder ( @{ $sync->{ h1_folders_wanted } } ) +#{ +# $folder =~ s{ \\\*}{ *}g ; +#} # this hack is because LWP post does not pass well a hash in the $form parameter @@ -2021,6 +2201,25 @@ if ( $sync->{ skipemptyfolders } ) myprint( "Host1: will not syncing empty folders on host1. Use --noskipemptyfolders to create them anyway on host2\n") ; } +if ( $sync->{ checknoabletosearch } ) +{ + myprint( "Checking SEARCH ALL works on both accounts. To avoid that check, use --nochecknoabletosearch\n" ) ; + my $check1 = checknoabletosearch( $sync, $sync->{ imap1 }, 'INBOX', 'Host1' ) ; + my $check2 = checknoabletosearch( $sync, $sync->{ imap2 }, 'INBOX', 'Host2' ) ; + if ( $check1 or $check2 ) + { + myprint( "At least one account can not SEARCH ALL. So acting like --noabletosearch\n" ) ; + $sync->{abletosearch} = 0 ; + $sync->{abletosearch1} = 0 ; + $sync->{abletosearch2} = 0 ; + } + else + { + myprint( "Good! SEARCH ALL works on both accounts.\n" ) ; + } +} + + if ( $sync->{ foldersizes } ) { @@ -2035,7 +2234,7 @@ if ( $sync->{ justfoldersizes } ) exit_clean( $sync, $EX_OK, "Exiting because of --justfoldersizes\n" ) ; } -$sync->{stats} = 1 ; +$sync->{can_do_stats} = 1 ; if ( $sync->{ delete1emptyfolders } ) { delete1emptyfolders( $sync ) ; @@ -2060,6 +2259,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) { $sync->{ h1_current_folder } = $h1_fold ; eta_print( $sync ) ; + abortifneeded( $sync ) ; if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } my $h2_fold = imap2_folder_name( $sync, $h1_fold ) ; @@ -2075,10 +2275,15 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) debugsleep( $sync ) ; - my $h1_fold_nb_messages = count_from_select( $sync->{imap1}->History ) ; - myprint( "Host1: folder [$h1_fold] has $h1_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ; + my $h1_msgs_all_hash_ref ; + my @h1_msgs ; + my $h1_msgs_nb ; + my $h1_msgs_nb_from_select ; - if ( $sync->{ skipemptyfolders } and 0 == $h1_fold_nb_messages ) { + $h1_msgs_nb_from_select = count_from_select( $sync->{imap1}->History ) ; + myprint( "Host1: folder [$h1_fold] has $h1_msgs_nb_from_select messages in total (mentioned by SELECT)\n" ) ; + + if ( $sync->{ skipemptyfolders } and 0 == $h1_msgs_nb_from_select ) { myprint( "Host1: skipping empty host1 folder [$h1_fold]\n" ) ; next FOLDER ; } @@ -2087,22 +2292,32 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) # Thanks jh1995 # Goal: do not create folder if --search or --max/minage return 0 message. # even if there are messages by SELECT (no not real empty, empty for the user point of vue). - if ( $sync->{ skipemptyfolders } ) + if ( $sync->{ skipemptyfolders } or $sync->{ dry } ) { - my $h1_msgs_all_hash_ref_tmp = { } ; - my @h1_msgs_tmp = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref_tmp, $sync->{ search1 }, $h1_fold ) ; - my $h1_fold_nb_messages_tmp = scalar( @h1_msgs_tmp ) ; - if ( 0 == $h1_fold_nb_messages_tmp ) { + $h1_msgs_all_hash_ref = { } ; + @h1_msgs = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref, $sync->{ search1 }, $sync->{abletosearch1}, $h1_fold ) ; + + $h1_msgs_nb = scalar( @h1_msgs ) ; + if ( 0 == $h1_msgs_nb and $sync->{ skipemptyfolders } ) { myprint( "Host1: skipping empty host1 folder [$h1_fold] (0 message found by SEARCH)\n" ) ; next FOLDER ; } } if ( ! exists $h2_folders_all{ $h2_fold } ) { - create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold ) or next FOLDER ; + # In --dry mode I could count the messages to be transfered instead of 0 + # Messages transferred : 0 (could be 0 without dry mode) + if ( ! create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold ) ) + { + if ( $sync->{ dry } ) + { + $nb_msg_skipped_dry_mode += $h1_msgs_nb ; + } + next FOLDER ; + } } - acls_sync( $h1_fold, $h2_fold ) ; + acls_sync( $sync, $h1_fold, $h2_fold ) ; # Sometimes the folder on host2 is listed (it exists) but is # not selectable but becomes selectable by a create (Gmail) @@ -2138,13 +2353,18 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } - my $h1_msgs_all_hash_ref = { } ; - my @h1_msgs = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref, $sync->{ search1 }, $sync->{abletosearch1}, $h1_fold ); + + if ( ! defined $h1_msgs_nb ) + { + $h1_msgs_all_hash_ref = { } ; + @h1_msgs = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref, $sync->{ search1 }, $sync->{abletosearch1}, $h1_fold ); + $h1_msgs_nb = scalar @h1_msgs ; + }else{ + # select_msgs already done. + } if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } - my $h1_msgs_nb = scalar @h1_msgs ; - myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages\n" ) ; ( $sync->{ debug } or $debuglist ) and myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages, LIST gives: @h1_msgs\n" ) ; $sync->{ debug } and myprint( "Host1: selecting messages of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ; @@ -2188,7 +2408,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) @h2_msgs{ @h2_msgs } = ( ) ; my @h1_msgs_in_cache = sort { $a <=> $b } keys %{ $cache_1_2_ref } ; - my @h2_msgs_in_cache = keys %{ $cache_2_1_ref } ; + my @h2_msgs_in_cache = sort { $a <=> $b } keys %{ $cache_2_1_ref } ; my ( %h1_msgs_not_in_cache, %h2_msgs_not_in_cache ) ; %h1_msgs_not_in_cache = %h1_msgs ; @@ -2196,9 +2416,9 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) delete @h1_msgs_not_in_cache{ @h1_msgs_in_cache } ; delete @h2_msgs_not_in_cache{ @h2_msgs_in_cache } ; - my @h1_msgs_not_in_cache = keys %h1_msgs_not_in_cache ; + my @h1_msgs_not_in_cache = sort { $a <=> $b } keys %h1_msgs_not_in_cache ; #myprint( "h1_msgs_not_in_cache: [@h1_msgs_not_in_cache]\n" ) ; - my @h2_msgs_not_in_cache = keys %h2_msgs_not_in_cache ; + my @h2_msgs_not_in_cache = sort { $a <=> $b } keys %h2_msgs_not_in_cache ; my @h2_msgs_delete2_not_in_cache = () ; %h1_msgs_copy_by_uid = ( ) ; @@ -2233,8 +2453,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) } else { - my $uidnext = $sync->{imap1}->uidnext( $h1_fold ) || $uidnext_default ; - my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; + my $fetch_hash_uids = $fetch_hash_set || "1:*" ; $h1_fir_ref = $sync->{imap1}->fetch_hash( $fetch_hash_uids, @h1_common_fetch_param, $h1_fir_ref ) if ( @h1_msgs ) ; } @@ -2260,22 +2479,30 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) $sync->{ nb_msg_skipped } += 1 ; $sync->{ h1_nb_msg_noheader } +=1 ; $sync->{ h1_nb_msg_processed } +=1 ; - } elsif(0 == $rc) + } elsif( 0 == $rc ) { # duplicate push @h1_msgs_duplicate, $m; # duplicate, same id same size? my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0; - $sync->{ nb_msg_skipped } += 1; - $h1_nb_msg_duplicate += 1; - $sync->{ h1_nb_msg_processed } +=1 ; + + $sync->{ acc1 }->{ nb_msg_duplicate } += 1; + if ( ! $sync->{ syncduplicates } ) { + $sync->{ nb_msg_skipped } += 1 ; + $sync->{ h1_nb_msg_processed } +=1 ; + } } } + + my $h1_msgs_duplicate_nb = scalar @h1_msgs_duplicate ; myprint( "Host1: folder [$h1_fold] selected $h1_msgs_nb messages, duplicates $h1_msgs_duplicate_nb\n" ) ; $sync->{ debug } and myprint( 'Host1: whole time parsing headers took ', timenext( $sync ), " s\n" ) ; + + + # Getting headers and metada can be so long that host2 might be disconnected here if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } @@ -2296,8 +2523,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) if ( $sync->{abletosearch2} and scalar( @h2_msgs ) ) { $h2_fir_ref = $sync->{imap2}->fetch_hash( \@h2_msgs, @h2_common_fetch_param, $h2_fir_ref) ; }else{ - my $uidnext = $sync->{imap2}->uidnext( $h2_fold ) || $uidnext_default ; - my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; + my $fetch_hash_uids = $fetch_hash_set || "1:*" ; $h2_fir_ref = $sync->{imap2}->fetch_hash( $fetch_hash_uids, @h2_common_fetch_param, $h2_fir_ref ) if ( @h2_msgs ) ; } @@ -2313,7 +2539,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) $h2_nb_msg_noheader += 1 ; } elsif( 0 == $rc ) { # duplicate - $h2_nb_msg_duplicate += 1 ; + $sync->{ acc2 }->{ nb_msg_duplicate } += 1 ; push @h2_msgs_duplicate, $m ; } } @@ -2353,9 +2579,9 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) foreach my $h2_msg ( @h2_msgs_duplicate ) { myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2 $sync->{dry_message}\n" ) ; push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ; - if ( ! $sync->{dry} ) { - $sync->{imap2}->delete_message( $h2_msg ) ; - $h2_nb_msg_deleted += 1 ; + if ( ! $sync->{ dry } ) { + $sync->{ imap2 }->delete_message( $h2_msg ) ; + $sync->{ acc2 }->{ nb_msg_deleted } += 1 ; } } my $cnt = scalar @h2_expunge ; @@ -2381,9 +2607,9 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted on host2 [$m_id] $sync->{dry_message}\n" ) if ! $isdel; push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 }; - if ( ! ( $sync->{dry} or $isdel ) ) { - $sync->{imap2}->delete_message($h2_msg); - $h2_nb_msg_deleted += 1; + if ( ! ( $sync->{ dry } or $isdel ) ) { + $sync->{ imap2 }->delete_message( $h2_msg ); + $sync->{ acc2 }->{ nb_msg_deleted } += 1; } } } @@ -2391,8 +2617,8 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2 $sync->{dry_message}\n" ) ; push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 }; if ( ! $sync->{dry} ) { - $sync->{imap2}->delete_message($h2_msg); - $h2_nb_msg_deleted += 1; + $sync->{ imap2 }->delete_message( $h2_msg ); + $sync->{ acc2 }->{ nb_msg_deleted } += 1; } } my $cnt = scalar @h2_expunge ; @@ -2445,9 +2671,9 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) }else{ myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted $sync->{dry_message}\n" ) ; push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ; - if ( ! $sync->{dry} ) { - $sync->{imap2}->delete_message( $h2_msg ) ; - $h2_nb_msg_deleted += 1 ; + if ( ! $sync->{ dry} ) { + $sync->{ imap2 }->delete_message( $h2_msg ) ; + $sync->{ acc2 }->{ nb_msg_deleted } += 1 ; } } } @@ -2475,6 +2701,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) my @h1_msgs_to_delete ; MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) { + abortifneeded( $sync ) ; if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } #myprint( "h1_nb_msg_processed: $sync->{ h1_nb_msg_processed }\n" ) ; @@ -2510,7 +2737,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) } if ( total_bytes_max_reached( $sync ) ) { - # a bug when using --delete1 --noexpungeaftereach + # Still a bug when using --delete1 --noexpungeaftereach # same thing below on all total_bytes_max_reached! last FOLDER ; } @@ -2558,7 +2785,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) } } - if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } if ( $sync->{ delete1 } ) { push @h1_msgs_to_delete, $h1_msg ; @@ -2566,6 +2793,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) } # END MESS: loop + # @h1_msgs_in_cache are already synced too. delete_message_on_host1( $sync, $h1_fold, $sync->{ expunge1 }, @h1_msgs_to_delete, @h1_msgs_in_cache ) ; if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } @@ -2595,6 +2823,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) # MESS_BY_UID: foreach my $h1_msg ( sort { $a <=> $b } keys %h1_msgs_copy_by_uid ) { + abortifneeded( $sync ) ; $sync->{ debug } and myprint( "Copy by uid $h1_fold/$h1_msg\n" ) ; if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } @@ -2638,18 +2867,30 @@ END_SIZE foldersizesatend( $sync ) ; } +#$sync->{imap1}->State( 0 ); # Unconnected if ( ! lost_connection( $sync, $sync->{imap1}, "for host1 [$sync->{host1}]" ) ) { $sync->{imap1}->logout( ) ; } if ( ! lost_connection( $sync, $sync->{imap2}, "for host2 [$sync->{host2}]" ) ) { $sync->{imap2}->logout( ) ; } -stats( $sync ) ; -myprint( errorsdump( $sync->{nb_errors}, errors_log( $sync ) ) ) if ( $sync->{errorsdump} ) ; -tests_live_result( $sync->{nb_errors} ) if ( $sync->{testslive} or $sync->{testslive6} ) ; +do_and_print_stats( $sync ) ; + + +if ( $sync->{errorsdump} and $sync->{nb_errors} ) +{ + myprint( errors_listing( $sync ) ) ; +} + + +if ( $sync->{testslive} or $sync->{testslive6} ) +{ + tests_live_result( $sync->{nb_errors} ) ; +} if ( $sync->{nb_errors} ) { - exit_clean( $sync, $EXIT_WITH_ERRORS ) ; + my $exit_value = $EXIT_VALUE_OF_ERR_TYPE{ $sync->{most_common_error} } || $EXIT_CATCH_ALL ; + exit_clean( $sync, $exit_value ) ; } else { @@ -2768,9 +3009,56 @@ sub output_reset_with return $mysync->{ output } ; } -sub pidfile + +sub tests_print_output_if_needed { - my $mysync = shift ; + note( 'Entering tests_print_output_if_needed()' ) ; + + is( undef, print_output_if_needed( ), 'print_output_if_needed: no args => undef' ) ; + my $mysync = { } ; + is( q{}, print_output_if_needed( $mysync ), 'print_output_if_needed: undef => undef' ) ; + + output( $mysync, "Hello\n" ) ; + is( "Hello\n", print_output_if_needed( $mysync ), 'print_output_if_needed: Hello => Hello' ) ; + + $mysync->{ dockercontext } = 1 ; + is( "Hello\n", print_output_if_needed( $mysync ), 'print_output_if_needed: dockercontext + Hello => Hello' ) ; + + $mysync->{ version } = 1 ; + is( q{}, print_output_if_needed( $mysync ), 'print_output_if_needed: dockercontext + Hello + --version => ""' ) ; + + $mysync->{ dockercontext } = 0 ; + is( "Hello\n", print_output_if_needed( $mysync ), 'print_output_if_needed: Hello + --version => Hello' ) ; + + note( 'Leaving tests_print_output_if_needed()' ) ; + return ; +} + + +sub print_output_if_needed +{ + + my $mysync = shift @ARG ; + if ( ! defined $mysync ) { return ; } + my $output = output( $mysync ) ; + + if ( $mysync->{ version } && under_docker_context( $mysync ) ) + { + return q{} ; + } + else + { + myprint( $output ) ; + return $output ; + } + +} + + + +sub define_pidfile +{ + my $mysync = shift @ARG ; $mysync->{ pidfilelocking } = defined $mysync->{ pidfilelocking } ? $mysync->{ pidfilelocking } : 0 ; @@ -2795,9 +3083,26 @@ sub pidfile } $mysync->{ pidfile } = defined $mysync->{ pidfile } ? $mysync-> { pidfile } : $mysync->{ tmpdir } . "/$pidfile_basename" ; + $mysync->{ abortfile } = abortfile( $mysync, $PROCESS_ID ) ; return ; } +sub abortfile +{ + my $mysync = shift @ARG ; + my $pid = shift @ARG ; + + my $abortfile ; + if ( $mysync->{ abort } ) + { + $abortfile = $mysync->{ pidfile } . "abort$pid" ; + } + else + { + $abortfile = $mysync->{ pidfile } . "abort$PROCESS_ID" ; + } + return $abortfile ; +} sub tests_kill_zero { @@ -2975,7 +3280,7 @@ sub killpid my $pidtokill = shift ; if ( ! $pidtokill ) { - myprint( "No process to abort.\n" ) ; + myprint( "No process to kill.\n" ) ; return ; } @@ -2989,7 +3294,7 @@ sub killpid if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) { myprint( "Sending signal QUIT to PID $pidtokill \n" ) ; kill 'QUIT', $pidtokill ; - sleep 2 ; + sleep 3 ; waitpid( $pidtokill, WNOHANG) ; }else{ myprint( "Can not send signal kill ZERO to PID $pidtokill.\n" ) ; @@ -3023,7 +3328,7 @@ sub killpid sub tests_abort { note( 'Entering tests_abort()' ) ; - + # Well, the abort behavior is tested by test.sh is( undef, abort( ), 'abort: no args => undef' ) ; note( 'Leaving tests_abort()' ) ; return ; @@ -3036,31 +3341,87 @@ sub abort { my $mysync = shift @ARG ; + myprint( "In abort\n" ) ; if ( not $mysync ) { return ; } if ( ! -r $mysync->{pidfile} ) { - myprint( "Can not read pidfile $mysync->{pidfile}. Exiting.\n" ) ; - exit $EX_OK ; + myprint( "In abort: Can not read pidfile $mysync->{pidfile}\n" ) ; + return ; } my $pidtokill = firstline( $mysync->{pidfile} ) ; if ( ! $pidtokill ) { - myprint( "No process to abort. Exiting.\n" ) ; - exit $EX_OK ; + myprint( "In abort: No process to abort in $mysync->{pidfile}\n" ) ; + return ; } - killpid( $pidtokill ) ; + if ( ! match_a_pid_number( $pidtokill ) ) + { + myprint( "In abort: pid $pidtokill in $mysync->{pidfile} is not a pid number\n" ) ; + return ; + } - # well, the abort job is done anyway, because even when not succeeded - # in aborting another run, this run has to end without doing any - # thing else - exit $EX_OK ; + if ( $mysync->{abortbyfile} ) + { + abortbyfile( $mysync, $pidtokill ) ; + } + else + { + killpid( $pidtokill ) ; + } + return ; +} + +sub abortbyfile +{ + my $mysync = shift @ARG ; + my $pidtokill = shift @ARG ; + + my $abortfile = abortfile( $mysync, $pidtokill ) ; + myprint( "touching $abortfile\n" ) ; + touch( $abortfile ) ; + return ; +} + + +sub tests_under_docker_context +{ + note( 'Entering tests_under_docker_context()' ) ; + + is( undef, under_docker_context( ), 'under_docker_context: no args => undef' ) ; + + my $mysync = { } ; + $mysync->{ dockercontext } = 1 ; + is( 1, under_docker_context( $mysync ), 'under_docker_context: --dockercontext => 1' ) ; + $mysync->{ dockercontext } = 0 ; + is( 0, under_docker_context( $mysync ), 'under_docker_context: --nodockercontext => 0' ) ; + + $mysync = { } ; + # Is not it a stupid test? + if ( under_docker_context( $mysync ) ) + { + is( 1, under_docker_context( $mysync ), 'under_docker_context: docker context => 1' ) ; + } + else + { + is( 0, under_docker_context( $mysync ), 'under_docker_context: not docker context => 0' ) ; + } + + note( 'Leaving tests_under_docker_context()' ) ; + return ; } sub under_docker_context { my $mysync = shift ; + + if ( ! defined $mysync ) { return ; } + + if ( defined $mysync->{ dockercontext } ) + { + return( $mysync->{ dockercontext } ) ; + } if ( -e '/.dockerenv' ) { @@ -3075,27 +3436,35 @@ sub under_docker_context } -sub docker_context +sub docker_context { - my $mysync = shift ; - - #-e '/.dockerenv' || return ; + my $mysync = shift ; if ( ! under_docker_context( $mysync ) ) { return ; } - $mysync->{ debug } and myprint( "Docker context detected with /.dockerenv\n" ) ; - # No pidfile - $mysync->{pidfile} = q{} ; - # No log - $mysync->{log} = 0 ; - # In case - $mysync->{ debug } and myprint( "Changing current directory to /var/tmp/\n" ) ; - chdir '/var/tmp/' ; + output( $mysync, "Docker context detected with the file /.dockerenv\n" ) ; + # No pidfile by default + + $mysync->{ pidfile } = defined( $mysync->{ pidfile } ) ? $mysync->{ pidfile } : q{} ; + # No log by default + if ( defined( $mysync->{ log } ) ) + { + output( $mysync, "Logging in Docker context. Be sure you added access to it with a mount or similar. See https://docs.docker.com/storage/volumes/\n" ) ; + } + else + { + output( $mysync, "No log by default in Docker context. Use --log to trigger logging to the logfile.\n" ) ; + $mysync->{ log } = 0 ; + } - return ; + # In case something is written relatively to . + output( $mysync, "Changing current directory to /var/tmp/\n" ) ; + chdir '/var/tmp/' ; + + return ; } sub cgibegin @@ -3151,7 +3520,7 @@ sub under_cgi_context return ; } -sub cgibuildheader +sub cgibuildheader { my $mysync = shift ; if ( ! under_cgi_context( $mysync ) ) { return ; } @@ -3166,7 +3535,7 @@ sub cgibuildheader my $httpheader ; if ( $mysync->{ abort } ) { $httpheader = $mysync->{cgi}->header( - -type => 'text/plain', + -type => 'text/plain; charset=UTF-8', -status => '200 OK to abort syncing IMAP boxes' . ". Here is " . hostname(), ) ; }elsif( $mysync->{ loaddelay } ) { @@ -3174,7 +3543,7 @@ sub cgibuildheader # 503 Service Unavailable # The server is currently unable to handle the request due to a temporary overloading or maintenance of the server. $httpheader = $mysync->{cgi}->header( - -type => 'text/plain', + -type => 'text/plain; charset=UTF-8', -status => '503 Service Unavailable' . ". Be back in $mysync->{ loaddelay } min. Load on " . hostname() . " is $mysync->{ loadavg }", ) ; }else{ @@ -3306,40 +3675,56 @@ sub tests_umask return ; } -sub cgisetcontext +sub buggyflagsregex { - my $mysync = shift ; - if ( ! under_cgi_context( $mysync ) ) { return ; } + # From /X analyse + # cut -d: -f1 Error_112_all_syncs.txt | xargs egrep -oih 'Invalid system flag [^( ]+' | sort | uniq -c | sort -g + my @buggyflagsregex = ( 's/\\\\RECEIPTCHECKED|\\\\Indexed|\\\\X-EON-HAS-ATTACHMENT|\\\\UNSEEN|\\\\ATTACHED|\\\\X-HAS-ATTACH|\\\\FORWARDED|\\\\FORWARD|\\\\X-FORWARDED|\\\\\$FORWARDED|\\\\PRIORITY|\\\\READRCPT//g' ) ; + return( @buggyflagsregex ) ; +} - output( $mysync, "Under cgi context\n" ) ; - set_umask( $mysync ) ; +sub cgisetcontext +{ + my $mysync = shift ; + if ( ! under_cgi_context( $mysync ) ) { return ; } + + output( $mysync, "Under cgi context\n" ) ; + + + set_umask( $mysync ) ; # Remove all content in unsafe evaled options @{ $mysync->{ regextrans2 } } = ( ) ; - @regexflag = ( ) ; + + @{ $mysync->{ regexflag } } = buggyflagsregex( ) ; + @regexmess = ( ) ; @skipmess = ( ) ; @pipemess = ( ) ; $delete2foldersonly = undef ; $delete2foldersbutnot = undef ; - $maxlinelengthcmd = undef ; + $maxlinelengthcmd = undef ; - # Set safe default values (I hope...) + # Set safe default values (I hope...) #$mysync->{pidfile} = 'imapsync.pid' ; - $mysync->{pidfilelocking} = 1 ; - $mysync->{errorsmax} = $ERRORS_MAX_CGI ; - $modulesversion = 0 ; - $mysync->{releasecheck} = defined $mysync->{releasecheck} ? $mysync->{releasecheck} : 1 ; - $usecache = 0 ; - $mysync->{showpasswords} = 0 ; - $debugimap1 = $debugimap2 = $debugimap = 0 ; - $reconnectretry1 = $reconnectretry2 = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; - $pipemesscheck = 0 ; + $mysync->{ pidfilelocking } = 1 ; + $mysync->{ errorsmax } = $ERRORS_MAX_CGI ; + $modulesversion = 0 ; + $mysync->{ releasecheck } = defined $mysync->{ releasecheck } ? $mysync->{ releasecheck } : 1 ; + $usecache = 0 ; + $mysync->{ showpasswords } = 0 ; + $mysync->{ acc1 }->{ debugimap } = 0 ; + $mysync->{ acc2 }->{ debugimap } = 0 ; - $mysync->{hashfile} = $CGI_HASHFILE ; - my $hashsynclocal = hashsynclocal( $mysync ) || die "Can not get hashsynclocal. Exiting\n" ; + $mysync->{ acc1 }->{ reconnectretry } = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; + $mysync->{ acc2 }->{ reconnectretry } = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; + + $pipemesscheck = 0 ; + + $mysync->{ hashfile } = $CGI_HASHFILE ; + my $hashsynclocal = hashsynclocal( $mysync ) || die "Can not get hashsynclocal. Exiting\n" ; if ( $ENV{ 'NET_SERVER_SOFTWARE' } and ( $ENV{ 'NET_SERVER_SOFTWARE' } =~ /Net::Server::HTTP/ ) ) { @@ -3352,7 +3737,8 @@ sub cgisetcontext } -d $cgidir or mkpath $cgidir or die "Can not create $cgidir: $OS_ERROR\n" ; $mysync->{ tmpdir } = $cgidir ; - + $mysync->{ logdir } = '' ; + chdir $cgidir or die "Can not cd to $cgidir: $OS_ERROR\n" ; cgioutputenvcontext( $mysync ) ; $mysync->{ debug } and output( $mysync, 'Current directory is ' . getcwd( ) . "\n" ) ; @@ -3368,11 +3754,16 @@ sub cgisetcontext $mysync->{ tail } = defined $mysync->{ tail } ? $mysync->{ tail } : 1 ; # not sure it's for good - @useheader = qw( Message-Id ) ; + @useheader = qw( Message-Id Received ) ; # addheader on by default $mysync->{ addheader } = defined $mysync->{ addheader } ? $mysync->{ addheader } : 1 ; + + # sync duplicates by default in cgi context + $mysync->{ syncduplicates } = defined $mysync->{ syncduplicates } ? $mysync->{ syncduplicates } : 1 ; + # log the logfile name by default in cgi context + $mysync->{ loglogfile } = defined $mysync->{ loglogfile } ? $mysync->{ loglogfile } : 1 ; return ; } @@ -3389,6 +3780,100 @@ sub cgioutputenvcontext return ; } +sub announcelogfile +{ + my $mysync = shift ; + + if ( $mysync->{ log } ) + { + myprint( "Log file is $mysync->{ logfile } ( to change it, use --logfile path ; or use --nolog to turn off logging )\n" ) ; + loglogfile( $mysync ) ; + } + else + { + myprint( "No log file because of option --nolog\n" ) ; + } + return ; +} + + +sub loglogfile +{ + my $mysync = shift ; + if ( ! $mysync->{ loglogfile } ) { return ; } + if ( ! $mysync->{ log } ) { return ; } + + my $cwd = getcwd( ) ; + my $absolutelogfilepath ; + # Fixme: add case when the logfile name is already absolute + $absolutelogfilepath = "$cwd/$mysync->{ logfile }" ; + my $loglogfilename = '../list_all_logs_auto.txt' ; + myprint( "Writing log file name $absolutelogfilepath to $loglogfilename\n" ) ; + if ( open( my $fh, '>>', $loglogfilename ) ) + { + print $fh "$absolutelogfilepath\n" ; + close $fh ; + } + else + { + myprint( "Could not open loglogfile $loglogfilename $!\n" ) ; + } + return ; +} + + +sub checkselectable +{ + my $mysync = shift ; + + if ( $mysync->{ checkselectable } ) { + my @h1_folders_wanted_selectable ; + myprint( "Host1: Checking wanted folders are selectable. Use --nocheckselectable to avoid this check.\n" ) ; + foreach my $folder ( @{ $mysync->{ h1_folders_wanted } } ) + { + ( $mysync->{ debug } or $mysync->{ debugfolders } ) and myprint( "Checking $folder is selectable on host1\n" ) ; + # It does an imap command LIST "" $folder and then search for no \Noselect + if ( ! $mysync->{ imap1 }->selectable( $folder ) ) + { + myprint( "Host1: warning! ignoring folder $folder because it is not selectable\n" ) ; + }else + { + push @h1_folders_wanted_selectable, $folder ; + } + } + @{ $mysync->{ h1_folders_wanted } } = @h1_folders_wanted_selectable ; + ( $mysync->{ debug } or $mysync->{ debugfolders } ) + and myprint( 'Host1: checking folders took ', timenext( $mysync ), " s\n" ) ; + } + else + { + myprint( "Host1: Not checking that wanted folders are selectable. Use --checkselectable to force this check.\n" ) ; + } + return ; +} + +sub setcheckselectable +{ + my $mysync = shift ; + + my $h1_folders_wanted_nb = scalar @{ $mysync->{ h1_folders_wanted } } ; + # 152 because 98% of host1 accounts have less than 152 folders on /X service. + # command to get this value: + # datamash_file_op_index G_Host1_Nb_folders.txt perc:98 4 %16.1f + if ( ! defined $mysync->{ checkselectable } ) + { + if ( 152 >= $h1_folders_wanted_nb ) + { + $mysync->{ checkselectable } = 1 ; + }else{ + myprint( "Host1: Not checking that $h1_folders_wanted_nb wanted folders are selectable. Use --checkselectable to force this check.\n" ) ; + $mysync->{ checkselectable } = 0 ; + } + } + return ; +} + + sub debugsleep { @@ -3416,7 +3901,6 @@ sub tests_foldersize # Globals: -# $uidnext_default # $fetch_hash_set # sub foldersize @@ -3450,6 +3934,7 @@ sub foldersize my $biggest_in_folder = 0 ; @{ $hash_ref }{ @msgs } = ( undef ) if @msgs ; + my $stot = 0 ; if ( $imap->IsUnconnected( ) ) @@ -3467,8 +3952,7 @@ sub foldersize } else { - my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ; - my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; + my $fetch_hash_uids = $fetch_hash_set || "1:*" ; if ( ! $imap->fetch_hash( $fetch_hash_uids, 'RFC822.SIZE', $hash_ref ) ) { my $error = "$side failure with fetch_hash: $EVAL_ERROR\n" ; errors_incr( $mysync, $error ) ; @@ -3477,8 +3961,11 @@ sub foldersize } for ( keys %{ $hash_ref } ) { my $size = $hash_ref->{ $_ }->{ 'RFC822.SIZE' } ; - $stot += $size ; - $biggest_in_folder = max( $biggest_in_folder, $size ) ; + if ( defined $size ) + { + $stot += $size ; + $biggest_in_folder = max( $biggest_in_folder, $size ) ; + } } } return( $stot, $nb_msgs, $biggest_in_folder ) ; @@ -3717,6 +4204,66 @@ sub add return $x + $y ; } +sub tests_checknoabletosearch +{ + note( 'Entering checknoabletosearch()' ) ; + + is( undef, checknoabletosearch( ), 'checknoabletosearch: no args => undef' ) ; + + note( 'Leaving checknoabletosearch()' ) ; + return ; +} + + + + +sub checknoabletosearch +{ + # call example: checknoabletosearch( $sync, $sync->{ imap1 }, 'INBOX', 'Host1' ) ; + # output: + # * undef if something is not ok to decide + # * 1 if SEARCH ALL failed + + my( $mysync, $imap, $folder, $HostX ) = @ARG ; + + if ( ! all_defined( $mysync, $imap, $folder, $HostX ) ) + { + return ; + } + + myprint( "$HostX: checking if SEARCH ALL works on $folder\n" ) ; + if ( ! select_folder( $mysync, $imap, $folder, $HostX ) ) + { + myprint( "$HostX: can not SELECT folder [$folder]\n" ) ; + return ; + } + my $count_from_select = count_from_select( $imap->History ) ; + myprint( "$HostX: folder [$folder] has $count_from_select messages mentioned by SELECT\n" ) ; + + my $msgs_all = $imap->messages( ) ; + if ( ! $msgs_all ) + { + myprint( "$HostX: can not SEARCH ALL folder [$folder]\n" ) ; + myprint( "$HostX: ", $imap->LastError(), "\n" ) ; + return 1 ; + } + + my $count_from_search_all = scalar( @{ $msgs_all } ) ; + myprint( "$HostX: folder [$folder] has $count_from_search_all messages found by SEARCH ALL\n" ) ; + + if ( $count_from_select == $count_from_search_all ) + { + myprint( "$HostX: folder [$folder] has the same messages count ($count_from_select) by SELECT and SEARCH ALL\n" ) ; + } + else + { + myprint( "$HostX: Warning, folder [$folder] has not the same count by SELECT ($count_from_select) and SEARCH ALL ($count_from_search_all)\n" ) ; + return 1 ; + } + + return ; +} + sub foldersizes_diff_list { @@ -3864,7 +4411,7 @@ END_SIZE return ; } - my $h2_bytes_limit = $mysync->{h2}->{quota_limit_bytes} || 0 ; + my $h2_bytes_limit = $mysync->{ acc2 }->{quota_limit_bytes} || 0 ; if ( $h2_bytes_limit and ( $h2_bytes_limit < $mysync->{ h1_bytes_start } ) ) { my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $mysync->{ h1_bytes_start } / $h2_bytes_limit ) ; @@ -3906,7 +4453,7 @@ END_SIZE return ; } - my $h2_bytes_limit = $mysync->{h2}->{quota_limit_bytes} || 0 ; + my $h2_bytes_limit = $mysync->{ acc2 }->{quota_limit_bytes} || 0 ; if ( $h2_bytes_limit and ( $h2_bytes_limit < $mysync->{ h1_bytes_start } ) ) { my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $mysync->{ h1_bytes_start } / $h2_bytes_limit ) ; @@ -3917,15 +4464,51 @@ END_SIZE } +sub tests_total_bytes_max_reached +{ + note( 'Entering tests_total_bytes_max_reached()' ) ; + + is( undef, total_bytes_max_reached( ), 'total_bytes_max_reached: no args => undef' ) ; + + my $mysync = {} ; + is( undef, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: no exitwhenover => undef' ) ; + + $mysync->{ exitwhenover } = 300 ; + is( undef, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: exitwhenover 300 but no total_bytes_transferred => undef' ) ; + + $mysync->{ total_bytes_transferred } = 200 ; + is( undef, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: exitwhenover 300 but total_bytes_transferred 200 => undef' ) ; + + $mysync->{ total_bytes_transferred } = 400 ; + is( 1, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: exitwhenover 300 but total_bytes_transferred 400 => 1' ) ; + + + + note( 'Leaving tests_total_bytes_max_reached()' ) ; + return ; +} + + sub total_bytes_max_reached { my $mysync = shift ; - if ( ! $mysync->{ exitwhenover } ) { - return( 0 ) ; + if ( ! defined $mysync ) { return ; } + + if ( ! $mysync->{ exitwhenover } ) + { + return ; } - if ( $mysync->{ total_bytes_transferred } >= $mysync->{ exitwhenover } ) { - myprint( "Maximum bytes transferred reached, $mysync->{total_bytes_transferred} >= $mysync->{ exitwhenover }, ending sync\n" ) ; + + if ( ! $mysync->{ total_bytes_transferred } ) + { + return ; + } + + if ( $mysync->{ total_bytes_transferred } >= $mysync->{ exitwhenover } ) + { + my $error = "Maximum bytes transferred reached, $mysync->{total_bytes_transferred} >= $mysync->{ exitwhenover }, ending sync\n" ; + errors_incr( $mysync, $error ) ; return( 1 ) ; } return ; @@ -4166,7 +4749,7 @@ sub appendlimit_from_capability #myprint( Data::Dumper->Dump( [ \$myimap ] ) ) ; my $appendlimit = capability_of( $myimap, 'APPENDLIMIT' ) ; #myprint( "has_capability APPENDLIMIT $appendlimit\n" ) ; - if ( is_an_integer( $appendlimit ) ) + if ( is_integer( $appendlimit ) ) { return $appendlimit ; } @@ -4291,8 +4874,6 @@ sub tests_maxsize_setting # Now --truncmess stuff - - note( 'Leaving tests_maxsize_setting()' ) ; return ; @@ -4432,20 +5013,70 @@ sub hashsynclocal sub tests_hashsync { - note( 'Entering tests_hashsync()' ) ; + note( 'Entering tests_hashsync()' ) ; + + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( ), 'hashsync: no args' ) ; + + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( {}, q{} ), 'hashsync: empty args' ) ; + my $mysync ; + $mysync->{ host1 } = 'zzz' ; + is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ; + is( '6a7b451ac99eab1531ad8e6cd544b32420c552ac', hashsync( $mysync, q{A} ), 'hashsync: host1 zzz => ' ) ; + $mysync->{ host2 } = 'zzz' ; + is( '15959573e4a86763253a7aedb1a2b0c60d133dc2', hashsync( $mysync, q{} ), 'hashsync: + host2 zzz => ' ) ; + is( 'b8d4ab541b209c75928528020ca28ee43488bd8f', hashsync( $mysync, 'A' ), 'hashsync: + hashkey A => ' ) ; + + $mysync = undef ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( $mysync, q{} ), 'hashsync: undef $mysync' ) ; + $mysync->{ password1 } = 'abcd' ; + is( 'afa29ab8534495251ac8346a985717c54bc49c26', hashsync( $mysync, q{} ), 'hashsync: password1: abcd' ) ; + + # A user reported a massive failure on /X (Thomas V. 21/04/2020 à 21:41 Subject: Error) + # "Wide character in subroutine entry at /usr/local/lib/perl5/site_perl/Digest/HMAC.pm" + # I can reproduce it now - is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( {}, q{} ), 'hashsync: empty args' ) ; - my $mysync ; - $mysync->{ host1 } = 'zzz' ; - is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ; - is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ; - $mysync->{ host2 } = 'zzz' ; - is( '15959573e4a86763253a7aedb1a2b0c60d133dc2', hashsync( $mysync, q{} ), 'hashsync: + host2 zzz => ' ) ; - is( 'b8d4ab541b209c75928528020ca28ee43488bd8f', hashsync( $mysync, 'A' ), 'hashsync: + hashkey A => ' ) ; + # The eval is there to avoid a complete crash + # this one is fatal so it is commented + # is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', 1 / 0 , 'hashsync: 1 / 0 fatal' ) ; - note( 'Leaving tests_hashsync()' ) ; - return ; + my $eval ; + # this one is not fatal + is( undef, $eval = eval { 1 / 0 } , 'hashsync: 1/0 not fatal' ) ; + # this one neither + $mysync->{ password1 } = 'Ö' ; + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', $eval = eval { hashsync( $mysync, q{} ) } , 'hashsync: password1: Ö with eval' ) ; + + $mysync->{ password1 } = 'Ö' ; + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hashsync( $mysync, q{} ), 'hashsync: password1: Ö without eval' ) ; + + $mysync->{ password1 } = qq{\x{00D6}} ; + is( 'bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a', $eval = eval { hashsync( $mysync, q{} ) }, 'hashsync: password1: \x{00D6}' ) ; # + + print qq{1 00D6:Ö\n} ; + print encode_utf8( qq{2 00D6:Ö\n} ) ; + print qq{3 00D6:\x{00D6}\n} ; + print encode_utf8( qq{4 00D6:\x{00D6}\n} ) ; + + + print qq{5 6536:收\n} ; + print encode_utf8( qq{6 6536:收\n} ) ; + # the next one prints "Wide character in print at ./imapsync line xxxx" + print qq{7 6536:\x{6536}\n} ; + print encode_utf8( qq{8 6536:\x{6536}\n} ) ; + + $mysync->{ password1 } = qq{收} ; + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hashsync( $mysync, q{} ), 'hashsync: password1: 收' ) ; + + $mysync->{ password1 } = qq{\x{6536}} ; + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', $eval = eval{ hashsync( $mysync, q{} ) }, 'hashsync: password1: \x{6536} with eval' ) ; + + # No side effect. + $mysync->{ password1 } = 'abcd' ; + is( 'afa29ab8534495251ac8346a985717c54bc49c26', hashsync( $mysync, q{} ), 'hashsync: password1: abcd again' ) ; + + note( 'Leaving tests_hashsync()' ) ; + return ; } sub hashsync @@ -4461,12 +5092,119 @@ sub hashsync $mysync->{ user2 } || q{}, $mysync->{ password2 } || q{}, ) ; - my $hashsync = hmac_sha1_hex( $mystring, $hashkey ) ; + #my $hashsync = hmac_sha1_hex( $mystring, $hashkey ) ; + my $hashsync = hmac_sha1_hex_robust( $mystring, $hashkey ) ; #myprint( "$hashsync\n" ) ; return( $hashsync ) ; } +sub tests_hmac_sha1_hex +{ + note( 'Entering tests_hmac_sha1_hex()' ) ; + + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( ), 'hmac_sha1_hex: no args => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( '' ), 'hmac_sha1_hex: empty string => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( '', '' ), 'hmac_sha1_hex: empty strings => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( '', '', 'caca' ), 'hmac_sha1_hex: empty strings + caca => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + + # Good + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex( 'Ö' ), 'hmac_sha1_hex: Ö => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ; + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex( encode_utf8(qq{\x{00D6}}) ), 'hmac_sha1_hex: encode_utf8 \x{00D6} => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ; + # Bad + is( 'fe8dc3b9ba3e8850bb4a7b070b2279e911003af2', hmac_sha1_hex( encode_utf8( 'Ö' ) ), 'hmac_sha1_hex: encode_utf8 Ö => fe8dc3b9ba3e8850bb4a7b070b2279e911003af2' ) ; + is( 'bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a', hmac_sha1_hex( qq{\x{00D6}} ), 'hmac_sha1_hex: qq{\x{00D6}} => bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a' ) ; + + # Good + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( 'A' ), 'hmac_sha1_hex: A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( encode_utf8(qq{\x{0041}}) ), 'hmac_sha1_hex: encode_utf8 \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( encode_utf8( 'A' ) ), 'hmac_sha1_hex: encode_utf8 A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( qq{\x{0041}} ), 'hmac_sha1_hex: \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + + # Good + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( 'A', 'B' ), 'hmac_sha1_hex: A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( encode_utf8(qq{\x{0041}}), 'B' ), 'hmac_sha1_hex: encode_utf8 \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( encode_utf8( 'A' ), 'B' ), 'hmac_sha1_hex: encode_utf8 A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( qq{\x{0041}}, 'B' ), 'hmac_sha1_hex: \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + + # http://unicode.scarfboy.com/?s=U%2B6536 + # Good + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex( '收' ), 'hmac_sha1_hex: 收 => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex( encode_utf8(qq{\x{6536}}) ), 'hmac_sha1_hex: encode_utf8 \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + # Bad + is( 'e82217119628ad03e659cc89671d05ea4cee7238', hmac_sha1_hex( encode_utf8( '收' ) ), 'hmac_sha1_hex: encode_utf8 收 => e82217119628ad03e659cc89671d05ea4cee7238' ) ; + # Very very bad, perl dies... + #is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex( qq{\x{6536}} ), 'hmac_sha1_hex: \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + # Ok but well, bad indeed + is( undef, my $eval = eval{ hmac_sha1_hex( qq{\x{6536}} ) }, 'hmac_sha1_hex: \x{6536} => undef' ) ; + + + note( 'Leaving tests_hmac_sha1_hex()' ) ; + return ; +} + +sub tests_hmac_sha1_hex_robust +{ + note( 'Entering tests_hmac_sha1_hex_robust()' ) ; + + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( ), 'hmac_sha1_hex_robust: no args => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( '' ), 'hmac_sha1_hex_robust: empty string => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( '', '' ), 'hmac_sha1_hex_robust: empty strings => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( '', '', 'caca' ), 'hmac_sha1_hex_robust: empty strings + caca => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + + # Good + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex_robust( 'Ö' ), 'hmac_sha1_hex_robust: Ö => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ; + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex_robust( encode_utf8(qq{\x{00D6}}) ), 'hmac_sha1_hex_robust: encode_utf8 \x{00D6} => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ; + # Bad + is( 'fe8dc3b9ba3e8850bb4a7b070b2279e911003af2', hmac_sha1_hex_robust( encode_utf8( 'Ö' ) ), 'hmac_sha1_hex_robust: encode_utf8 Ö => fe8dc3b9ba3e8850bb4a7b070b2279e911003af2' ) ; + is( 'bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a', hmac_sha1_hex_robust( qq{\x{00D6}} ), 'hmac_sha1_hex_robust: qq{\x{00D6}} => bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a' ) ; + + # Good + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( 'A' ), 'hmac_sha1_hex_robust: A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( encode_utf8(qq{\x{0041}}) ), 'hmac_sha1_hex_robust: encode_utf8 \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( encode_utf8( 'A' ) ), 'hmac_sha1_hex_robust: encode_utf8 A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( qq{\x{0041}} ), 'hmac_sha1_hex_robust: \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + + # Good + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( 'A', 'B' ), 'hmac_sha1_hex_robust: A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( encode_utf8(qq{\x{0041}}), 'B' ), 'hmac_sha1_hex_robust: encode_utf8 \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( encode_utf8( 'A' ), 'B' ), 'hmac_sha1_hex_robust: encode_utf8 A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( qq{\x{0041}}, 'B' ), 'hmac_sha1_hex_robust: \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + + # http://unicode.scarfboy.com/?s=U%2B6536 + # Good + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex_robust( '收' ), 'hmac_sha1_hex_robust: 收 => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex_robust( encode_utf8(qq{\x{6536}}) ), 'hmac_sha1_hex_robust: encode_utf8 \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + # Bad + is( 'e82217119628ad03e659cc89671d05ea4cee7238', hmac_sha1_hex_robust( encode_utf8( '收' ) ), 'hmac_sha1_hex_robust: encode_utf8 收 => e82217119628ad03e659cc89671d05ea4cee7238' ) ; + # Good + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex_robust( qq{\x{6536}} ), 'hmac_sha1_hex_robust: \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + # Good again + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', my $eval = eval{ hmac_sha1_hex_robust( qq{\x{6536}} ) }, 'hmac_sha1_hex_robust: \x{6536} => undef' ) ; + + note( 'Leaving tests_hmac_sha1_hex_robust()' ) ; + return ; +} + + +sub hmac_sha1_hex_robust +{ + my $string = shift ; + my $val ; + if ( defined( $val = eval{ hmac_sha1_hex( $string, @ARG ) } ) ) + { + return $val ; + } + elsif( defined( $val = eval{ hmac_sha1_hex( encode_utf8( $string ), @ARG ) } ) ) + { + return $val ; + } + else + { + return ; + } +} + sub tests_createhashfileifneeded { note( 'Entering tests_createhashfileifneeded()' ) ; @@ -4588,7 +5326,7 @@ sub imapsync_id vendor => 'Gilles LAMIRAL', 'support-url' => 'https://imapsync.lamiral.info/', # Example of date-time: 19-Sep-2015 08:56:07 - date => date_from_rcs( q{$Date: 2019/12/23 20:18:02 $ } ), + date => date_from_rcs( q{$Date: 2021/07/22 14:21:09 $ } ), } ; my $imapsync_id_github = { @@ -4597,7 +5335,7 @@ sub imapsync_id os => $OSNAME, vendor => 'github', 'support-url' => 'https://github.com/imapsync/imapsync', - date => date_from_rcs( q{$Date: 2019/12/23 20:18:02 $ } ), + date => date_from_rcs( q{$Date: 2021/07/22 14:21:09 $ } ), } ; $imapsync_id = $imapsync_id_lamiral ; @@ -5003,12 +5741,16 @@ sub errors_incr $mysync->{errorsmax} ||= $ERRORS_MAX ; if ( $mysync->{nb_errors} >= $mysync->{errorsmax} ) { myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to any value, for example 100 with --errorsmax 100 ). Exiting.\n" ) ; + my $most_common_error = errorsanalyse( errors_log( $mysync ) ) ; if ( $mysync->{errorsdump} ) { - myprint( errorsdump( $mysync->{nb_errors}, errors_log( $mysync ) ) ) ; + myprint( errorsdump( errors_log( $mysync ) ) ) ; + myprint( "The most frequent error is $most_common_error\n" ) ; # again since errorsdump( ) can be very verbose and masquerade previous warning myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to any value, for example 100 with --errorsmax 100 ). Exiting.\n" ) ; } - exit_clean( $mysync, $EXIT_WITH_ERRORS_MAX ) ; + my $exit_value = $EXIT_VALUE_OF_ERR_TYPE{ $most_common_error } || $EXIT_CATCH_ALL ; + #exit_clean( $mysync, $EXIT_WITH_ERRORS_MAX ) ; + exit_clean( $mysync, $exit_value ) ; } return ; } @@ -5048,14 +5790,288 @@ sub errors_log } +sub tests_error_type +{ + note( 'Entering tests_error_type()' ) ; + + is( 'ERR_NOTHING_REPORTED', error_type( ), 'error_type: no args => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', error_type( '' ), 'error_type: empty string => ERR_NOTHING_REPORTED' ) ; + + is( 'ERR_UNCLASSIFIED', error_type( 'ERR_UNCLASSIFIED' ), 'error_type: ERR_UNCLASSIFIED => ERR_UNCLASSIFIED' ) ; + is( 'ERR_UNCLASSIFIED', error_type( 'aie' ), 'error_type: aie => ERR_UNCLASSIFIED' ) ; + is( 'ERR_UNCLASSIFIED', error_type( 'ouille' ), 'error_type: ouille => ERR_UNCLASSIFIED' ) ; + + is( 'ERR_Host1_FETCH', error_type( 'Message xxx could not be fetched: blabla' ), + 'error_type: could not be fetched => ERR_Host1_FETCH' + ) ; + + is( 'ERR_APPEND_SIZE', + error_type( 'could not append message xxx: BAD maximum message size exceeded' ), + 'error_type: could not append message xxx: BAD maximum message size exceeded => ERR_APPEND_SIZE' + ) ; + + is( 'ERR_OVERQUOTA', + error_type( 'Quota limit will be exceeded' ), + 'error_type: Quota limit will be exceeded => ERR_OVERQUOTA' + ) ; + + is( 'ERR_APPEND', error_type( 'could not append' ), 'error_type: could not append => ERR_APPEND' ) ; + + is( 'ERR_CREATE', + error_type( 'Could not create folder' ), + 'error_type: Could not create folder => ERR_CREATE' + ) ; + + is( 'ERR_SELECT', + error_type( 'Could not select: blabla' ), + 'error_type: Could not select: blabla => ERR_SELECT' + ) ; + + + # + #Maximum bytes transferred reached, 423 >= 100, ending sync + is( 'ERR_TRANSFER_EXCEEDED', + error_type( 'Maximum bytes transferred reached, blabla' ), + 'error_type: Maximum bytes transferred reached, blabla => ERR_TRANSFER_EXCEEDED' + ) ; + + # + is( 'ERR_CONNECTION_FAILURE_HOST1', + error_type( 'Host1 failure: can not open imap connection on host1 [badhostkaka] with user [tata]: Unable to connect to badhostkaka: Invalid argument' ), + 'error_type: can not open imap connection on host1 => ERR_CONNECTION_FAILURE_HOST1' + ) ; + + is( 'ERR_CONNECTION_FAILURE_HOST2', + error_type( 'Host2 failure: can not open imap connection on host2 [badhostkiki] with user [titi]: Unable to connect to badhostkiki: Invalid argument' ), + 'error_type: can not open imap connection on host2 => ERR_CONNECTION_FAILURE_HOST2' + ) ; + + is( 'ERR_APPEND_VIRUS', + error_type( 'could not append ( Subject:[For Your Consideration], Date:["29-Nov-2016 03:21:10 -0800"], Size:[5505], Flags:[\Seen] ) to folder INBOX: 275 NO Message refused because it contains a virus' ), + 'error_type: could not append ... virus => ERR_APPEND_VIRUS' + ) ; + + note( 'Leaving tests_error_type()' ) ; + return ; +} + + + +# Could be implemented with https://metacpan.org/pod/Tie::RegexpHash +# with just a hash of error regexes as keys and types as values. + +sub error_type +{ + my $error = shift ; + + if ( ! defined $error ) { return 'ERR_NOTHING_REPORTED' ; } + if ( ! $error ) { return 'ERR_NOTHING_REPORTED' ; } + + # + if ( $error =~ m{Host1 failure: Error login on} ) { return 'ERR_AUTHENTICATION_FAILURE_USER1' } ; + if ( $error =~ m{Host2 failure: Error login on} ) { return 'ERR_AUTHENTICATION_FAILURE_USER2' } ; + + if ( $error =~ m{Host. failure: Can not go to tls encryption on host.} ) { return 'ERR_EXIT_TLS_FAILURE' } ; + # + + if ( $error =~ m{could not be fetched:} ) { return 'ERR_Host1_FETCH' } ; + + # could not append .*BAD maximum message size exceeded + # could not append.*Maximum size of appendable message has been exceeded + if ( $error =~ m{could not append .*BAD maximum message size exceeded} ) + { return 'ERR_APPEND_SIZE' ; } ; + + if ( $error =~ m{could not append.*Maximum size of appendable message has been exceeded} ) + { return 'ERR_APPEND_SIZE' ; } ; + + # Could not create folder *[OVERQUOTA] Not enough disk quota + # could not append .*[OVERQUOTA] Not enough disk quota + # could not append .*[OVERQUOTA] Mailbox is full / Blocks limit exceeded / Inode limit exceeded + if ( $error =~ m{OVERQUOTA} ) { return 'ERR_OVERQUOTA' ; } ; + if ( $error =~ m{Quota limit will be exceeded} ) { return 'ERR_OVERQUOTA' ; } ; + if ( $error =~ m{full: it is time to find a bigger place} ) { return 'ERR_OVERQUOTA' ; } ; + + # could not append ... to folder INBOX: 276 NO Message refused because it contains a virus + if ( $error =~ m{could not append.*virus} ) + { return 'ERR_APPEND_VIRUS' ; } ; + + # could not append .*Write failed 'Broken pipe' + # could not append .*timeout waiting .* for data from server + # could not append .*BAD Invalid Arguments: Unable to parse message + # could not append .*BAD Command Argument Error. 11 + # could not append .*NO header limit reached + if ( $error =~ m{could not append} ) { return 'ERR_APPEND' ; } ; + + # Could not create folder .*Invalid mailbox name + if ( $error =~ m{Could not create folder} ) { return 'ERR_CREATE' ; } ; + + + # Could not select:.*NO [NOPERM] Permission denied + # Could not select:.*NO Mailbox doesn't exist + # Could not select:.*NO [SERVERBUG] Internal error occurred. + # Could not select:.*[CANNOT] Mailbox isn't a valid mbox file + if ( $error =~ m{Could not select:} ) { return 'ERR_SELECT' ; } ; + + #Maximum bytes transferred reached, 423 >= 100, ending sync + if ( $error =~ m{Maximum bytes transferred reached} ) { return 'ERR_TRANSFER_EXCEEDED' ; } ; + + if ( $error =~ m{can not open imap connection on host1} ) { return 'ERR_CONNECTION_FAILURE_HOST1' ; } ; + if ( $error =~ m{can not open imap connection on host2} ) { return 'ERR_CONNECTION_FAILURE_HOST2' ; } ; + + # Default is ERR_UNCLASSIFIED + return 'ERR_UNCLASSIFIED' ; + +} + +sub tests_errorclassify +{ + note( 'Entering tests_errorclassify()' ) ; + + is( undef, errorclassify( ), 'errorclassify: no args => undef' ) ; + + is_deeply( { 'ERR_UNCLASSIFIED' => 1 }, errorclassify( 'aie' ), 'errorclassify: aie => { ERR_UNCLASSIFIED => 1 }' ) ; + is_deeply( { 'ERR_UNCLASSIFIED' => 2 }, errorclassify( 'aie', 'ouille' ), 'errorclassify: aie ouille => { ERR_UNCLASSIFIED => 2 }' ) ; + is_deeply( { 'ERR_UNCLASSIFIED' => 2, 'ERR_NOTHING_REPORTED' => 1 }, errorclassify( 'aie', 'ouille', '' ), 'errorclassify: aie ouille "" => { ERR_UNCLASSIFIED => 2 }' ) ; + is_deeply( { 'ERR_UNCLASSIFIED' => 3 }, errorclassify( 'aie', 'ouille', 'aie' ), 'errorclassify: aie ouille aie => { ERR_UNCLASSIFIED => 3 }' ) ; + is_deeply( { 'ERR_UNCLASSIFIED' => 1, 'ERR_OVERQUOTA' => 2 }, errorclassify( 'aie', 'OVERQUOTA pipi', 'OVERQUOTA caca' ), 'errorclassify: aie OVERQUOTA OVERQUOTA' ) ; + is_deeply( { 'ERR_NOTHING_REPORTED' => 1 }, errorclassify( '' ), 'errorclassify: "" => { ERR_NOTHING_REPORTED => 1 }' ) ; + is_deeply( { 'ERR_NOTHING_REPORTED' => 2 }, errorclassify( '', '' ), 'errorclassify: "", "" => { ERR_NOTHING_REPORTED => 1 }' ) ; + + note( 'Leaving tests_errorclassify()' ) ; + return ; +} + + + +sub errorclassify +{ + my @errors = @ARG ; + + if ( ! @errors ) { return ; } ; + + my $error_type_count = { } ; + foreach my $error ( @errors ) + { + my $error_type = error_type( $error ) ; + $error_type_count->{ $error_type }++ ; + } + + return $error_type_count ; +} + +sub tests_most_common_error +{ + note( 'Entering tests_most_common_error()' ) ; + + is( 'ERR_NOTHING_REPORTED', most_common_error( ), 'most_common_error: no args => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', most_common_error( {} ), 'most_common_error: empty hash ref => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', most_common_error( 'blabla' ), 'most_common_error: not a hash ref => ERR_NOTHING_REPORTED' ) ; + + is( 'ERR_FOO', most_common_error( { ERR_FOO => 1 } ), 'most_common_error: { ERR_FOO => 1 } => ERR_FOO' ) ; + is( 'ERR_BAR', most_common_error( { ERR_FOO => 1, ERR_BAR => 2 } ), 'most_common_error: { ERR_FOO => 1, ERR_BAR => 2 } => ERR_BAR' ) ; + is( 'ERR_FOO', most_common_error( { ERR_FOO => 2, ERR_BAR => 1 } ), 'most_common_error: { ERR_FOO => 2, ERR_BAR => 1 } => ERR_FOO' ) ; + # exaequo => first lexical wins. ERR_BAR <= ERR_FOO + is( 'ERR_BAR', most_common_error( { ERR_FOO => 2, ERR_BAR => 2 } ), 'most_common_error: { ERR_FOO => 2, ERR_BAR => 2 } => ERR_BAR' ) ; + + is( 'A', most_common_error( { A => 5, B => 5, C => 5 } ), 'most_common_error: { A => 5, B => 5, C => 5 } => A' ) ; + is( 'B', most_common_error( { A => 5, B => 6, C => 6 } ), 'most_common_error: { A => 5, B => 6, C => 6 } => B' ) ; + is( 'C', most_common_error( { A => 5, B => 5, C => 7 } ), 'most_common_error: { A => 5, B => 5, C => 7 } => C' ) ; + is( 'C', most_common_error( { A => 5, B => 6, C => 7 } ), 'most_common_error: { A => 5, B => 5, C => 7 } => C' ) ; + + note( 'Leaving tests_most_common_error()' ) ; + return ; +} + + + +sub most_common_error +{ + my $errors_counted_ref = shift ; + + if ( ! defined $errors_counted_ref ) { return 'ERR_NOTHING_REPORTED' ; } + + if ( 'HASH' ne ref $errors_counted_ref ) { return 'ERR_NOTHING_REPORTED' ; } + + # empty hash + if ( !%{ $errors_counted_ref } ) { return 'ERR_NOTHING_REPORTED' ; } + + # non empty hash + my $most_common_error = ( sort + { + $errors_counted_ref->{$b} <=> $errors_counted_ref->{$a} + || $a cmp $b + } keys %{$errors_counted_ref} )[0] ; + + return $most_common_error ; + +} + + + +sub tests_errorsanalyse +{ + note( 'Entering tests_errorsanalyse()' ) ; + + is( 'ERR_NOTHING_REPORTED', errorsanalyse( ), 'errorsanalyse: no args => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', errorsanalyse( ( ) ), 'errorsanalyse: empty list => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_UNCLASSIFIED', errorsanalyse( 'aie' ), 'errorsanalyse: aie => ERR_UNCLASSIFIED' ) ; + + # in case of equality, empty wins + is( 'ERR_NOTHING_REPORTED', errorsanalyse( 'aie', '' ), 'errorsanalyse: aie => ERR_UNCLASSIFIED' ) ; + is( 'ERR_NOTHING_REPORTED', errorsanalyse( '', 'aie' ), 'errorsanalyse: aie => ERR_UNCLASSIFIED' ) ; + + + is( 'ERR_UNCLASSIFIED', errorsanalyse( 'aie', 'ouille' ), 'errorsanalyse: aie, ouille => ERR_UNCLASSIFIED' ) ; + is( 'ERR_UNCLASSIFIED', errorsanalyse( 'aie', 'ouille', '' ), 'errorsanalyse: aie, ouille, "" => ERR_UNCLASSIFIED' ) ; + is( 'ERR_UNCLASSIFIED', errorsanalyse( '', 'aie', 'ouille' ), 'errorsanalyse: aie, ouille, "" => ERR_UNCLASSIFIED' ) ; + + is( 'ERR_NOTHING_REPORTED', errorsanalyse( '' ), 'errorsanalyse: "" => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', errorsanalyse( ( '' ) ), 'errorsanalyse: ( "" ) => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', errorsanalyse( ( '', '' ) ), 'errorsanalyse: ( "", "" ) => ERR_NOTHING_REPORTED' ) ; + + note( 'Leaving tests_errorsanalyse()' ) ; + return ; +} + + + +sub errorsanalyse +{ + my @errors = @ARG ; + my $errors_types_counted = errorclassify( @errors ) ; + + my $most_common_error = most_common_error( $errors_types_counted ) ; + + return $most_common_error ; +} + + + +sub tests_errorsdump +{ + note( 'Entering tests_errorsdump()' ) ; + + is( undef, errorsdump( ), 'errorsdump: no args => undef' ) ; + is( undef, errorsdump( ( ) ), 'errorsdump: empty list => undef' ) ; + is( "Err 1/1: ", errorsdump( '' ), 'errorsdump: one empty string => "Err 1/1: "' ) ; + is( "Err 1/1: aieaieaie", errorsdump( 'aieaieaie' ), 'errorsdump: aieaieaie => "Err 1/1: aieaieaie"' ) ; + is( "Err 1/2: Aie Err 2/2: Ouille", errorsdump( 'Aie ', 'Ouille' ), 'errorsdump: Aie Ouille => "Err 1/2: Aie Err 2/2: Ouille"' ) ; + note( 'Leaving tests_errorsdump()' ) ; + return ; +} + + sub errorsdump { - my( $nb_errors, @errors_log ) = @ARG ; + if ( ! @ARG ) { return ; } + + my @errors_log = @ARG ; + my $nb_errors = @errors_log ; my $error_num = 0 ; my $errors_list = q{} ; if ( @errors_log ) { - $errors_list = "++++ Listing $nb_errors errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n" ; - foreach my $error ( @errors_log ) { + foreach my $error ( @errors_log ) + { $error_num++ ; $errors_list .= "Err $error_num/$nb_errors: $error" ; } @@ -5064,9 +6080,26 @@ sub errorsdump } + +sub errors_listing +{ + my $mysync = shift ; + $mysync->{most_common_error} = errorsanalyse( errors_log( $sync ) ) ; + + my $errors_listing = join( '', + "++++ Listing $mysync->{nb_errors} errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n", + errorsdump( errors_log( $mysync ) ), + "The most frequent error is $mysync->{most_common_error}\n", + ) ; + return $errors_listing ; +} + + + + sub tests_live_result { - note( 'Entering tests_live_result()' ) ; + note( 'Entering tests_live_result()' ) ; my $nb_errors = shift ; if ( $nb_errors ) { @@ -5074,7 +6107,7 @@ sub tests_live_result } else { myprint( "Live tests ended successfully\n" ) ; } - note( 'Leaving tests_live_result()' ) ; + note( 'Leaving tests_live_result()' ) ; return ; } @@ -5140,7 +6173,7 @@ sub sync_flags ( $mysync->{ debug } or $debugflags ) and myprint( "Host1: flags init msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ; - $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ; + $h1_flags = flags_for_host2( $mysync, $h1_flags, $permanentflags2 ) ; $h2_flags = flagscase( $h2_flags ) ; @@ -5195,7 +6228,8 @@ sub lost_connection if ( $imap->IsUnconnected( ) ) { $mysync->{nb_errors}++ ; my $lcomm = $imap->LastIMAPCommand || q{} ; - my $einfo = $imap->LastError || @{$imap->History}[$LAST] || q{} ; + + my $einfo = imap_last_error( $imap ) ; # if string is long try reduce to a more reasonable size $lcomm = _filter( $mysync, $lcomm ) ; @@ -5209,6 +6243,14 @@ sub lost_connection } } +sub imap_last_error +{ + my $imap = shift ; + my $einfo = $imap->LastError || @{$imap->History}[$LAST] || q{} ; + chomp( $einfo ) ; + return( $einfo ) ; +} + sub tests_max { note( 'Entering tests_max()' ) ; @@ -5569,10 +6611,10 @@ sub get_password1 my $mysync = shift ; - $mysync->{password1} + $mysync->{ password1 } || $mysync->{ passfile1 } - || 'PREAUTH' eq $authmech1 - || 'EXTERNAL' eq $authmech1 + || 'PREAUTH' eq $mysync->{ acc1 }->{ authmech } + || 'EXTERNAL' eq $mysync->{ acc1 }->{ authmech } || $ENV{IMAPSYNC_PASSWORD1} || do { @@ -5583,8 +6625,8 @@ password of user1 in a file named file1 and use "--passfile1 file1" instead of t Then give this file restrictive permissions with the command "chmod 600 file1". An other solution is to set the environment variable IMAPSYNC_PASSWORD1 FIN_PASSFILE - my $user = $authuser1 || $mysync->{user1} ; - my $host = $mysync->{host1} ; + my $user = $mysync->{ acc1 }->{ authuser } || $mysync->{ user1 } ; + my $host = $mysync->{ host1 } ; my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ; $mysync->{password1} = ask_for_password( $prompt ) ; } ; @@ -5613,8 +6655,8 @@ sub get_password2 $mysync->{password2} || $mysync->{ passfile2 } - || 'PREAUTH' eq $authmech2 - || 'EXTERNAL' eq $authmech2 + || 'PREAUTH' eq $mysync->{ acc2 }->{ authmech } + || 'EXTERNAL' eq $mysync->{ acc2 }->{ authmech } || $ENV{IMAPSYNC_PASSWORD2} || do { @@ -5625,8 +6667,8 @@ password of user2 in a file named file2 and use "--passfile2 file2" instead of t Then give this file restrictive permissions with the command "chmod 600 file2". An other solution is to set the environment variable IMAPSYNC_PASSWORD2 FIN_PASSFILE - my $user = $authuser2 || $mysync->{user2} ; - my $host = $mysync->{host2} ; + my $user = $mysync->{ acc2 }->{ authuser } || $mysync->{ user2 } ; + my $host = $mysync->{ host2 } ; my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ; $mysync->{password2} = ask_for_password( $prompt ) ; } ; @@ -5656,9 +6698,15 @@ sub remove_tmp_files { my $mysync = shift or return ; $mysync->{pidfile} or return ; + if ( -e $mysync->{pidfile} ) { + myprint( "Removing pidfile $mysync->{pidfile}\n" ) ; unlink $mysync->{pidfile} ; } + if ( -e $mysync->{abortfile} ) { + myprint( "Removing pidfile $mysync->{abortfile}\n" ) ; + unlink $mysync->{abortfile} ; + } return ; } @@ -5679,14 +6727,28 @@ sub cleanup_before_exit if ( $mysync->{log} ) { myprint( "Log file is $mysync->{logfile} ( to change it, use --logfile filepath ; or use --nolog to turn off logging )\n" ) ; } + else + { + myprint( "No log file because of option --nolog\n" ) ; + } + if ( $mysync->{log} and $mysync->{logfile_handle} ) { - #myprint( "Closing $mysync->{ logfile }\n" ) ; - close $mysync->{logfile_handle} ; + #print( "Closing $mysync->{ logfile }\n" ) ; + teefinish( $mysync ) ; } return ; } +sub exit_most_errors +{ + my $mysync = shift @ARG ; + + myprint( errors_listing( $mysync ) ) ; + my $exit_value = $EXIT_VALUE_OF_ERR_TYPE{ $mysync->{most_common_error} } || $EXIT_CATCH_ALL ; + exit_clean( $mysync, $exit_value ) ; + return ; +} sub exit_clean { @@ -5697,7 +6759,7 @@ sub exit_clean { myprint( @messages ) ; } - myprint( "Exiting with return value $status ($EXIT_TXT{$status}) $mysync->{nb_errors}/$mysync->{errorsmax} nb_errors/max_errors\n" ) ; + myprint( "Exiting with return value $status ($EXIT_TXT{$status}) $mysync->{nb_errors}/$mysync->{errorsmax} nb_errors/max_errors PID $PROCESS_ID\n" ) ; cleanup_before_exit( $mysync ) ; exit $status ; @@ -5721,11 +6783,12 @@ sub catch_ignore my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ; myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), "). Received $sigcounter $signame signals so far. Thanks!\n" ) ; - stats( $mysync ) ; + do_and_print_stats( $mysync ) ; return ; } + sub catch_exit { my $mysync = shift ; @@ -5733,22 +6796,26 @@ sub catch_exit if ( $signame ) { myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), "). Asked to terminate\n" ) ; - if ( $mysync->{stats} ) { - myprint( "Here are the final stats of this sync not completely finished so far\n" ) ; - stats( $mysync ) ; + if ( $mysync->{can_do_stats} ) { + do_and_print_stats( $mysync ) ; myprint( "Ended by a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), "). I am asked to terminate immediately.\n" ) ; - myprint( "You should resynchronize those accounts by running a sync again,\n", - "since some messages and entire folders might still be missing on host2.\n" ) ; } + myprint( "You should resynchronize those accounts by running a sync again,\n", + "since some messages and entire folders might still be missing on host2.\n" + ) ; ## no critic (RequireLocalizedPunctuationVars) + # Well, restore default action does not work well $SIG{ $signame } = 'DEFAULT'; # restore default action + #$SIG{ 'TERM' } = 'DEFAULT'; # restore default action # kill myself with $signame # https://www.cons.org/cracauer/sigint.html myprint( "Killing myself with signal $signame\n" ) ; - cleanup_before_exit( $mysync ) ; + #cleanup_before_exit( $mysync ) ; kill( $signame, $PROCESS_ID ) ; - sleep 1 ; + #kill( 'TERM', $PROCESS_ID ) ; + #sleep 1 ; + #while ( 1 ) { } ; $mysync->{nb_errors}++ ; exit_clean( $mysync, $EXIT_BY_SIGNAL, "Still there after killing myself with signal $signame...\n" @@ -5861,6 +6928,7 @@ sub install_signals # --sigignore can override sigexit, sigreconnect and sigprint (for the same signals only) sig_install( $mysync, 'catch_ignore', @{ $mysync->{ sigignore } } ) ; + # remove/add sleeping mechanism when receiving USR1 signal (except on Win32) sig_install_toggle_sleep( $mysync ) ; } @@ -5955,10 +7023,6 @@ sub reconnect_if_needed } - -# $sync->{id} = defined $sync->{id} ? $sync->{id} : 1 ; -# imap_id_stuff( $sync ) ; - sub justconnect { my $mysync = shift ; @@ -5974,10 +7038,11 @@ sub justconnect1 { myprint( "Host1: Will just connect to $mysync->{host1} without login\n" ) ; $mysync->{imap1} = connect_imap( - $mysync->{host1}, $mysync->{port1}, $debugimap1, - $mysync->{ssl1}, $mysync->{tls1}, 'Host1', - $mysync->{h1}->{timeout}, $mysync->{h1} ) ; - imap_id( $mysync, $mysync->{imap1}, 'Host1' ) ; + $mysync->{host1}, $mysync->{port1}, + $mysync->{ssl1}, $mysync->{tls1}, + $mysync->{ acc1 } ) ; + + imap_id( $mysync, $mysync->{imap1}, $mysync->{ acc1 }->{ Side } ) ; $mysync->{imap1}->logout( ) ; return $mysync->{host1} ; } @@ -5992,10 +7057,11 @@ sub justconnect2 { myprint( "Host2: Will just connect to $mysync->{host2} without login\n" ) ; $mysync->{imap2} = connect_imap( - $mysync->{host2}, $mysync->{port2}, $debugimap2, - $mysync->{ssl2}, $mysync->{tls2}, 'Host2', - $mysync->{h2}->{timeout}, $mysync->{h2} ) ; - imap_id( $mysync, $mysync->{imap2}, 'Host2' ) ; + $mysync->{host2}, $mysync->{port2}, + $mysync->{ssl2}, $mysync->{tls2}, + $mysync->{ acc2 } ) ; + + imap_id( $mysync, $mysync->{imap2}, $mysync->{ acc2 }->{ Side } ) ; $mysync->{imap2}->logout( ) ; return $mysync->{host2} ; } @@ -6006,9 +7072,18 @@ sub justconnect2 sub skip_macosx { #return ; - return( 'macosx.polarhome.com' eq hostname() ) ; + # hostname used to be macosx.polarhome.com + return( 'macosx' eq hostname( ) && ( 'darwin' eq $OSNAME ) ) ; } +sub skip_macosx_binary +{ + #return ; + return( skip_macosx( ) && ( $PROGRAM_NAME =~ m{imapsync_bin_Darwin} ) ) ; +} + + + sub tests_mailimapclient_connect { note( 'Entering tests_mailimapclient_connect()' ) ; @@ -6026,7 +7101,7 @@ sub tests_mailimapclient_connect is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4: setting Server(test.lamiral.info)' ) ; is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4: setting Debug( 1 )' ) ; is( 143, $imap->Port( 143 ), 'mailimapclient_connect ipv4: setting Port( 143 )' ) ; - is( 3, $imap->Timeout( 3 ), 'mailimapclient_connect ipv4: setting Timout( 3 )' ) ; + is( 10, $imap->Timeout( 10 ), 'mailimapclient_connect ipv4: setting Timeout( 10 )' ) ; like( ref( $imap->connect( ) ), qr/IO::Socket::INET|IO::Socket::IP/, 'mailimapclient_connect ipv4: connect to test.lamiral.info' ) ; like( $imap->logout( ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv4: logout' ) ; is( undef, undef $imap, 'mailimapclient_connect ipv4: free variable' ) ; @@ -6042,11 +7117,10 @@ sub tests_mailimapclient_connect is( undef, undef $imap, 'mailimapclient_connect ipv4 + ssl: free variable' ) ; # ipv6 + ssl - # Fails often on ks2ipv6.lamiral.info - + ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv6 + ssl: new' ) ; is( 'petiteipv6.lamiral.info', $imap->Server( 'petiteipv6.lamiral.info' ), 'mailimapclient_connect ipv6 + ssl: setting Server petiteipv6.lamiral.info' ) ; - is( 3, $imap->Timeout( 3 ), 'mailimapclient_connect ipv4: setting Timout( 3 )' ) ; + is( 10, $imap->Timeout( 10 ), 'mailimapclient_connect ipv6: setting Timeout( 10 )' ) ; ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'mailimapclient_connect ipv6 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ; is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv6 + ssl: setting Port( 993 )' ) ; SKIP: { @@ -6062,9 +7136,9 @@ sub tests_mailimapclient_connect { skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 4 ) ; } - + is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4 + ssl: setting Debug( 1 )' ) ; - + # It sounds stupid but it avoids failures on the next test about $imap->connect is( '2a01:e34:ecde:70d0:223:54ff:fec2:36d7', resolv( 'petiteipv6.lamiral.info' ), 'resolv: petiteipv6.lamiral.info => 2001:41d0:8:bebd::1' ) ; @@ -6089,7 +7163,7 @@ sub tests_mailimapclient_connect_bug # ipv6 ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect_bug ipv6: new' ) ; - is( 'ks2ipv6.lamiral.info', $imap->Server( 'ks2ipv6.lamiral.info' ), 'mailimapclient_connect_bug ipv6: setting Server(ks2ipv6.lamiral.info)' ) ; + is( 'ks6ipv6.lamiral.info', $imap->Server( 'ks6ipv6.lamiral.info' ), 'mailimapclient_connect_bug ipv6: setting Server(ks6ipv6.lamiral.info)' ) ; is( 143, $imap->Port( 143 ), 'mailimapclient_connect_bug ipv6: setting Port( 993 )' ) ; SKIP: { @@ -6105,7 +7179,7 @@ sub tests_mailimapclient_connect_bug { skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 1 ) ; } - like( ref( $imap->connect( ) ), qr/IO::Socket::INET/, 'mailimapclient_connect_bug ipv6: connect to ks2ipv6.lamiral.info' ) + like( ref( $imap->connect( ) ), qr/IO::Socket::INET/, 'mailimapclient_connect_bug ipv6: connect to ks6ipv6.lamiral.info' ) or diag( 'mailimapclient_connect_bug ipv6: ', $imap->LastError( ), $!, ) ; } #is( $imap->logout( ), undef, 'mailimapclient_connect_bug ipv6: logout in ssl causes failure' ) ; @@ -6140,12 +7214,12 @@ sub tests_connect_socket } $socket = IO::Socket::INET6->new( - PeerAddr => 'ks2ipv6.lamiral.info', + PeerAddr => 'ks6ipv6.lamiral.info', PeerPort => 143, ) ; - ok( $imap = connect_socket( $socket ), 'connect_socket: ks2ipv6.lamiral.info port 143 IO::Socket::INET6' ) ; + ok( $imap = connect_socket( $socket ), 'connect_socket: ks6ipv6.lamiral.info port 143 IO::Socket::INET6' ) ; #$imap->Debug( 1 ) ; # myprint( $imap->capability( ) ) ; if ( $imap ) { @@ -6154,13 +7228,13 @@ sub tests_connect_socket $IO::Socket::SSL::DEBUG = 4 ; $socket = IO::Socket::SSL->new( - PeerHost => 'ks2ipv6.lamiral.info', + PeerHost => 'ks6ipv6.lamiral.info', PeerPort => 993, SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH', ) ; # myprint( $socket ) ; - ok( $imap = connect_socket( $socket ), 'connect_socket: ks2ipv6.lamiral.info port 993 IO::Socket::SSL' ) ; + ok( $imap = connect_socket( $socket ), 'connect_socket: ks6ipv6.lamiral.info port 993 IO::Socket::SSL' ) ; #$imap->Debug( 1 ) ; # myprint( $imap->capability( ) ) ; # $socket->close( ) ; @@ -6216,10 +7290,10 @@ sub tests_probe_imapssl skip( 'Tests avoided on CUILLERE or pcHPDV7-HP or Mac or docker: cannot do ipv6', 0 ) ; } # fed up with this one - #like( probe_imapssl( 'ks2ipv6.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: ks2ipv6.lamiral.info matches "* OK"' ) ; + #like( probe_imapssl( 'ks6ipv6.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: ks6ipv6.lamiral.info matches "* OK"' ) ; } ; - + # It sounds stupid but it avoids failures on the next test about $imap->connect ok( resolv( 'imap.gmail.com' ), 'resolv: imap.gmail.com => something' ) ; like( probe_imapssl( 'imap.gmail.com' ), qr/^\* OK/, 'probe_imapssl: imap.gmail.com matches "* OK"' ) ; @@ -6257,193 +7331,604 @@ sub probe_imapssl sub connect_imap { - my( $host, $port, $mydebugimap, $ssl, $tls, $Side, $mytimeout, $h ) = @_ ; + my( $host, $port, $ssl, $tls, $acc ) = @_ ; my $imap = Mail::IMAPClient->new( ) ; - - if ( $ssl ) { set_ssl( $imap, $h ) } + + if ( $ssl ) { set_ssl( $imap, $acc ) } $imap->Server( $host ) ; $imap->Port( $port ) ; - $imap->Debug( $mydebugimap ) ; - $imap->Timeout( $mytimeout ) ; + $imap->Debug( $acc->{ debugimap } ) ; + $imap->Timeout( $acc->{ timeout } ) ; - my $side = lc $Side ; - myprint( "$Side: connecting on $side [$host] port [$port]\n" ) ; + my $side = lc $acc->{ Side } ; + + myprint( "$acc->{ Side }: connecting on $side [$host] port [$port]\n" ) ; if ( ! $imap->connect( ) ) { $sync->{nb_errors}++ ; exit_clean( $sync, $EXIT_CONNECTION_FAILURE, - "$Side: Can not open imap connection on [$host]: ", + "$acc->{ Side }: Can not open imap connection on [$host]: ", $imap->LastError, " $OS_ERROR\n" ) ; } - myprint( "$Side IP address: ", $imap->Socket->peerhost(), "\n" ) ; + myprint( "$acc->{ Side } IP address: ", $imap->Socket->peerhost(), "\n" ) ; my $banner = $imap->Results()->[0] ; - myprint( "$Side banner: $banner" ) ; - myprint( "$Side capability: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ; + myprint( "$acc->{ Side } banner: $banner" ) ; + myprint( "$acc->{ Side } capability: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ; if ( $tls ) { - set_tls( $imap, $h ) ; + set_tls( $imap, $acc ) ; if ( ! $imap->starttls( ) ) { $sync->{nb_errors}++ ; exit_clean( $sync, $EXIT_TLS_FAILURE, - "$Side: Can not go to tls encryption on $side [$host]:", + "$acc->{ Side }: Can not go to tls encryption on $side [$host]:", $imap->LastError, "\n" ) ; } - myprint( "$Side: Socket successfuly converted to SSL\n" ) ; + myprint( "$acc->{ Side }: Socket successfully converted to SSL\n" ) ; } return( $imap ) ; } + +sub tests_login_imap +{ + note( 'Entering tests_login_imap()' ) ; + + is( undef, login_imap( ), 'login_imap: no args => undef' ) ; + + SKIP: { + if ( skip_macosx_binary( ) ) + { + skip( 'Tests avoided only on binary on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 11 ) ; + } + else{ + + my $myimap ; + my $acc = {} ; + $acc->{ Side } = 'HostK' ; + $acc->{ authmech } = 'LOGIN' ; + #$IO::Socket::SSL::DEBUG = 4 ; + # Each month (trimester?): + # echo | openssl s_client -crlf -connect test1.lamiral.info:993 + # ... + # certificate has expired + # Fix: + # ssh root@test1.lamiral.info 'apt update && apt upgrade && /etc/init.d/dovecot restart' + ok( + $myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1', + 1, undef, + 1, 100, $acc, {}, + ), 'login_imap: test1.lamiral.info test1 ssl' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ; + + ok( + $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, undef, + 1, 100, $acc, {}, + ), 'login_imap: test1.lamiral.info test1 tls' ) ; + ok( $myimap && $myimap->IsAuthenticated( ), 'login_imap: test1.lamiral.info test1 tls IsAuthenticated' ) ; + + #$IO::Socket::SSL::DEBUG = 4 ; + $acc->{sslargs} = { SSL_version => 'SSLv2' } ; + # SSLv2 not supported + is( + undef, $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, undef, + 1, 100, $acc, {}, + ), 'login_imap: test1.lamiral.info test1 tls SSLv2 not supported' ) ; +#SSL_verify_mode => 1 +#SSL_version => 'TLSv1_1' + + + + # I have left ? exit_clean to be replaced by errors_incr( $mysync, 'error message' ) + # 1 in login_imap() + + + my $mysync = {} ; + $acc = {} ; + $acc->{ Side } = 'Host2' ; + $acc->{ authmech } = 'LOGIN' ; + is( + undef, login_imap( 'noresol.lamiral.info', 143, 'test1', 'secret1', + 0, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: noresol.lamiral.info undef' ) ; + + is( 'ERR_CONNECTION_FAILURE_HOST2', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host2 noresol.lamiral.info => ERR_CONNECTION_FAILURE_HOST2' ) ; + + # authentication failure for user2 + $mysync = {} ; + is( + undef, login_imap( 'test1.lamiral.info', 143, 'test1', 'Ce crétin', + 0, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: user2 bad passord => undef' ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER2', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host2 bad password => ERR_AUTHENTICATION_FAILURE_USER2' ) ; + + # authentication failure for user1 + $mysync = {} ; + $acc = {} ; + $acc->{ Side } = 'Host1' ; + $acc->{ authmech } = 'LOGIN' ; + is( + undef, login_imap( 'test1.lamiral.info', 143, 'test1', 'Ce crétin', + 0, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: user1 bad passord => undef' ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host1 bad password => ERR_AUTHENTICATION_FAILURE_USER1' ) ; + + } + } + + note( 'Leaving tests_login_imap()' ) ; + return ; +} + +sub oauthgenerateaccess +{ + if ( "petite" eq hostname() ) + { + myprint( "oauthgenerateaccess\n" ) ; + my @output = backtick( 'cd oauth2 && pwd && ./generate_gmail_token imapsync.gl0@gmail.com' ) ; + myprint( @output ) ; + } + return ; +} + +sub tests_login_imap_oauth +{ + note( 'Entering tests_login_imap_oauth()' ) ; + + oauthgenerateaccess() ; + + SKIP: { + if ( skip_macosx_binary( ) ) + { + skip( 'Tests avoided only on binary on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 6 ) ; + } + else + { + + my $mysync ; + my $acc ; + # oauthdirect authentication failure for user2 + $mysync = {} ; + $acc = {} ; + $acc->{ oauthdirect } = 'caca2' ; + $acc->{ debugimap } = 1 ; + $mysync->{ showpasswords } = 1 ; + $acc->{ Side } = 'Host2' ; + $acc->{ authmech } = 'QQQ' ; + is( + undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin', + 1, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: user2 bad oauthdirect => undef' ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER2', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host2 bad oauthdirect => ERR_AUTHENTICATION_FAILURE_USER2' ) ; + + # oauthdirect authentication failure for user1 + $mysync = {} ; + $acc = {} ; + $acc->{ Side } = 'Host1' ; + $acc->{ oauthdirect } = 'caca1' ; + $acc->{ debugimap } = 1 ; + $mysync->{ showpasswords } = 1 ; + $acc->{ authmech } = 'QQQ' ; + is( + undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin', + 1, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: user1 bad oauthdirect => undef' ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host1 bad oauthdirect => ERR_AUTHENTICATION_FAILURE_USER1' ) ; + + # oauthdirect authentication failure for user1 + $mysync = {} ; + $acc = {} ; + $acc->{ Side } = 'Host1' ; + $acc->{ oauthdirect } = '' ; + $acc->{ debugimap } = 1 ; + $mysync->{ showpasswords } = 1 ; + $acc->{ authmech } = 'QQQ' ; + is( + undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin', + 1, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: user1 bad oauthdirect => undef' ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host1 no oauthdirect value => ERR_AUTHENTICATION_FAILURE_USER1' ) ; + + } + } + + # oauthdirect authentication success for user1 + SKIP: { + if ( ! -r 'oauth2/D_oauth2_oauthdirect_imapsync.gl0@gmail.com.txt' ) + { + skip( 'oauthdirect: no oauthdirect file', 2 ) ; + } + my $myimap ; + my $mysync = {} ; + my $acc = {} ; + $acc->{ Side } = 'Host1' ; + $acc->{ oauthdirect } = 'oauth2/D_oauth2_oauthdirect_imapsync.gl0@gmail.com.txt' ; + $acc->{ debugimap } = 1 ; + $mysync->{ showpasswords } = 1 ; + $acc->{ authmech } = 'QQQ' ; + isa_ok( + $myimap = login_imap( 'imap.gmail.com', 993, 'user_useless', 'password_useless', + 1, undef, + 1, 100, $acc, $mysync, + ), 'Mail::IMAPClient', 'login_imap: user1 good oauthdirect => Mail::IMAPClient' ) ; + + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 IsAuthenticated' ) ; + } + + # oauthaccesstoken authentication success for user1 + SKIP: { + if ( ! -r 'oauth2/D_oauth2_access_token_imapsync.gl0@gmail.com.txt' ) + { + skip( 'oauthaccesstoken: no access_token file', 2 ) ; + } + my $myimap ; + my $mysync = {} ; + my $acc = {} ; + $acc->{ Side } = 'Host1' ; + $acc->{ oauthaccesstoken } = 'oauth2/D_oauth2_access_token_imapsync.gl0@gmail.com.txt' ; + $acc->{ debugimap } = 1 ; + $mysync->{ showpasswords } = 1 ; + $acc->{ authmech } = 'QQQ' ; + isa_ok( + $myimap = login_imap( 'imap.gmail.com', 993, 'imapsync.gl0@gmail.com', 'password_useless', + 1, undef, + 1, 100, $acc, $mysync, + ), 'Mail::IMAPClient', 'login_imap: user1 good oauthaccesstoken => Mail::IMAPClient' ) ; + + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthaccesstoken IsAuthenticated' ) ; + + } + + + note( 'Leaving tests_login_imap_oauth()' ) ; + return ; +} + + + sub login_imap { - my @allargs = @_ ; my( - $host, $port, $user, $domain, $password, - $mydebugimap, $mytimeout, $fastio, - $ssl, $tls, $authmech, $authuser, $reconnectretry, - $proxyauth, $uid, $split, $Side, $h, $mysync ) = @allargs ; + $host, $port, $user, $password, + $ssl, $tls, + $uid, $split, $acc, $mysync ) = @allargs ; - my $side = lc $Side ; - myprint( "$Side: connecting and login on $side [$host] port [$port] with user [$user]\n" ) ; + if ( ! all_defined( $host, $port, $user, $acc->{ Side } ) ) + { + return ; + } + + my $side = lc $acc->{ Side } ; + myprint( "$acc->{ Side }: connecting and login on $side [$host] port [$port] with user [$user]\n" ) ; my $imap = init_imap( @allargs ) ; if ( ! $imap->connect() ) { - $mysync->{nb_errors}++ ; - exit_clean( $mysync, $EXIT_CONNECTION_FAILURE, - "$Side failure: can not open imap connection on $side [$host] with user [$user]: ", - $imap->LastError . " $OS_ERROR\n" - ) ; + my $error = "$acc->{ Side } failure: can not open imap connection on $side [$host] with user [$user]: " + . $imap->LastError . " $OS_ERROR\n" ; + errors_incr( $mysync, $error ) ; + return ; } - myprint( "$Side IP address: ", $imap->Socket->peerhost(), "\n" ) ; + myprint( "$acc->{ Side } IP address: ", $imap->Socket->peerhost(), "\n" ) ; my $banner = $imap->Results()->[0] ; - myprint( "$Side banner: $banner" ) ; - myprint( "$Side capability before authentication: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ; + myprint( "$acc->{ Side } banner: $banner" ) ; + myprint( "$acc->{ Side } capability before authentication: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ; if ( (! $ssl) and (! defined $tls ) and $imap->has_capability( 'STARTTLS' ) ) { - myprint( "$Side: going to ssl because STARTTLS is in CAPABILITY. Use --notls1 or --notls2 to avoid that behavior\n" ) ; + myprint( "$acc->{ Side }: going to ssl because STARTTLS is in CAPABILITY. Use --notls1 or --notls2 to avoid that behavior\n" ) ; $tls = 1 ; } - if ( $authmech eq 'PREAUTH' ) { + + #myprint( Data::Dumper->Dump( [ @allargs ] ) ) ; + if ( $tls ) { + set_tls( $imap, $acc ) ; + + if ( ! $imap->starttls( ) ) + { + my $error = "$acc->{ Side } failure: Can not go to tls encryption on $side [$host]: " + . $imap->LastError . "\n" ; + + errors_incr( $mysync, $error ) ; + return ; + } + myprint( "$acc->{ Side }: Socket successfully converted to SSL\n" ) ; + } + + if ( $acc->{ authmech } eq 'PREAUTH' ) { if ( $imap->IsAuthenticated( ) ) { $imap->Socket ; - myprintf("%s: Assuming PREAUTH for %s\n", $Side, $imap->Server ) ; + myprintf("%s: Assuming PREAUTH for %s\n", $acc->{ Side }, $imap->Server ) ; }else{ $mysync->{nb_errors}++ ; exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE, - "$Side failure: error login on $side [$host] with user [$user] auth [PREAUTH]\n" + "$acc->{ Side } failure: error login on $side [$host] with user [$user] auth [PREAUTH]\n" ) ; } } - if ( $tls ) { - set_tls( $imap, $h ) ; - if ( ! $imap->starttls( ) ) - { - $mysync->{nb_errors}++ ; - exit_clean( $mysync, $EXIT_TLS_FAILURE, - "$Side failure: Can not go to tls encryption on $side [$host]:", - $imap->LastError, "\n" - ) ; - } - myprint( "$Side: Socket successfuly converted to SSL\n" ) ; + + + if ( authenticate_imap( $imap, @allargs ) ) + { + myprint( "$acc->{ Side }: success login on [$host] with user [$user] auth [$acc->{ authmech }] or [LOGIN]\n" ) ; + return( $imap ) ; + } + else + { + # The errors are already printed + myprint( "$acc->{ Side }: failed login on [$host] with user [$user] auth [$acc->{ authmech }]\n" ) ; + return ; } - - authenticate_imap( $imap, @allargs ) ; - - myprint( "$Side: success login on [$host] with user [$user] auth [$authmech]\n" ) ; - return( $imap ) ; } + +sub init_imap +{ + my( + $host, $port, $user, $password, + $ssl, $tls, + $uid, $split, $acc, $mysync ) = @_ ; + + my ( $imap ) ; + + $imap = Mail::IMAPClient->new() ; + + if ( $mysync->{ tee } ) + { + # Well, it does not change anything, does it? + # It does when suppressing the hack with *STDERR + $imap->Debug_fh( $mysync->{ tee } ) ; + } + + if ( $ssl ) { set_ssl( $imap, $acc ) } + if ( $tls ) { } # can not do set_tls() here because connect() will directly do a STARTTLS + $imap->Clear( 1 ) ; + $imap->Server( $host ) ; + $imap->Port( $port ) ; + $imap->Fast_io( $acc->{ fastio } ) ; + $imap->Buffer( $buffersize || $DEFAULT_BUFFER_SIZE ) ; + $imap->Uid( $uid ) ; + + + $imap->Peek( 1 ) ; + $imap->Debug( $acc->{ debugimap } ) ; + if ( $mysync->{ showpasswords } ) { + $imap->Showcredentials( 1 ) ; + } + + defined $acc->{ timeout } and $imap->Timeout( $acc->{ timeout } ) ; + + if ( defined $acc->{ reconnectretry } ) + { + $imap->Reconnectretry( $acc->{ reconnectretry } ) ; + } + $imap->{IMAPSYNC_RECONNECT_COUNT} = 0 ; + $imap->Ignoresizeerrors( $allowsizemismatch ) ; + $split and $imap->Maxcommandlength( $SPLIT_FACTOR * $split ) ; + + + return( $imap ) ; + +} + sub authenticate_imap { my( $imap, - $host, $port, $user, $domain, $password, - $mydebugimap, $mytimeout, $fastio, - $ssl, $tls, $authmech, $authuser, $reconnectretry, - $proxyauth, $uid, $split, $Side, $h, $mysync ) = @_ ; + $host, $port, $user, $password, + $ssl, $tls, + $uid, $split, $acc, $mysync ) = @_ ; - check_capability( $imap, $authmech, $Side ) ; + check_capability( $imap, $acc->{ authmech }, $acc->{ Side } ) ; $imap->User( $user ) ; - $imap->Domain( $domain ) if ( defined $domain ) ; - $imap->Authuser( $authuser ) ; + + if ( defined $acc->{ domain } ) + { + $imap->Domain( $acc->{ domain } ) ; + $mysync->{ debug } and myprint( "Domain: $acc->{ domain }\n" ) ; + } + + $imap->Authuser( $acc->{ authuser } ) ; $imap->Password( $password ) ; - if ( 'X-MASTERAUTH' eq $authmech ) + if ( 'X-MASTERAUTH' eq $acc->{ authmech } ) { xmasterauth( $imap ) ; - return ; + return 1 ; } - if ( $proxyauth ) { + + if ( defined $acc->{ oauthdirect } ) + { + $acc->{ authmech } = 'XOAUTH2 direct' ; + return( oauthdirect( $mysync, $acc, $imap, $host, $user ) ) ; + } + + + if ( defined $acc->{ oauthaccesstoken } ) + { + $acc->{ authmech } = 'XOAUTH2 accesstoken' ; + return( oauthaccesstoken( $mysync, $acc, $imap, $host, $user ) ) ; + } + + + + + if ( $acc->{ proxyauth } ) { $imap->Authmechanism(q{}) ; - $imap->User( $authuser ) ; + $imap->User( $acc->{ authuser } ) ; } else { - $imap->Authmechanism( $authmech ) unless ( $authmech eq 'LOGIN' or $authmech eq 'PREAUTH' ) ; + $imap->Authmechanism( $acc->{ authmech } ) unless ( $acc->{ authmech } eq 'LOGIN' or $acc->{ authmech } eq 'PREAUTH' ) ; } - $imap->Authcallback(\&xoauth) if ( 'XOAUTH' eq $authmech ) ; - $imap->Authcallback(\&xoauth2) if ( 'XOAUTH2' eq $authmech ) ; - $imap->Authcallback(\&plainauth) if ( ( 'PLAIN' eq $authmech ) or ( 'EXTERNAL' eq $authmech ) ) ; + $imap->Authcallback(\&xoauth2) if ( 'XOAUTH2' eq $acc->{ authmech } ) ; + $imap->Authcallback(\&plainauth) if ( ( 'PLAIN' eq $acc->{ authmech } ) or ( 'EXTERNAL' eq $acc->{ authmech } ) ) ; - unless ( $authmech eq 'PREAUTH' or $imap->login( ) ) { - my $info = "$Side failure: Error login on [$host] with user [$user] auth" ; - my $einfo = $imap->LastError || @{$imap->History}[$LAST] ; - chomp $einfo ; - my $error = "$info [$authmech]: $einfo\n" ; - if ( ( $authmech eq 'LOGIN' ) or $imap->IsUnconnected( ) or $authuser ) { - $authuser ||= "" ; - myprint( "$Side info: authmech [$authmech] user [$user] authuser [$authuser] IsUnconnected [", $imap->IsUnconnected( ), "]\n" ) ; - $mysync->{nb_errors}++ ; - exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE, $error ) ; + unless ( $acc->{ authmech } eq 'PREAUTH' or $imap->login( ) ) { + my $info = "$acc->{ Side } failure: Error login on [$host] with user [$user] auth" ; + my $einfo = imap_last_error( $imap ) ; + my $error = "$info [$acc->{ authmech }]: $einfo\n" ; + + + if ( ( $acc->{ authmech } eq 'LOGIN' ) or $imap->IsUnconnected( ) or $acc->{ authuser } ) { + $acc->{ authuser } ||= "" ; + myprint( "$acc->{ Side } info: authmech [$acc->{ authmech }] user [$user] authuser [$acc->{ authuser }] IsUnconnected [", $imap->IsUnconnected( ), "]\n" ) ; + errors_incr( $mysync, $error ) ; + return ; }else{ - myprint( $error ) ; + errors_incr( $mysync, $error ) ; } + # It is not secure to try plain text LOGIN when another authmech failed - # but I do it. - # I shell remove this code one day. - myprint( "$Side info: trying LOGIN Auth mechanism on [$host] with user [$user]\n" ) ; - $imap->Authmechanism(q{}) ; - if ( ! $imap->login( ) ) + # but I do it anyway. This behavior is optional as option --notrylogin will skip it. + if ( $mysync->{ trylogin } ) { - $mysync->{nb_errors}++ ; - exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE, - "$info [LOGIN]: ", - $imap->LastError, "\n" - ) ; + myprint( "$acc->{ Side } info: trying LOGIN Auth mechanism on [$host] with user [$user]. Use option --notrylogin to avoid this second chance to login via LOGIN auth\n" ) ; + $imap->Authmechanism(q{}) ; + if ( ! $imap->login( ) ) + { + failure_login( $mysync, $acc, 'LOGIN', $imap, $host, $user ) ; + return ; + } + else + { + myprint( "$acc->{ Side }: success login on [$host] with user [$user] auth [LOGIN] after [$acc->{ authmech }] failure\n" ) ; + } + } + else + { + myprint( "$acc->{ Side } info: not trying LOGIN Auth mechanism on [$host] with user [$user]. Use option --trylogin to have this second chance to login via LOGIN auth\n" ) ; + return ; } } - if ( $proxyauth ) { + if ( $acc->{ proxyauth } ) { if ( ! $imap->proxyauth( $user ) ) { - my $info = "$Side failure: Error doing proxyauth as user [$user] on [$host] using proxy-login as [$authuser]" ; - my $einfo = $imap->LastError || @{$imap->History}[$LAST] ; - chomp $einfo ; - $mysync->{nb_errors}++ ; - exit_clean( $mysync, - $EXIT_AUTHENTICATION_FAILURE, - "$info: $einfo\n" - ) ; + failure_proxyauth( $mysync, $acc, $acc->{ authmech }, $imap, $host, $user ) ; + return ; } } + return 1; +} + + +sub failure_login +{ + my( $mysync, $acc, $authmech, $imap, $host, $user ) = @ARG ; + my $info = "$acc->{ Side } failure: Error login on [$host] with user [$user] auth" ; + my $einfo = imap_last_error( $imap ) ; + my $error = "$info [$authmech]: $einfo\n" ; + errors_incr( $mysync, $error ) ; return ; } +# failure_login and failure_proxyauth function are similar but +# variable $error so no factoring +sub failure_proxyauth +{ + my( $mysync, $acc, $authmech, $imap, $host, $user ) = @ARG ; + my $info = "$acc->{ Side } failure: Error login on [$host] with user [$user] auth" ; + my $einfo = imap_last_error( $imap ) ; + my $error = "$info [$authmech] using proxy-login as [$acc->{ authuser }]: $einfo\n" ; + errors_incr( $mysync, $error ) ; + return ; +} + + + + +sub oauthdirect +{ + my( $mysync, $acc, $imap, $host, $user ) = @_ ; + + my $oauthdirect_str ; + if ( -f -r $acc->{ oauthdirect } ) + { + $oauthdirect_str = firstline( $acc->{ oauthdirect } ) ; + } + else + { + $oauthdirect_str = $acc->{ oauthdirect } || 'Please define oauthdirect value' ; + } + if ( $imap->authenticate('XOAUTH2', sub { return $oauthdirect_str } ) ) + { + return 1 ; + } + else + { + failure_login( $mysync, $acc, $acc->{ authmech }, $imap, $host, $user ) ; + return ; + } + return ; +} + + + + +sub oauthaccesstoken +{ + my( $mysync, $acc, $imap, $host, $user ) = @_ ; + + my $oauthaccesstoken_str ; + if ( -f -r $acc->{ oauthaccesstoken } ) + { + $oauthaccesstoken_str = firstline( $acc->{ oauthaccesstoken } ) ; + } + else + { + $oauthaccesstoken_str = $acc->{ oauthaccesstoken } || 'Please define oauthaccesstoken value' ; + } + + my $oauth_string = "user=" . $user . "\x01auth=Bearer ". $oauthaccesstoken_str . "\x01\x01" ; + #myprint "oauth_string: $oauth_string\n" ; + + my $oauth_string_base64 = encode_base64( $oauth_string , '' ) ; + #myprint "oauth_string_base64: $oauth_string_base64\n" ; + + my $oauthdirect_str = $oauth_string_base64 ; + + if ( $imap->authenticate('XOAUTH2', sub { return $oauthdirect_str } ) ) + { + return 1 ; + } + else + { + failure_login( $mysync, $acc, $acc->{ authmech }, $imap, $host, $user ) ; + return ; + } + return ; +} + + + + sub check_capability { @@ -6479,12 +7964,12 @@ sub check_capability sub set_ssl { - my ( $imap, $h ) = @_ ; + my ( $imap, $acc ) = @_ ; # SSL_version can be # SSLv3 SSLv2 SSLv23 SSLv23:!SSLv2 (last one is the default in IO-Socket-SSL-1.953) # - my $sslargs_hash = $h->{sslargs} ; + my $sslargs_hash = $acc->{sslargs} ; my $sslargs_default = { SSL_verify_mode => $SSL_VERIFY_POLICY, @@ -6509,14 +7994,15 @@ sub set_ssl sub set_tls { - my ( $imap, $h ) = @_ ; + my ( $imap, $acc ) = @_ ; - my $sslargs_hash = $h->{sslargs} ; + my $sslargs_hash = $acc->{sslargs} ; my $sslargs_default = { SSL_verify_mode => $SSL_VERIFY_POLICY, - SSL_cipher_list => 'DEFAULT:!DH', + SSL_cipher_list => 'DEFAULT:!DH', } ; + #myprint( Data::Dumper->Dump( [ $acc, $sslargs_hash, $sslargs_default ] ) ) ; # initiate with default values my %sslargs_mix = %{ $sslargs_default } ; @@ -6535,53 +8021,6 @@ sub set_tls - -sub init_imap -{ - my( - $host, $port, $user, $domain, $password, - $mydebugimap, $mytimeout, $fastio, - $ssl, $tls, $authmech, $authuser, $reconnectretry, - $proxyauth, $uid, $split, $Side, $h, $mysync ) = @_ ; - - my ( $imap ) ; - - $imap = Mail::IMAPClient->new() ; - - if ( $mysync->{ tee } ) - { - # Well, it does not change anything, does it? - # It does when suppressing the hack with *STDERR - $imap->Debug_fh( $mysync->{ tee } ) ; - } - - if ( $ssl ) { set_ssl( $imap, $h ) } - if ( $tls ) { } # can not do set_tls() here because connect() will directly do a STARTTLS - $imap->Clear(1); - $imap->Server($host); - $imap->Port($port); - $imap->Fast_io($fastio); - $imap->Buffer($buffersize || $DEFAULT_BUFFER_SIZE); - $imap->Uid($uid); - - - $imap->Peek(1); - $imap->Debug($mydebugimap); - if ( $mysync->{ showpasswords } ) { - $imap->Showcredentials( 1 ) ; - } - defined $mytimeout and $imap->Timeout( $mytimeout ) ; - - $imap->Reconnectretry( $reconnectretry ) if ( $reconnectretry ) ; - $imap->{IMAPSYNC_RECONNECT_COUNT} = 0 ; - $imap->Ignoresizeerrors( $allowsizemismatch ) ; - $split and $imap->Maxcommandlength( $SPLIT_FACTOR * $split ) ; - - - return( $imap ) ; - -} - sub plainauth { my $code = shift; @@ -6714,80 +8153,6 @@ sub xoauth2 -# xoauth() thanks to Eduardo Bortoluzzi Junior -sub xoauth -{ - require URI::Escape ; - require Data::Uniqid ; - - my $code = shift; - my $imap = shift; - - # The base information needed to construct the OAUTH authentication - my $method = 'GET' ; - my $url = mysprintf( 'https://mail.google.com/mail/b/%s/imap/', $imap->User ) ; - my $urlparm = mysprintf( 'xoauth_requestor_id=%s', URI::Escape::uri_escape( $imap->User ) ) ; - - # For Google Apps, the consumer key is the primary domain - # TODO: create a command line argument to define the consumer key - my @user_parts = split /@/x, $imap->User ; - $sync->{ debug } and myprint( "XOAUTH: consumer key: $user_parts[1]\n" ) ; - - # All the parameters needed to be signed on the XOAUTH - my %hash = (); - $hash { 'xoauth_requestor_id' } = URI::Escape::uri_escape($imap->User); - $hash { 'oauth_consumer_key' } = $user_parts[1]; - $hash { 'oauth_nonce' } = md5_hex(Data::Uniqid::uniqid(rand(), 1==1)); - $hash { 'oauth_signature_method' } = 'HMAC-SHA1'; - $hash { 'oauth_timestamp' } = time ; - $hash { 'oauth_version' } = '1.0'; - - # Base will hold the string to be signed - my $base = "$method&" . URI::Escape::uri_escape( $url ) . q{&} ; - - # The parameters must be in dictionary order before signing - my $baseparms = q{} ; - foreach my $key ( sort keys %hash ) { - if ( length( $baseparms ) > 0 ) { - $baseparms .= q{&} ; - } - - $baseparms .= "$key=$hash{$key}" ; - } - - $base .= URI::Escape::uri_escape($baseparms); - $sync->{ debug } and myprint( "XOAUTH: base request to sign: $base\n" ) ; - # Sign it with the consumer secret, informed on the command line (password) - my $digest = hmac_sha1( $base, URI::Escape::uri_escape( $imap->Password ) . q{&} ) ; - - # The parameters signed become a parameter and... - $hash { 'oauth_signature' } = URI::Escape::uri_escape( substr encode_base64( $digest ), 0, $MINUS_ONE ) ; - - # ... we don't need the requestor_id anymore. - delete $hash{'xoauth_requestor_id'} ; - - # Create the final authentication string - my $string = $method . q{ } . $url . q{?} . $urlparm .q{ } ; - - # All the parameters must be sorted - $baseparms = q{}; - foreach my $key (sort keys %hash) { - if(length($baseparms)>0) { - $baseparms .= q{,} ; - } - - $baseparms .= "$key=\"$hash{$key}\""; - } - - $string .= $baseparms; - - $sync->{ debug } and myprint( "XOAUTH: authentication string: $string\n" ) ; - - # It must be base64 encoded - return encode_base64("$string", q{}); -} - - sub xmasterauth { # This is Kerio auth admin @@ -6839,29 +8204,6 @@ sub xmasterauth } -sub tests_do_valid_directory -{ - note( 'Entering tests_do_valid_directory()' ) ; - - Readonly my $NB_UNIX_tests_do_valid_directory => 2 ; - SKIP: { - skip( 'Tests only for Unix', $NB_UNIX_tests_do_valid_directory ) if ( 'MSWin32' eq $OSNAME ) ; - ok( 1 == do_valid_directory( '.'), 'do_valid_directory: . good' ) ; - ok( 1 == do_valid_directory( './W/tmp/tests/valid/sub'), 'do_valid_directory: ./W/tmp/tests/valid/sub good' ) ; - } - Readonly my $NB_UNIX_tests_do_valid_directory_non_root => 2 ; - SKIP: { - skip( 'Tests only for Unix', $NB_UNIX_tests_do_valid_directory_non_root ) if ( 'MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) ; - diag( 'Error / not writable is on purpose' ) ; - ok( 0 == do_valid_directory( '/'), 'do_valid_directory: / bad' ) ; - diag( 'Error permission denied on /noway is on purpose' ) ; - ok( 0 == do_valid_directory( '/noway'), 'do_valid_directory: /noway bad' ) ; - } - - - note( 'Leaving tests_do_valid_directory()' ) ; - return ; -} sub banner_imapsync { @@ -6870,8 +8212,8 @@ sub banner_imapsync my $banner_imapsync = join q{}, q{$RCSfile: imapsync,v $ }, - q{$Revision: 1.977 $ }, - q{$Date: 2019/12/23 20:18:02 $ }, + q{$Revision: 2.148 $ }, + q{$Date: 2021/07/22 14:21:09 $ }, "\n", "Command line used, run by $EXECUTABLE_NAME:\n", "$PROGRAM_NAME ", command_line_nopassword( $mysync, @argv ), "\n" ; @@ -6879,6 +8221,29 @@ sub banner_imapsync return( $banner_imapsync ) ; } +sub tests_do_valid_directory +{ + note( 'Entering tests_do_valid_directory()' ) ; + + is( 1, do_valid_directory( '.'), 'do_valid_directory: . good' ) ; + is( 1, do_valid_directory( './W/tmp/tests/valid/sub'), 'do_valid_directory: ./W/tmp/tests/valid/sub good' ) ; + + Readonly my $NB_UNIX_tests_do_valid_directory_non_root => 2 ; + diag( "OSNAME=$OSNAME EFFECTIVE_USER_ID=$EFFECTIVE_USER_ID" ) ; + + SKIP: { + skip( 'Tests only for non roor user', $NB_UNIX_tests_do_valid_directory_non_root ) if ( '0' eq $EFFECTIVE_USER_ID ) ; + diag( 'The "Error / is not writable" is on purpose' ) ; + ok( 0 == do_valid_directory( '/'), 'do_valid_directory: / bad' ) ; + diag( 'The "Error permission denied" on /noway is on purpose' ) ; + ok( 0 == do_valid_directory( '/noway'), 'do_valid_directory: /noway bad' ) ; + } + + + note( 'Leaving tests_do_valid_directory()' ) ; + return ; +} + sub do_valid_directory { my $dir = shift @ARG ; @@ -6898,7 +8263,7 @@ sub do_valid_directory return( 0 ) ; } # Trying to create it - myprint( "Creating directory $dir\n" ) ; + myprint( "Creating directory $dir (current directory is " . getcwd( ) . ")\n" ) ; if ( ! eval { mkpath( $dir ) } ) { myprint( "$EVAL_ERROR" ) if ( $EVAL_ERROR ) ; } @@ -6924,11 +8289,14 @@ sub tests_match_a_pid_number is( 1, match_a_pid_number( 99999 ), 'match_a_pid_number: 99999 => 1' ) ; is( 1, match_a_pid_number( -99999 ), 'match_a_pid_number: -99999 => 1' ) ; is( undef, match_a_pid_number( 0 ), 'match_a_pid_number: 0 => undef' ) ; - is( undef, match_a_pid_number( 100000 ), 'match_a_pid_number: 100000 => undef' ) ; - is( undef, match_a_pid_number( 123456 ), 'match_a_pid_number: 123456 => undef' ) ; + is( 1, match_a_pid_number( 100000 ), 'match_a_pid_number: 100000 => 1' ) ; + is( 1, match_a_pid_number( 123456 ), 'match_a_pid_number: 123456 => 1' ) ; is( undef, match_a_pid_number( '-0' ), 'match_a_pid_number: "-0" => undef' ) ; - is( undef, match_a_pid_number( -100000 ), 'match_a_pid_number: -100000 => undef' ) ; - is( undef, match_a_pid_number( -123456 ), 'match_a_pid_number: -123456 => undef' ) ; + is( 1, match_a_pid_number( -100000 ), 'match_a_pid_number: -100000 => 1' ) ; + is( 1, match_a_pid_number( -123456 ), 'match_a_pid_number: -123456 => 1' ) ; + is( 1, match_a_pid_number( 2**22 ), 'match_a_pid_number: 2**22 => 1' ) ; + is( undef, match_a_pid_number( 2**22 + 1 ), 'match_a_pid_number: 2**22 + 1 => undef' ) ; + is( undef, match_a_pid_number( 4194304 + 1 ), 'match_a_pid_number: 2**22 + 1 = 4194305 => undef' ) ; note( 'Leaving tests_match_a_pid_number()' ) ; return ; @@ -6944,7 +8312,7 @@ sub match_a_pid_number # can be negative on Windows #if ( 0 > $pid ) { return ; } #if ( 65535 < $pid ) { return ; } - if ( 99999 < abs( $pid ) ) { return ; } + if ( 2**22 < abs( $pid ) ) { return ; } if ( 0 == abs( $pid ) ) { return ; } return 1 ; } @@ -6974,13 +8342,20 @@ sub remove_pidfile_not_running { # my $pid_filename = shift @ARG ; - + + #myprint( "In remove_pidfile_not_running $pid_filename\n" ) ; if ( ! $pid_filename ) { myprint( "No variable pid_filename\n" ) ; return } ; - if ( ! -e $pid_filename ) { myprint( "File $pid_filename does not exist\n" ) ; return } ; + if ( ! -e $pid_filename ) + { + myprint( "File $pid_filename does not exist\n" ) ; + return ; + } + #myprint( "Still In remove_pidfile_not_running $pid_filename\n" ) ; + if ( ! -f $pid_filename ) { myprint( "File $pid_filename is not a file\n" ) ; return } ; my $pid = firstline( $pid_filename ) ; - if ( ! match_a_pid_number( $pid ) ) { myprint( "pid $pid in $pid_filename is not a number\n" ) ; return } ; + if ( ! match_a_pid_number( $pid ) ) { myprint( "In remove_pidfile_not_running: pid $pid in $pid_filename is not a pid number\n" ) ; return } ; # can't kill myself => do nothing if ( ! kill 'ZERO', $PROCESS_ID ) { myprint( "Can not kill ZERO myself $PROCESS_ID\n" ) ; return } ; @@ -7061,6 +8436,8 @@ sub tail if ( ! $lock ) { return ; } if ( ! $tail ) { return ; } + if ( ! -e $pidfile ) { return ; } + my $pidtotail = firstline( $pidfile ) ; if ( ! $pidtotail ) { return ; } @@ -7173,13 +8550,14 @@ sub write_pidfile { # returns undef if something is considered fatal # returns 1 otherwise - + + #myprint( "In write_pidfile\n" ) ; if ( ! @ARG ) { return 1 ; } my $mysync = shift @ARG ; - # Do not write the pid file if this process goal is to abort the process designed by the pid file - if ( $mysync->{abort} ) { return 1 ; } + # Do not write the pid file if the current process goal is to abort the process designed by the pid file + if ( $mysync->{ abort } ) { return 1 ; } # my $pid_filename = $mysync->{ pidfile } ; @@ -7384,6 +8762,9 @@ sub tests_jux_utf8 is( '[&ZTZO9nux-] = [收件箱]', jux_utf8( '&ZTZO9nux-'), 'jux_utf8: => [&ZTZO9nux-] = [收件箱]' ) ; # + # + is( '[!Old Emails]', jux_utf8( '!Old Emails'), 'jux_utf8: !Old Emails => [!Old Emails]' ) ; + is( '[2006 Budget & Fcst]', jux_utf8( '2006 Budget & Fcst'), 'jux_utf8: 2006 Budget & Fcst => [2006 Budget & Fcst]' ) ; note( 'Leaving tests_jux_utf8()' ) ; return ; } @@ -7530,6 +8911,7 @@ sub create_folder if ( $create_folder_old ) { return( create_folder_old( $mysync, $myimap2 , $h2_fold , $h1_fold ) ) ; } + myprint( "Creating folder [$h2_fold] on host2\n" ) ; if ( ( 'INBOX' eq uc $h2_fold ) and ( $myimap2->exists( $h2_fold ) ) ) { @@ -7577,6 +8959,7 @@ sub create_folder if ( ! $mysync->{ justfolders } ) { myprint( "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" ) ; + # The messages that could be transferred are counted and the number is given at the end. } return( 0 ) ; } @@ -7639,7 +9022,7 @@ sub sort_requested_folders { my @requested_folders_sorted = () ; - #myprint "folderfirst: @folderfirst\n" ; + $sync->{ debug } and myprint "folderfirst: @folderfirst\n" ; my @folderfirst_requested = remove_from_requested_folders( @folderfirst ) ; #myprint "folderfirst_requested: @folderfirst_requested\n" ; @@ -7648,7 +9031,7 @@ sub sort_requested_folders my @middle = sort keys %requested_folder ; @requested_folders_sorted = ( @folderfirst_requested, @middle, @folderlast_requested ) ; - #myprint "requested_folders_sorted: @requested_folders_sorted\n" ; + $sync->{ debug } and myprint "requested_folders_sorted: @requested_folders_sorted\n" ; add_to_requested_folders( @requested_folders_sorted ) ; return( @requested_folders_sorted ) ; @@ -7707,7 +9090,7 @@ sub tests_remove_from_requested_folders is_deeply( [ 'F1', 'F2' ], [ remove_from_requested_folders( 'F1', 'F2' ) ], 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => F1 F2' ) ; is_deeply( { 'F3' => 1 }, { %requested_folder }, 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => %requested_folder F3' ) ; - + undef %requested_folder ; note( 'Leaving tests_remove_from_requested_folders()' ) ; return ; @@ -7784,13 +9167,13 @@ sub tests_compare_lists ok(+1 == compare_lists([1] , []) , 'compare_lists, [1] > []'); - ok( 0 == compare_lists([1], 1 ) , 'compare_lists, [1] = 1 ') ; - ok( 0 == compare_lists( 1 , [1]) , 'compare_lists, 1 = [1]') ; + ok( 0 == compare_lists( [1], 1 ) , 'compare_lists, [1] = 1 ') ; + ok( 0 == compare_lists( 1 , [1] ) , 'compare_lists, 1 = [1]') ; ok( 0 == compare_lists( 1 , 1 ) , 'compare_lists, 1 = 1 ') ; - ok($MINUS_ONE == compare_lists( 0 , 1 ) , 'compare_lists, 0 < 1 ') ; - ok($MINUS_ONE == compare_lists($MINUS_ONE , 0 ) , 'compare_lists, -1 < 0 ') ; - ok($MINUS_ONE == compare_lists( 1 , 2 ) , 'compare_lists, 1 < 2 ') ; - ok(+1 == compare_lists( 2 , 1 ) , 'compare_lists, 2 > 1 ') ; + ok( $MINUS_ONE == compare_lists( 0 , 1 ) , 'compare_lists, 0 < 1 ') ; + ok( $MINUS_ONE == compare_lists( $MINUS_ONE , 0 ) , 'compare_lists, -1 < 0 ') ; + ok( $MINUS_ONE == compare_lists( 1 , 2 ) , 'compare_lists, 1 < 2 ') ; + ok( +1 == compare_lists( 2 , 1 ) , 'compare_lists, 2 > 1 ') ; ok( 0 == compare_lists([1,2], [1,2]) , 'compare_lists, [1,2] = [1,2]' ) ; @@ -8015,6 +9398,7 @@ sub folders_list_to_help return( $listing ) ; } +# Globals are $sync @h1_folders_all @h2_folders_all $prefix1 $prefix2 sub private_folders_separators_and_prefixes { # what are the private folders separators and prefixes for each server ? @@ -8121,8 +9505,32 @@ sub sanitize_subfolder } } +sub tests_sanitize_host +{ + note( 'Entering tests_sanitize_host()' ) ; + + is( undef, sanitize_host( ), 'sanitize_host: no args => undef' ) ; + is( '', sanitize_host( '' ), 'sanitize_host: empty => empty' ) ; + is( 'imap.example.org', sanitize_host( 'imap.example.org' ), 'sanitize_host: imap.example.org => imap.example.org' ) ; + is( 'imap.example.org', sanitize_host( ' imap.example.org' ), 'sanitize_host: imap.example.org 1 => imap.example.org' ) ; + is( 'imap.example.org', sanitize_host( 'imap.example.org ' ), 'sanitize_host: imap.example.org 2 => imap.example.org' ) ; + is( 'imap.example.org', sanitize_host( 'imap.exam ple.org' ), 'sanitize_host: imap.example.org 3 => imap.example.org' ) ; + is( 'imap.example.org', sanitize_host( ' imap.exam ple.org ' ), 'sanitize_host: imap.example.org 4 => imap.example.org' ) ; + is( 'imap.example.org', sanitize_host( 'imap.exa/mple.org/' ), 'sanitize_host: imap.example.org/ => imap.example.org' ) ; + + note( 'Leaving tests_sanitize_host()' ) ; + return ; +} +sub sanitize_host +{ + my $host = shift ; + if ( ! defined $host ) { return ; } + + $host =~ tr{ /}{}d ; + return $host ; +} sub tests_add_subfolder1_to_folderrec @@ -8707,86 +10115,89 @@ sub timesince -sub tests_flags_regex +sub tests_regexflags { - note( 'Entering tests_flags_regex()' ) ; + note( 'Entering tests_regexflags()' ) ; - ok( q{} eq flags_regex(q{} ), 'flags_regex, null string q{}' ) ; - ok( q{\Seen NonJunk $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, nothing to do} ) ; + my $mysync = {} ; + + ok( q{} eq regexflags( $mysync, q{} ), 'regexflags, null string q{}' ) ; + ok( q{\Seen NonJunk $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, nothing to do} ) ; - @regexflag = ('I am BAD' ) ; - ok( not ( defined flags_regex( q{} ) ), 'flags_regex, bad regex' ) ; + @{ $mysync->{ regexflag } } = ('I am BAD' ) ; + ok( not ( defined regexflags( $mysync, q{} ) ), 'regexflags, bad regex' ) ; - @regexflag = ( 's/NonJunk//g' ) ; - ok( q{\Seen $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove NonJunk: 's/NonJunk//g'} ) ; - @regexflag = ( q{s/\$Spam//g} ) ; - ok( q{\Seen NonJunk } eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove $Spam: 's/\$Spam//g'} ) ; + @{ $mysync->{ regexflag } } = ( 's/NonJunk//g' ) ; + ok( q{\Seen $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, remove NonJunk: 's/NonJunk//g'} ) ; + @{ $mysync->{ regexflag } } = ( q{s/\$Spam//g} ) ; + ok( q{\Seen NonJunk } eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, remove $Spam: 's/\$Spam//g'} ) ; - @regexflag = ( 's/\\\\Seen//g' ) ; + @{ $mysync->{ regexflag } } = ( 's/\\\\Seen//g' ) ; - ok( q{ NonJunk $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove \Seen: 's/\\\\\\\\Seen//g'} ) ; + ok( q{ NonJunk $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, remove \Seen: 's/\\\\\\\\Seen//g'} ) ; - @regexflag = ( 's/(\s|^)[^\\\\]\w+//g' ) ; - ok( q{\Seen \Middle \End} eq flags_regex( q{\Seen NonJunk \Middle $Spam \End} ), q{flags_regex: only \word among \Seen NonJunk \Middle $Spam \End} ) ; - ok( q{ \Seen \Middle \End1} eq flags_regex( q{Begin \Seen NonJunk \Middle $Spam \End1 End} ), - q{flags_regex: only \word among Begin \Seen NonJunk \Middle $Spam \End1 End} ) ; + @{ $mysync->{ regexflag } } = ( 's/(\s|^)[^\\\\]\w+//g' ) ; + ok( q{\Seen \Middle \End} eq regexflags( $mysync, q{\Seen NonJunk \Middle $Spam \End} ), q{regexflags: only \word among \Seen NonJunk \Middle $Spam \End} ) ; + ok( q{ \Seen \Middle \End1} eq regexflags( $mysync, q{Begin \Seen NonJunk \Middle $Spam \End1 End} ), + q{regexflags: only \word among Begin \Seen NonJunk \Middle $Spam \End1 End} ) ; - @regexflag = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g} ) ; - ok( 'Keep1 Keep2 ReB' eq flags_regex('ReA Keep1 REM Keep2 ReB'), 'Keep only regex' ) ; + @{ $mysync->{ regexflag } } = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g} ) ; + ok( 'Keep1 Keep2 ReB' eq regexflags( $mysync, 'ReA Keep1 REM Keep2 ReB' ), 'Keep only regex' ) ; - ok( 'Keep1 Keep2 ' eq flags_regex( 'REM REM Keep1 Keep2'), 'Keep only regex' ) ; - ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 REM REM Keep2'), 'Keep only regex' ) ; - ok( 'Keep1 Keep2 ' eq flags_regex( 'REM Keep1 REM REM Keep2'), 'Keep only regex' ) ; - ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2'), 'Keep only regex' ) ; - ok( 'Keep1 ' eq flags_regex( 'REM Keep1'), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM REM Keep1 Keep2' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 REM REM Keep2' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM REM Keep2' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2' ), 'Keep only regex' ) ; + ok( 'Keep1 ' eq regexflags( $mysync, 'REM Keep1' ), 'Keep only regex' ) ; - @regexflag = ( q{s/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g} ) ; - ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 ReB'), 'Keep only regex' ) ; - ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 REM REM REM'), 'Keep only regex' ) ; - ok( 'Keep2 ' eq flags_regex('Keep2 REM REM REM'), 'Keep only regex' ) ; + @{ $mysync->{ regexflag } } = ( q{s/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g} ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2 ReB' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2 REM REM REM' ), 'Keep only regex' ) ; + ok( 'Keep2 ' eq regexflags( $mysync, 'Keep2 REM REM REM' ), 'Keep only regex' ) ; - @regexflag = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g}, + @{ $mysync->{ regexflag } } = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g}, 's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g' ) ; - ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), 'Keep only regex' ) ; - ok( 'Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), 'Keep only regex' ) ; - ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), 'Keep only regex' ) ; - ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), 'Keep only regex' ) ; - ok( 'Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), 'Keep only regex' ) ; - ok( 'Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), 'Keep only regex' ) ; - ok( 'Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2 REM' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 REM Keep2 REM' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 Keep2 REM' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 Keep3 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2 REM REM Keep3 REM' ), 'Keep only regex' ) ; + ok( 'Keep1 ' eq regexflags( $mysync, 'REM REM Keep1 REM REM REM ' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep3 ' eq regexflags( $mysync, 'RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 ' ), 'Keep only regex' ) ; - @regexflag = ( 's/(.*)/$1 jrdH8u/' ) ; - ok('REM REM REM REM REM jrdH8u' eq flags_regex('REM REM REM REM REM'), q{Add jrdH8u 's/(.*)/\$1 jrdH8u/'} ) ; - @regexflag = ('s/jrdH8u *//'); - ok('REM REM REM REM REM ' eq flags_regex('REM REM REM REM REM jrdH8u'), q{Remove jrdH8u s/jrdH8u *//} ) ; + @{ $mysync->{ regexflag } } = ( 's/(.*)/$1 jrdH8u/' ) ; + ok('REM REM REM REM REM jrdH8u' eq regexflags( $mysync, 'REM REM REM REM REM' ), q{Add jrdH8u 's/(.*)/\$1 jrdH8u/'} ) ; + @{ $mysync->{ regexflag } } = ('s/jrdH8u *//' ); + ok('REM REM REM REM REM ' eq regexflags( $mysync, 'REM REM REM REM REM jrdH8u' ), q{Remove jrdH8u s/jrdH8u *//} ) ; - @regexflag = ( + @{ $mysync->{ regexflag } } = ( 's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg' ); ok( '\\Deleted \\Answered ' - eq flags_regex('Blabla \$Junk \\Deleted machin \\Answered truc'), + eq regexflags( $mysync, 'Blabla \$Junk \\Deleted machin \\Answered truc' ), 'Keep only regex: Exchange case (Phil)' ) ; - ok( q{} eq flags_regex( q{} ), 'Keep only regex: Exchange case, null string (Phil)' ) ; + ok( q{} eq regexflags( $mysync, q{} ), 'Keep only regex: Exchange case, null string (Phil)' ) ; ok( q{} - eq flags_regex('Blabla $Junk machin truc'), + eq regexflags( $mysync, 'Blabla $Junk machin truc' ), 'Keep only regex: Exchange case, no accepted flags (Phil)' ) ; ok('\\Deleted \\Answered \\Draft \\Flagged ' - eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), + eq regexflags( $mysync, '\\Deleted \\Answered \\Draft \\Flagged ' ), 'Keep only regex: Exchange case (Phil)' ) ; - @regexflag = ( 's/\\\\Flagged//g' ) ; + @{ $mysync->{ regexflag } } = ( 's/\\\\Flagged//g' ) ; is('\Deleted \Answered \Draft ', - flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), - 'flags_regex: remove \Flagged 1' ) ; + regexflags( $mysync, '\\Deleted \\Answered \\Draft \\Flagged ' ), + 'regexflags: remove \Flagged 1' ) ; + is('\\Deleted \\Answered \\Draft', - flags_regex('\\Deleted \\Flagged \\Answered \\Draft'), - 'flags_regex: remove \Flagged 2' ) ; + regexflags( $mysync, '\\Deleted \\Flagged \\Answered \\Draft' ), + 'regexflags: remove \Flagged 2' ) ; # I didn't understand why it gives \F # https://perldoc.perl.org/perlrebackslash.html @@ -8795,49 +10206,136 @@ sub tests_flags_regex # \F Not available in old Perl so I comment the test - # @regexflag = ( 's/\\Flagged/X/g' ) ; + # @{ $mysync->{ regexflag } } = ( 's/\\Flagged/X/g' ) ; #is('\Deleted FX \Answered \FX \Draft \FX', - #flags_regex( '\Deleted Flagged \Answered \Flagged \Draft \Flagged' ), - # 'flags_regex: remove \Flagged 3 mistery...' ) ; + #regexflags( '\Deleted Flagged \Answered \Flagged \Draft \Flagged' ), + # 'regexflags: remove \Flagged 3 mistery...' ) ; - note( 'Leaving tests_flags_regex()' ) ; + $mysync->{ regexflag } = [ ] ; + $mysync->{ filterbuggyflags } = 1 ; + filterbuggyflags( $mysync ) ; + + is( '\Deleted \Answered \Draft \Flagged', + regexflags( $mysync, '\\Deleted \\Answered \\RECEIPTCHECKED \\Draft \\Indexed \\Flagged' ), + 'regexflags: remove famous /X 1' ) ; + + is( '\\Deleted \\Flagged \\Answered \\Draft', + regexflags( $mysync, '\\Deleted \\RECEIPTCHECKED \\Flagged \\Answered \\Indexed \\Draft' ), + 'regexflags: remove famous /X 2' ) ; + + is( '\ ', '\\ ', 'regexflags: \ is \\ ' ) ; + is( '\\ ', '\\ ', 'regexflags: \\ is \\ ' ) ; + is( '\\ \ ', '\ \\ ', 'regexflags: \\ \ is \ \\ ' ) ; + note( 'Leaving tests_regexflags()' ) ; return ; } -sub flags_regex +sub regexflags { - my ( $h1_flags ) = @_ ; - foreach my $regexflag ( @regexflag ) { - my $h1_flags_orig = $h1_flags ; - $debugflags and myprint( "eval \$h1_flags =~ $regexflag\n" ) ; - my $ret = eval "\$h1_flags =~ $regexflag ; 1 " ; - $debugflags and myprint( "regexflag $regexflag [$h1_flags_orig] -> [$h1_flags]\n" ) ; + my $mysync = shift ; + my $flags = shift ; + + foreach my $regexflag ( @{ $mysync->{ regexflag } } ) + { + my $flags_orig = $flags ; + $debugflags and myprint( "eval \$flags =~ $regexflag\n" ) ; + my $ret = eval "\$flags =~ $regexflag ; 1 " ; + $debugflags and myprint( "regexflag $regexflag [$flags_orig] -> [$flags]\n" ) ; if( not ( defined $ret ) or $EVAL_ERROR ) { myprint( "Error: eval regexflag '$regexflag': $EVAL_ERROR\n" ) ; return( undef ) ; } } - return( $h1_flags ) ; + return( $flags ) ; } + +sub filterbuggyflags +{ + my $mysync = shift ; + if ( $mysync->{ filterbuggyflags } ) + { + unshift @{ $mysync->{ regexflag } }, buggyflagsregex( ) ; + } + return ; +} + + +sub tests_remove_doublequotes_if_any +{ + note( 'Entering tests_remove_doublequotes_if_any()' ) ; + # the number of tests is stupid here + is( undef, remove_doublequotes_if_any( ), 'remove_doublequotes_if_any: no args => undef' ) ; + is( q{}, remove_doublequotes_if_any( q{} ), 'remove_doublequotes_if_any: empty string => empty string' ) ; + is( q{}, remove_doublequotes_if_any( q{""} ), 'remove_doublequotes_if_any: double-quotes => empty string' ) ; + is( q{}, remove_doublequotes_if_any( q{"""} ), 'remove_doublequotes_if_any: double-quotes => empty string' ) ; + is( q{}, remove_doublequotes_if_any( q{"""} ), 'remove_doublequotes_if_any: double-quotes => empty string' ) ; + is( q{toto}, remove_doublequotes_if_any( q{"toto"} ), 'remove_doublequotes_if_any: "toto" => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{toto} ), 'remove_doublequotes_if_any: toto => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{to"to} ), 'remove_doublequotes_if_any: to"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{toto"} ), 'remove_doublequotes_if_any: toto" => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{"toto} ), 'remove_doublequotes_if_any: "toto => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{"to"to} ), 'remove_doublequotes_if_any: "to"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{to"to"} ), 'remove_doublequotes_if_any: to"to" => toto' ) ; + + is( q{toto}, remove_doublequotes_if_any( q{to\"to} ), 'remove_doublequotes_if_any: to\"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{toto\"} ), 'remove_doublequotes_if_any: toto\" => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{\"toto} ), 'remove_doublequotes_if_any: \"toto => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{\"to\"to} ), 'remove_doublequotes_if_any: \"to\"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{to\"to\"} ), 'remove_doublequotes_if_any: to\"to" => toto' ) ; + + + note( 'Leaving tests_remove_doublequotes_if_any()' ) ; + return ; +} + + + +sub remove_doublequotes_if_any +{ + my $string = shift ; + + if ( ! defined $string ) { return ; } + $string =~ s/\\\"//g ; + $string =~ tr/"//d ; + return $string ; +} + + +# No globals here sub acls_sync { - my($h1_fold, $h2_fold) = @_ ; - if ( $syncacls ) { - my $h1_hash = $sync->{imap1}->getacl($h1_fold) - or myprint( "Could not getacl for $h1_fold: $EVAL_ERROR\n" ) ; - my $h2_hash = $sync->{imap2}->getacl($h2_fold) - or myprint( "Could not getacl for $h2_fold: $EVAL_ERROR\n" ) ; +# https://tools.ietf.org/html/rfc4314 +# Standard Rights: +# https://tools.ietf.org/html/rfc4314#section-2.1 + + my( $mysync, $h1_fold, $h2_fold ) = @_ ; + if ( $mysync->{ syncacls } ) { + my $h1_hash = $mysync->{imap1}->getacl($h1_fold) + or myprint( "Host1: Could not getacl for $h1_fold: $EVAL_ERROR\n" ) ; + my $h2_hash = $mysync->{imap2}->getacl($h2_fold) + or myprint( "Host2: Could not getacl for $h2_fold: $EVAL_ERROR\n" ) ; + my %users = map { ($_, 1) } ( keys %{ $h1_hash} , keys %{ $h2_hash } ) ; foreach my $user (sort keys %users ) { - my $acl = $h1_hash->{$user} || 'none' ; - myprint( "acl $user: [$acl]\n" ) ; - next if ($h1_hash->{$user} && $h2_hash->{$user} && - $h1_hash->{$user} eq $h2_hash->{$user}); - unless ($sync->{dry}) { - myprint( "setting acl $h2_fold $user $acl\n" ) ; - $sync->{imap2}->setacl($h2_fold, $user, $acl) - or myprint( "Could not set acl: $EVAL_ERROR\n" ) ; + my $h1_acl = remove_doublequotes_if_any( $h1_hash->{$user} ) || '' ; + my $h2_acl = remove_doublequotes_if_any( $h2_hash->{$user} ) || '' ; + myprint( "Host1: user $user has acl [$h1_acl] on host1\n" ) ; + myprint( "Host2: user $user has acl [$h2_acl] on host2\n" ) ; + # removes surrounding double-quotes if any + my $user_no_quotes = remove_doublequotes_if_any( $user ) ; + + if ( $h1_hash->{$user} + && $h2_hash->{$user} + && $h1_hash->{$user} eq $h2_hash->{$user} ) + { + myprint( "Host2: user $user_no_quotes has already the same acl, no need to set it.\n" ) ; + next ; + } + myprint( "Host2: setting acl for folder $h2_fold user $user_no_quotes acl $h1_acl $mysync->{dry_message}\n" ) ; + unless ( $mysync->{dry} ) { + $mysync->{imap2}->setacl( $h2_fold, $user_no_quotes, $h1_acl ) + or myprint( "Could not set acl for user $user_no_quotes on host2: $EVAL_ERROR\n" ) ; } } } @@ -8874,10 +10372,11 @@ sub permanentflags if ( $line =~ m{\[PERMANENTFLAGS\s\(([^)]+?)\)\]}x ) { ( $debugflags or $sync->{ debug } ) and myprint( "permanentflags: $line" ) ; my $permanentflags = $1 ; - if ( $permanentflags =~ m{\\\*}x ) { + if ( $permanentflags =~ m{\\\*}x ) + { $permanentflags = q{} ; } - return($permanentflags) ; + return( $permanentflags ) ; } ; } return( q{} ) ; @@ -8913,19 +10412,6 @@ sub flags_filter return( $flags_out ) ; } -sub flagscase -{ - my $flags = shift ; - - my @flags = split /\s+/x, $flags ; - my %rfc_flags = map { $_ => 1 } split q{ }, '\Answered \Flagged \Deleted \Seen \Draft' ; - my @flags_out = map { exists $rfc_flags{ ucsecond( lc $_ ) } ? ucsecond( lc $_ ) : $_ } @flags ; - - my $flags_out = join q{ }, @flags_out ; - - return( $flags_out ) ; -} - sub tests_flagscase { note( 'Entering tests_flagscase()' ) ; @@ -8943,6 +10429,93 @@ sub tests_flagscase return ; } +sub flagscase +{ + my $flags = shift ; + + my @flags = split /\s+/x, $flags ; + my %rfc_flags = map { $_ => 1 } split q{ }, '\Answered \Flagged \Deleted \Seen \Draft' ; + my @flags_out = map { exists $rfc_flags{ ucsecond( lc $_ ) } ? ucsecond( lc $_ ) : $_ } @flags ; + + my $flags_out = join q{ }, @flags_out ; + + return( $flags_out ) ; +} + + + +sub tests_flags_for_host2 +{ + note( 'Entering tests_flags_for_host2()' ) ; + + is( undef, flags_for_host2( ), 'flags_for_host2: no args => undef' ) ; + + my $mysync ; + is( undef, flags_for_host2( $mysync ), 'flags_for_host2: undef => undef' ) ; + + $mysync = { } ; + is( undef, flags_for_host2( $mysync ), 'flags_for_host2: nothing => undef' ) ; + + is( q{}, flags_for_host2( $mysync, '' ), 'flags_for_host2: no flags => empty string' ) ; + + is( q{}, flags_for_host2( $mysync, '\Recent' ), 'flags_for_host2: \Recent => empty string' ) ; + + is( q{\Seen}, flags_for_host2( $mysync, '\Recent \Seen' ), 'flags_for_host2: \Recent \Seen => \Seen' ) ; + + is( q{\Deleted \Seen}, flags_for_host2( $mysync, '\Deleted \Recent \Seen' ), 'flags_for_host2: \Deleted \Recent \Seen => \Deleted \Seen' ) ; + + $mysync->{ flagscase } = 0 ; + is( q{\DELETED \Seen}, flags_for_host2( $mysync, '\DELETED \Seen' ), 'flags_for_host2: flagscase = 0 \DELETED \Seen => \DELETED \Seen' ) ; + + $mysync->{ flagscase } = 1 ; + is( q{\Deleted \Seen}, flags_for_host2( $mysync, '\DELETED \Seen' ), 'flags_for_host2: flagscase = 1 \DELETED \Seen => \Deleted \Seen' ) ; + + $mysync->{ filterflags } = 0 ; + is( q{\Seen \Blabla}, flags_for_host2( $mysync, '\Seen \Blabla', '\Seen \Junk' ), 'flags_for_host2: filterflags = 0 \Seen \Blabla among \Seen \Junk => \Seen \Blabla' ) ; + + $mysync->{ filterflags } = 1 ; + is( q{\Seen}, flags_for_host2( $mysync, '\Seen \Blabla', '\Seen \Junk' ), 'flags_for_host2: filterflags = 1 \Seen \Blabla among \Seen \Junk => \Seen' ) ; + + $mysync->{ filterflags } = 1 ; + is( q{\Seen \Blabla}, flags_for_host2( $mysync, '\Seen \Blabla', '' ), 'flags_for_host2: filterflags = 1 \Seen \Blabla among "" => \Seen \Blabla' ) ; + + + note( 'Leaving tests_flags_for_host2()' ) ; + return ; +} + + + + +sub flags_for_host2 +{ + my $mysync = shift ; + my $h1_flags = shift ; + my $permanentflags2 = shift ; + + if ( ! all_defined( $mysync, $h1_flags ) ) { return ; } ; + + # RFC 2060: This flag can not be altered by any client + $h1_flags =~ s@\\Recent\s?@@xgi ; + + my $h1_flags_re ; + if ( $mysync->{ regexflag } and defined( $h1_flags_re = regexflags( $mysync, $h1_flags ) ) ) { + $h1_flags = $h1_flags_re ; + } + + if ( $mysync->{ flagscase } ) + { + $h1_flags = flagscase( $h1_flags ) ; + } + + if ( $permanentflags2 and $mysync->{ filterflags } ) + { + $h1_flags = flags_filter( $h1_flags, $permanentflags2 ) ; + } + + return( $h1_flags ) ; +} + sub ucsecond @@ -9041,8 +10614,7 @@ sub select_msgs_by_fetch $debugdev and myprint( "Calling fetch_hash()\n" ) ; - my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ; - my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; + my $fetch_hash_uids = $fetch_hash_set || "1:*" ; %fetch = %{$imap->fetch_hash( $fetch_hash_uids, 'INTERNALDATE' ) } ; @msgs_all = sort { $a <=> $b } keys %fetch ; @@ -9108,6 +10680,10 @@ sub msgs_from_maxmin @min = @{ $min_ref } ; SWITCH: { + if ( not ( defined $minage or defined $maxage ) ) + { + return ; + } unless( defined $minage ) { @msgs = @max ; last SWITCH } ; unless( defined $maxage ) { @msgs = @min ; last SWITCH } ; my ( %union, %inter ) ; @@ -9125,23 +10701,38 @@ sub msgs_from_maxmin sub tests_msgs_from_maxmin { - note( 'Entering tests_msgs_from_maxmin()' ) ; + note( 'Entering tests_msgs_from_maxmin()' ) ; + my @msgs ; + + # no maxage nor minage + @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; + is_deeply( [ ], \@msgs , 'msgs_from_maxmin: no maxage nor minage => empty result' ) ; + + # maxage alone $maxage = $NUMBER_200 ; @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; - ok( 0 == compare_lists( [ '1', '2' ], \@msgs ), 'msgs_from_maxmin: maxage++' ) ; + is_deeply( [ '1', '2' ], \@msgs , 'msgs_from_maxmin: maxage++' ) ; + + # maxage > minage -> intersection $minage = $NUMBER_100 ; @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; - ok( 0 == compare_lists( [ '2' ], \@msgs ), 'msgs_from_maxmin: -maxage++minage-' ) ; + is_deeply( [ '2' ], \@msgs , 'msgs_from_maxmin: -maxage++minage-' ) ; + + # maxage < minage -> union $minage = $NUMBER_300 ; @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; - ok( 0 == compare_lists( [ '1', '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++maxage-minage++' ) ; + is_deeply( [ '1', '2', '3' ], \@msgs, 'msgs_from_maxmin: ++maxage-minage++' ) ; + + + # minage alone $maxage = undef ; @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; - ok( 0 == compare_lists( [ '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++minage-' ) ; + is_deeply( [ '2', '3' ], \@msgs, 'msgs_from_maxmin: ++minage-' ) ; - note( 'Leaving tests_msgs_from_maxmin()' ) ; + + note( 'Leaving tests_msgs_from_maxmin()' ) ; return ; } @@ -9249,6 +10840,13 @@ sub copy_message ( $mysync->{ debug } or $mysync->{dry} ) and myprint( "msg $h1_fold/$h1_msg copying to $h2_fold $mysync->{dry_message} " . eta( $mysync ) . "\n" ) ; + if ( $mysync->{dry1} ) + { + $mysync->{ h1_nb_msg_processed } +=1 ; + $nb_msg_skipped_dry_mode += 1 ; + return ; + } + my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} || 0 ; my $h1_flags = $h1_fir_ref->{$h1_msg}->{'FLAGS'} || q{} ; my $h1_idate = $h1_fir_ref->{$h1_msg}->{'INTERNALDATE'} || q{} ; @@ -9294,7 +10892,7 @@ sub copy_message ( $mysync->{ debug } or $debugflags ) and myprint( "Host1: flags init msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ; - $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ; + $h1_flags = flags_for_host2( $mysync, $h1_flags, $permanentflags2 ) ; ( $mysync->{ debug } or $debugflags ) and myprint( "Host1: flags filt msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ; @@ -9447,7 +11045,7 @@ sub message_for_host2 ${ $string_ref } = $header . "\r\n" . ${ $string_ref } ; } - if ( ( defined $mysync->{ truncmess } ) and is_an_integer( $mysync->{ truncmess } ) ) + if ( ( defined $mysync->{ truncmess } ) and is_integer( $mysync->{ truncmess } ) ) { ${ $string_ref } = truncmess( ${ $string_ref }, $mysync->{ truncmess } ) ; } @@ -10094,20 +11692,6 @@ sub date_for_host2 return( $h1_date ) ; } -sub flags_for_host2 -{ - my( $h1_flags, $permanentflags2 ) = @_ ; - # RFC 2060: This flag can not be altered by any client - $h1_flags =~ s@\\Recent\s?@@xgi ; - my $h1_flags_re ; - if ( @regexflag and defined( $h1_flags_re = flags_regex( $h1_flags ) ) ) { - $h1_flags = $h1_flags_re ; - } - $h1_flags = flagscase( $h1_flags ) if $flagscase ; - $h1_flags = flags_filter( $h1_flags, $permanentflags2) if ( $permanentflags2 and $filterflags ) ; - - return( $h1_flags ) ; -} sub subject { @@ -10116,7 +11700,7 @@ sub subject my $header = extract_header( $string ) ; - if( $header =~ m/^Subject:\s*([^\n\r]*)\r?$/msx ) { + if( $header =~ m/^Subject:[ \t]*([^\n\r]*)\r?$/msx ) { #myprint( "MMM[$1]\n" ) ; $subject = $1 ; } @@ -10125,12 +11709,14 @@ sub subject sub tests_subject { - note( 'Entering tests_subject()' ) ; + note( 'Entering tests_subject()' ) ; ok( q{} eq subject( q{} ), 'subject: null') ; - ok( 'toto le hero' eq subject( 'Subject: toto le hero' ), 'subject: toto le hero') ; - ok( 'toto le hero' eq subject( 'Subject:toto le hero' ), 'subject: toto le hero blank') ; - ok( 'toto le hero' eq subject( "Subject:toto le hero\r\n" ), 'subject: toto le hero\r\n') ; + is( '', subject( 'Subject:' ), 'Subject:') ; + is( '', subject( "Subject:\r\n" ), 'Subject:\r\n') ; + ok( 'toto le hero' eq subject( 'Subject: toto le hero' ), 'Subject: toto le hero') ; + ok( 'toto le hero' eq subject( 'Subject:toto le hero' ), 'Subject:toto le hero') ; + ok( 'toto le hero' eq subject( "Subject:toto le hero\r\n" ), 'Subject: toto le hero\r\n') ; my $MESS ; $MESS = <<'EOF'; @@ -10169,13 +11755,24 @@ Subject: toto le hero EOF ok( q{} eq subject( $MESS ), 'subject: null but body could') ; + + $MESS = <<'EOF'; +From: lalala +Subject: +Date: zzzzzz + +Subject: toto le hero +EOF + is( '', subject( $MESS ), 'Subject:') ; + + + note( 'Leaving tests_subject()' ) ; return ; } # GlobVar -# $max_msg_size_in_bytes # $h2_uidguess # ... # @@ -10187,10 +11784,9 @@ sub append_message_on_host2 my $new_id ; if ( ! $mysync->{dry} ) { - $max_msg_size_in_bytes = max( $string_len, $max_msg_size_in_bytes ) ; $new_id = $mysync->{imap2}->append_string( $h2_fold, ${ $string_ref }, $h1_flags, $h1_date ) ; myprint( debugmemory( $mysync, " at A2" ) ) ; - if ( ! $new_id){ + if ( ! defined $new_id ){ my $subject = subject( ${ $string_ref } ) ; my $error_imap = $mysync->{imap2}->LastError || q{} ; my $error = "- msg $h1_fold/$h1_msg {$string_len} could not append ( Subject:[$subject], Date:[$h1_date], Size:[$h1_size], Flags:[$h1_flags] ) to folder $h2_fold: $error_imap\n" ; @@ -10210,6 +11806,7 @@ sub append_message_on_host2 $mysync->{ total_bytes_transferred } += $string_len ; $mysync->{ nb_msg_transferred } += 1 ; $mysync->{ h1_nb_msg_processed } +=1 ; + $mysync->{ biggest_message_transferred } = max( $string_len, $mysync->{ biggest_message_transferred } ) ; my $time_spent = timesince( $mysync->{begin_transfer_time} ) ; my $rate = bytes_display_string( $mysync->{total_bytes_transferred} / $time_spent ) ; @@ -10279,15 +11876,18 @@ sub sleep_if_needed { my( $mysync ) = shift ; - if ( ! $mysync ) { - return ; - } - # No need to go further if there is no limit set - if ( not ( $mysync->{maxmessagespersecond} - or $mysync->{maxbytespersecond} ) - ) { - return ; - } + if ( ! $mysync ) { + return ; + } + # No need to go further if there is no limit set + if ( + not ( + $mysync->{maxmessagespersecond} + or $mysync->{maxbytespersecond} + ) + ) { + return ; + } $mysync->{maxsleep} = defined $mysync->{maxsleep} ? $mysync->{maxsleep} : $MAX_SLEEP ; # Must be positive @@ -10360,7 +11960,7 @@ sub sleep_max_bytes sub tests_sleep_max_bytes { - note( 'Entering tests_sleep_max_bytes()' ) ; + note( 'Entering tests_sleep_max_bytes()' ) ; ok( 0 == sleep_max_bytes( 4000, 2, undef ), 'sleep_max_bytes: maxbytespersecond == undef => sleep 0' ) ; ok( 0 == sleep_max_bytes( 4000, 2, 0 ), 'sleep_max_bytes: maxbytespersecond = 0 => sleep 0') ; @@ -10371,7 +11971,7 @@ sub tests_sleep_max_bytes ok( 0 == sleep_max_bytes( 2000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max not reached => sleep 0') ; ok( 0 == sleep_max_bytes( -2000, 2, 1000 ), 'sleep_max_bytes: maxbytespersecond = 1k max not reached => sleep 0') ; - note( 'Leaving tests_sleep_max_bytes()' ) ; + note( 'Leaving tests_sleep_max_bytes()' ) ; return ; } @@ -10383,7 +11983,8 @@ sub delete_message_on_host1 if ( ! @h1_msg ) { return ; } delete_messages_on_any( $mysync, - $mysync->{imap1}, + $mysync->{ acc1 }, + $mysync->{ imap1 }, "Host1: $h1_fold", $expunge, $split1, @@ -10419,18 +12020,22 @@ sub tests_operators_and_exclam_precedence return ; } + sub delete_messages_on_any { - my( $mysync, $imap, $hostX_folder, $expunge, $split, @messages ) = @_ ; + # $acc is not used yet, + # + my( $mysync, $acc, $imap, $hostX_folder, $expunge, $split, @messages ) = @_ ; my $expunge_message = q{} ; my $dry_message = $mysync->{ dry_message } ; $expunge_message = 'and expunged' if ( $expunge ) ; # "Host1: msg " - $imap->Debug( 1 ) ; + # $imap->Debug( 1 ) ; - while ( my @messages_part = splice @messages, 0, $split ) + my @messages_to_mark_deleted = @messages ; + while ( my @messages_part = splice @messages_to_mark_deleted, 0, $split ) { foreach my $message ( @messages_part ) { @@ -10442,7 +12047,7 @@ sub delete_messages_on_any if ( defined $nb_deleted ) { # $nb_deleted is not accurate - $mysync->{ h1_nb_msg_deleted } += scalar @messages_part ; + $acc->{ nb_msg_deleted } += scalar @messages_part ; } else { @@ -10458,7 +12063,7 @@ sub delete_messages_on_any uidexpunge_or_expunge( $mysync, $imap, @messages ) ; } - $imap->Debug( 0 ) ; + #$imap->Debug( 0 ) ; return ; } @@ -10547,13 +12152,13 @@ sub tests_eta $mysync->{ begin_transfer_time } = time ; # Now $mysync->{ h1_nb_msg_processed } = 0 ; - is( "ETA: " . localtime( time ) . " 0 s 0/0 msgs left", + is( "ETA: " . localtimez( time ) . " 0 s 0/0 msgs left", eta( $mysync ), 'eta: no args => ETA: "Now" 0 s 0/0 msgs left' ) ; $mysync->{ h1_nb_msg_processed } = 1 ; $mysync->{ h1_nb_msg_start } = 2 ; - is( "ETA: " . localtime( time ) . " 0 s 1/2 msgs left", + is( "ETA: " . localtimez( time ) . " 0 s 1/2 msgs left", eta( $mysync ), 'eta: 1, 1, 2 => ETA: "Now" 0 s 1/2 msgs left' ) ; @@ -10584,7 +12189,7 @@ sub eta my $time_remaining = time_remaining( $time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_msg_transferred ) ; $mysync->{ debug } and myprint( "time_spent: $time_spent time_remaining: $time_remaining\n" ) ; my $nb_msg_remaining = $h1_nb_msg_start - $h1_nb_processed ; - my $eta_date = localtime( time + $time_remaining ) ; + my $eta_date = localtimez( time + $time_remaining ) ; return( mysprintf( 'ETA: %s %1.0f s %s/%s msgs left', $eta_date, $time_remaining, $nb_msg_remaining, $h1_nb_msg_start ) ) ; } @@ -11171,6 +12776,7 @@ sub touch } + sub tests_tmpdir_has_colon_bug { note( 'Entering tests_tmpdir_has_colon_bug()' ) ; @@ -11237,7 +12843,7 @@ sub tmpdir_fix_colon_bug myprint( "Old cache directory $cachedir_old still exists\n" ) ; $err++ ; }else{ - myprint( "Old cache directory $cachedir_old successfuly moved\n" ) ; + myprint( "Old cache directory $cachedir_old successfully moved\n" ) ; } } return( not $err ) ; @@ -11280,31 +12886,33 @@ sub cache_folder sub tests_filter_forbidden_characters { - note( 'Entering tests_filter_forbidden_characters()' ) ; + note( 'Entering tests_filter_forbidden_characters()' ) ; - ok( 'a_b' eq filter_forbidden_characters( 'a_b' ), 'filter_forbidden_characters: a_b -> a_b' ) ; - ok( 'a_b' eq filter_forbidden_characters( 'a*b' ), 'filter_forbidden_characters: a*b -> a_b' ) ; - ok( 'a_b' eq filter_forbidden_characters( 'a|b' ), 'filter_forbidden_characters: a|b -> a_b' ) ; - ok( 'a_b' eq filter_forbidden_characters( 'a?b' ), 'filter_forbidden_characters: a?b -> a_b' ) ; - ok( 'a_______b' eq filter_forbidden_characters( 'a*|?:"<>b' ), 'filter_forbidden_characters: a*|?:"<>b -> a_______b' ) ; + is( undef , filter_forbidden_characters( ), 'filter_forbidden_characters: no args -> undef' ) ; - SKIP: { - skip( 'Not on MSWin32', 1 ) if ( 'MSWin32' eq $OSNAME ) ; - ok( ( 'a b ' eq filter_forbidden_characters( 'a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b "' ) ; - } ; + is( 'a_b' , filter_forbidden_characters( 'a_b' ), 'filter_forbidden_characters: a_b -> a_b' ) ; + is( 'a_b' , filter_forbidden_characters( 'a*b' ), 'filter_forbidden_characters: a*b -> a_b' ) ; + is( 'a_b' , filter_forbidden_characters( 'a|b' ), 'filter_forbidden_characters: a|b -> a_b' ) ; + is( 'a_b' , filter_forbidden_characters( 'a?b' ), 'filter_forbidden_characters: a?b -> a_b' ) ; + is( 'a________b', filter_forbidden_characters( q{a*|?:"<>'b} ), q{filter_forbidden_characters: a*|?:"<>'b -> a________b} ) ; - SKIP: { - skip( 'Only on MSWin32', 2 ) if ( 'MSWin32' ne $OSNAME ) ; - ok( ( ' a b_' eq filter_forbidden_characters( ' a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b_"' ) ; - ok( ( ' a b_/ c d_' eq filter_forbidden_characters( ' a b / c d ' ) ), 'filter_forbidden_characters: " a b / c d " -> "a b_/ c d_"' ) ; - } ; - ok( 'a_b' eq filter_forbidden_characters( "a\tb" ), 'filter_forbidden_characters: a\tb -> a_b' ) ; - ok( "a_b" eq filter_forbidden_characters( "a\rb" ), 'filter_forbidden_characters: a\rb -> a_b' ) ; - ok( "a_b" eq filter_forbidden_characters( "a\nb" ), 'filter_forbidden_characters: a\nb -> a_b' ) ; - ok( "a_b" eq filter_forbidden_characters( "a\\b" ), 'filter_forbidden_characters: a\b -> a_b' ) ; + is( 'a_b_' , filter_forbidden_characters( 'a b ' ), 'filter_forbidden_characters: "a b " -> "a_b_"' ) ; - note( 'Leaving tests_filter_forbidden_characters()' ) ; + + is( 'a_b' , filter_forbidden_characters( "a\tb" ), 'filter_forbidden_characters: a\tb -> a_b' ) ; + is( "a_b" , filter_forbidden_characters( "a\rb" ), 'filter_forbidden_characters: a\rb -> a_b' ) ; + is( "a_b" , filter_forbidden_characters( "a\nb" ), 'filter_forbidden_characters: a\nb -> a_b' ) ; + is( "a_b" , filter_forbidden_characters( "a\\b" ), 'filter_forbidden_characters: a\b -> a_b' ) ; + + is( 'a-b' , filter_forbidden_characters( 'a-b' ), 'filter_forbidden_characters: a-b -> a-b' ) ; + is( 'a__-__-__-__-__b' , filter_forbidden_characters( 'aé-è-à -ç-Öb' ), 'filter_forbidden_characters: aé-è-à -ç-Öb -> a__-__-__-__-__b' ) ; + + is( 'abcdABCDwxyzWXYZ012789' , filter_forbidden_characters( 'abcdABCDwxyzWXYZ012789' ), + 'filter_forbidden_characters: abcdABCDwxyzWXYZ012789 -> abcdABCDwxyzWXYZ012789' ) ; + + + note( 'Leaving tests_filter_forbidden_characters()' ) ; return ; } @@ -11312,13 +12920,12 @@ sub filter_forbidden_characters { my $string = shift ; - if ( ! defined $string ) { return ; } + if ( ! defined $string ) { return ; } + + $string =~ s{[\Q*|?:"<>' \E\t\r\n\\]}{_}xg ; + # replace all non-ascii and control characters by _ + $string =~ s/[[:^ascii:][:cntrl:]]/_/xg ; - if ( 'MSWin32' eq $OSNAME ) { - # Move trailing whitespace to _ " a b /c d " -> " a b_/c d_" - $string =~ s{\ (/|$)}{_$1}xg ; - } - $string =~ s{[\Q*|?:"<>\E\t\r\n\\]}{_}xg ; #myprint( "[$string]\n" ) ; return( $string ) ; } @@ -11351,58 +12958,58 @@ sub convert_sep_to_slash sub tests_regexmess { - note( 'Entering tests_regexmess()' ) ; + note( 'Entering tests_regexmess()' ) ; - ok( 'blabla' eq regexmess( 'blabla' ), 'regexmess, no regexmess, nothing to do' ) ; + ok( 'blabla' eq regexmess( 'blabla' ), 'regexmess: no regexmess, nothing to do' ) ; @regexmess = ( 'lalala' ) ; - ok( not( defined regexmess( 'popopo' ) ), 'regexmess, bad regex lalala' ) ; + ok( not( defined regexmess( 'popopo' ) ), 'regexmess: bad regex lalala' ) ; @regexmess = ( 's/p/Z/g' ) ; - ok( 'ZoZoZo' eq regexmess( 'popopo' ), 'regexmess, s/p/Z/g' ) ; + ok( 'ZoZoZo' eq regexmess( 'popopo' ), 'regexmess: s/p/Z/g' ) ; @regexmess = ( 's{c}{C}gxms' ) ; ok("H1: abC\nH2: Cde\n\nBody abC" eq regexmess( "H1: abc\nH2: cde\n\nBody abc"), - 'regexmess, c->C'); + 'regexmess: c->C'); @regexmess = ( 's{\AFrom\ }{From:}gxms' ) ; ok( q{} eq regexmess(q{}), - 'From mbox 1 add colon blank'); + 'regexmess: From mbox 1 add colon blank'); ok( 'From:' eq regexmess('From '), - 'From mbox 2 add colo'); + 'regexmess: From mbox 2 add colo'); ok( "\n" . 'From ' eq regexmess("\n" . 'From '), - 'From mbox 3 add colo') ; + 'regexmess: From mbox 3 add colo') ; ok( "From: zzz\n" . 'From ' eq regexmess("From zzz\n" . 'From '), - 'From mbox 4 add colo') ; + 'regexmess: From mbox 4 add colo') ; @regexmess = ( 's{\AFrom\ [^\n]*(\n)?}{}gxms' ) ; ok( q{} eq regexmess(q{}), - 'From mbox 1 remove, blank'); + 'regexmess: From mbox 1 remove, blank'); ok( q{} eq regexmess('From '), - 'From mbox 2 remove'); + 'regexmess: From mbox 2 remove'); ok( "\n" . 'From ' eq regexmess("\n" . 'From '), - 'From mbox 3 remove'); + 'regexmess: From mbox 3 remove'); #myprint( "[", regexmess("From zzz\n" . 'From '), "]" ) ; ok( q{} . 'From ' eq regexmess("From zzz\n" . 'From '), - 'From mbox 4 remove'); + 'regexmess: From mbox 4 remove'); - ok( + is( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 From: @@ -11410,7 +13017,7 @@ From: Hello, Bye. EOM - eq regexmess( + , regexmess( <<'EOM' From zzz Date: Sat, 10 Jul 2010 05:34:45 -0700 @@ -11419,7 +13026,7 @@ From: Hello, Bye. EOM -), 'From mbox 5 remove'); + ), 'regexmess: From mbox 5 remove'); @regexmess = ( 's{\A((?:[^\n]+\n)+|)^Disposition-Notification-To:[^\n]*\n(\r?\n|.*\n\r?\n)}{$1$2}xms' ) ; # SUPER SUPER BEST! @@ -11460,7 +13067,7 @@ Disposition-Notification-To: Gilles LAMIRAL Hello, Bye. EOM -), + ), 'regexmess: 2 Delete header Disposition-Notification-To:'); ok( @@ -11480,7 +13087,7 @@ From: Hello, Bye. EOM -), + ), 'regexmess: 3 Delete header Disposition-Notification-To:'); ok( @@ -11500,7 +13107,7 @@ From: Disposition-Notification-To: Gilles LAMIRAL Bye. EOM -), + ), 'regexmess: 4 Delete header Disposition-Notification-To:'); @@ -11520,11 +13127,11 @@ From: Disposition-Notification-To: Gilles LAMIRAL Bye. EOM -), + ), 'regexmess: 5 Delete header Disposition-Notification-To:'); -ok( + ok( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 From: @@ -11542,10 +13149,10 @@ Hello, Disposition-Notification-To: Gilles LAMIRAL Bye. EOM -), + ), 'regexmess: 6 Delete header Disposition-Notification-To:'); -ok( + ok( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 From: @@ -11565,11 +13172,11 @@ Disposition-Notification-To: Gilles LAMIRAL Bye. EOM -), + ), 'regexmess: 7 Delete header Disposition-Notification-To:'); -ok( + ok( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 From: @@ -11589,7 +13196,7 @@ EOM 'regexmess: 8 Delete header Disposition-Notification-To:'); -ok( + ok( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 From: @@ -11607,12 +13214,12 @@ Hello, Disposition-Notification-To: Gilles LAMIRAL Bye. EOM -), + ), 'regexmess: 9 Delete header Disposition-Notification-To:'); -ok( + ok( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 From: @@ -11634,10 +13241,10 @@ Disposition-Notification-To: Gilles LAMIRAL Bye. EOM -), + ), 'regexmess: 10 Delete header Disposition-Notification-To:'); -ok( + ok( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 From: @@ -11662,7 +13269,7 @@ EOM ), 'regexmess: 11 Delete header Disposition-Notification-To:'); -ok( + ok( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 From: @@ -11688,15 +13295,15 @@ Disposition-Notification-To: Gilles LAMIRAL Bye. EOM -), + ), 'regexmess: 12 Delete header Disposition-Notification-To:'); -@regexmess = ( 's{\A(.*?(?! ^$))^Disposition-Notification-To:(.*?)$}{$1X-Disposition-Notification-To:$2}igxms' ) ; # BAD! -@regexmess = ( 's{\A((?:[^\n]+\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims' ) ; + @regexmess = ( 's{\A(.*?(?! ^$))^Disposition-Notification-To:(.*?)$}{$1X-Disposition-Notification-To:$2}igxms' ) ; # BAD! + @regexmess = ( 's{\A((?:[^\n]+\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims' ) ; -ok( + ok( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 From: @@ -11722,10 +13329,10 @@ Disposition-Notification-To: Gilles LAMIRAL Bye. EOM -), + ), 'regexmess: 13 Delete header Disposition-Notification-To:'); -ok( + ok( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 X-Disposition-Notification-To: Gilles LAMIRAL @@ -11753,10 +13360,10 @@ Disposition-Notification-To: Gilles LAMIRAL Bye. EOM -), + ), 'regexmess: 14 Delete header Disposition-Notification-To:'); -ok( + ok( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 X-Disposition-Notification-To: Gilles LAMIRAL @@ -11776,11 +13383,11 @@ Hello, Bye. EOM -), + ), 'regexmess: 15 Delete header Disposition-Notification-To:'); -ok( + ok( <<'EOM' Date: Sat, 10 Jul 2010 05:34:45 -0700 From: @@ -11800,10 +13407,10 @@ Hello, Bye. EOM -), + ), 'regexmess: 16 Delete header Disposition-Notification-To:'); -ok( + ok( <<'EOM' X-Disposition-Notification-To: Gilles LAMIRAL Date: Sat, 10 Jul 2010 05:34:45 -0700 @@ -11827,15 +13434,15 @@ EOM 'regexmess: 17 Delete header Disposition-Notification-To:'); @regexmess = ( 's/.{11}\K.*//gs' ) ; - is( "0123456789\n", regexmess( "0123456789\n" x 100 ), 'regexmess, truncate whole message after 11 characters' ) ; - is( "0123456789\n", regexmess( "0123456789\n" x 100_000 ), 'regexmess, truncate whole message after 11 characters ~ 1MB' ) ; + is( "0123456789\n", regexmess( "0123456789\n" x 100 ), 'regexmess: truncate whole message after 11 characters' ) ; + is( "0123456789\n", regexmess( "0123456789\n" x 100_000 ), 'regexmess: truncate whole message after 11 characters ~ 1MB' ) ; @regexmess = ( 's/.{10000}\K.*//gs' ) ; - is( "123456789\n" x 1000, regexmess( "123456789\n" x 100_000 ), 'regexmess, truncate whole message after 10000 characters ~ 1MB' ) ; + is( "123456789\n" x 1000, regexmess( "123456789\n" x 100_000 ), 'regexmess: truncate whole message after 10000 characters ~ 1MB' ) ; -@regexmess = ( 's/^(X-Ham-Report.*?\n)^X-/X-/sm' ) ; + @regexmess = ( 's/^(X-Ham-Report.*?\n)^X-/X-/sm' ) ; -is( + is( <<'EOM' X-Spam-Score: -1 X-Spam-Bar: / @@ -11848,7 +13455,7 @@ Hello, Bye. EOM , -regexmess( + regexmess( <<'EOM' X-Spam-Score: -1 X-Spam-Bar: / @@ -11868,20 +13475,247 @@ Hello, Bye. EOM -), - 'regexmess: 1 Delete header X-Ham-Report:'); + ), + 'regexmess: Delete header X-Ham-Report:'); # regex to play with Date: from the FAQ #@regexmess = 's{\A(.*?(?! ^$))^Date:(.*?)$}{$1Date:$2\nX-Date:$2}gxms' +# Change 8bit characters in whole email to X characters + @regexmess = ( 's{[\x80-\xff]}{X}gxms' ) ; + is( 'X-8bit: kaka 1 XX kiki', regexmess('X-8bit: kaka 1 ¤ kiki'), 'regexmess: 1 Change 8bit characters in whole email to X characters'); + +# Same change but using tr + @regexmess = ( 'tr [\x80-\xff] [X]' ) ; + is( 'X-8bit: kaka 1 XXXX kiki', regexmess('X-8bit: kaka 1 ¤£ kiki'), 'regexmess: 2 Change 8bit characters in whole email to X characters, using tr'); - note( 'Leaving tests_regexmess()' ) ; - return ; +# Add a final \r\n if missing + @regexmess = ( 's{(? +LaSuite: super + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +X-Spam-Report: caca +caca + caca +caca +LaSuite: super + +Hello, +Bye. +EOM + ), 'regexmess: 1 remove buggy X-Spam-Report: across several lines, not the final header'); + + + is( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +LaSuite: super +LaSuite2: super 2 + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +X-Spam-Report: caca +caca + caca +caca +LaSuite: super +LaSuite2: super 2 + +Hello, +Bye. +EOM + ), 'regexmess: 2 remove buggy X-Spam-Report: across several lines, not the final header'); + + + is( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +LaSuite: super +LaSuite2: super 2 + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +X-Spam-Report: caca +caca + caca +caca +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +LaSuite: super +LaSuite2: super 2 + +Hello, +Bye. +EOM + ), 'regexmess: 3 remove buggy X-Spam-Report: across several lines, first header'); + + + + + is( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +X-Spam-Report: caca +caca + caca +caca + +Hello, +Bye. +EOM + ), 'regexmess: 4 remove buggy X-Spam-Report: across several lines, final header'); + + + is( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + ), 'regexmess: 5 remove buggy X-Spam-Report: not there at all'); + + + is( +<<"EOM" +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +LaSuite: super\r +LaSuite2: super 2\r +\r +Hello,\r +Bye.\r +EOM + , regexmess( +<<"EOM" +X-Spam-Report: caca\r +caca\r + caca\r +caca\r +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +LaSuite: super\r +LaSuite2: super 2\r +\r +Hello,\r +Bye.\r +EOM + ), 'regexmess: 6 remove buggy X-Spam-Report: across several lines, first header, with \r'); + + + is( +<<"EOM" +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +LaSuite: super\r +LaSuite2: super 2\r +\r +Hello,\r +Bye.\r +EOM + , regexmess( +<<"EOM" +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +X-Spam-Report: caca\r +caca\r + caca\r +caca\r +LaSuite: super\r +LaSuite2: super 2\r +\r +Hello,\r +Bye.\r +EOM + ), 'regexmess: 7 remove buggy X-Spam-Report: across several lines, middle header, with \r'); + + + is( +<<"EOM" +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +\r +Hello,\r +Bye.\r +EOM + , regexmess( +<<"EOM" +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +X-Spam-Report: caca\r +caca\r + caca\r +caca\r +\r +Hello,\r +Bye.\r +EOM + ), 'regexmess: 8 remove buggy X-Spam-Report: across several lines, final header, with \r'); + + + undef @regexmess ; + note( 'Leaving tests_regexmess()' ) ; + return ; } sub regexmess @@ -12119,10 +13953,83 @@ EOM # Complex regular subexpression recursion limit (32766) exceeded with more lines # exit; - note( 'Leaving tests_skipmess()' ) ; + + undef @skipmess ; + note( 'Leaving tests_skipmess()' ) ; return ; } + +sub tests_skipmess_neg +{ + note( 'Entering tests_skipmess_neg()' ) ; + + + @skipmess = ('m{i}') ; + ok( 1 == skipmess( 'Hi!' ), 'skipmess: i string yes' ) ; + ok( 0 == skipmess( 'Ho!' ), 'skipmess: i string no' ) ; + + @skipmess = ('m{\A(?!.*i)}') ; + ok( 0 == skipmess( 'Hi!' ), 'skipmess: not i string no' ) ; + ok( 1 == skipmess( 'Ho!' ), 'skipmess: not i string yes' ) ; + + + @skipmess = ('m{\A(?!.*^From:[^\n]*tartanpion\@machin\.truc)}xms') ; + + ok( 0 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Bye. +EOM +), + 'skipmess: 1 not From tartanpion@machin.truc' ) ; + +ok( 1 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Bye. +EOM +), + 'skipmess: 2 not From tartanpion@machin.truc' ) ; + + + + + ok( 0 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + + From: +Bye. +EOM +), + 'skipmess: 3 not From tartanpion@machin.truc' ) ; + +ok( 1 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + + From: +Bye. +EOM +), + 'skipmess: 4 not From tartanpion@machin.truc' ) ; + + + + + undef @skipmess ; + note( 'Leaving tests_skipmess_neg()' ) ; + return ; +} + + sub skipmess { my ( $string ) = @_ ; @@ -12154,25 +14061,25 @@ sub tests_bytes_display_string is( 'NA', bytes_display_string( undef ), 'bytes_display_string: undef => NA' ) ; is( 'NA', bytes_display_string( 'blabla' ), 'bytes_display_string: blabla => NA' ) ; - ok( '0.000 KiB' eq bytes_display_string( 0 ), 'bytes_display_string: 0' ) ; - ok( '0.001 KiB' eq bytes_display_string( 1 ), 'bytes_display_string: 1' ) ; - ok( '0.010 KiB' eq bytes_display_string( 10 ), 'bytes_display_string: 10' ) ; - ok( '1.000 MiB' eq bytes_display_string( 1_048_575 ), 'bytes_display_string: 1_048_575' ) ; - ok( '1.000 MiB' eq bytes_display_string( 1_048_576 ), 'bytes_display_string: 1_048_576' ) ; + is( '0.000 KiB', bytes_display_string( 0 ), 'bytes_display_string: 0' ) ; + is( '0.001 KiB', bytes_display_string( 1 ), 'bytes_display_string: 1' ) ; + is( '0.010 KiB', bytes_display_string( 10 ), 'bytes_display_string: 10' ) ; + is( '1.000 MiB', bytes_display_string( 1_048_575 ), 'bytes_display_string: 1_048_575' ) ; + is( '1.000 MiB', bytes_display_string( 1_048_576 ), 'bytes_display_string: 1_048_576' ) ; - ok( '1.000 GiB' eq bytes_display_string( 1_073_741_823 ), 'bytes_display_string: 1_073_741_823 ' ) ; - ok( '1.000 GiB' eq bytes_display_string( 1_073_741_824 ), 'bytes_display_string: 1_073_741_824 ' ) ; + is( '1.000 GiB', bytes_display_string( 1_073_741_823 ), 'bytes_display_string: 1_073_741_823 ' ) ; + is( '1.000 GiB', bytes_display_string( 1_073_741_824 ), 'bytes_display_string: 1_073_741_824 ' ) ; - ok( '1.000 TiB' eq bytes_display_string( 1_099_511_627_775 ), 'bytes_display_string: 1_099_511_627_775' ) ; - ok( '1.000 TiB' eq bytes_display_string( 1_099_511_627_776 ), 'bytes_display_string: 1_099_511_627_776' ) ; + is( '1.000 TiB', bytes_display_string( 1_099_511_627_775 ), 'bytes_display_string: 1_099_511_627_775' ) ; + is( '1.000 TiB', bytes_display_string( 1_099_511_627_776 ), 'bytes_display_string: 1_099_511_627_776' ) ; - ok( '1.000 PiB' eq bytes_display_string( 1_125_899_906_842_623 ), 'bytes_display_string: 1_125_899_906_842_623' ) ; - ok( '1.000 PiB' eq bytes_display_string( 1_125_899_906_842_624 ), 'bytes_display_string: 1_125_899_906_842_624' ) ; + is( '1.000 PiB', bytes_display_string( 1_125_899_906_842_623 ), 'bytes_display_string: 1_125_899_906_842_623' ) ; + is( '1.000 PiB', bytes_display_string( 1_125_899_906_842_624 ), 'bytes_display_string: 1_125_899_906_842_624' ) ; - ok( '1024.000 PiB' eq bytes_display_string( 1_152_921_504_606_846_975 ), 'bytes_display_string: 1_152_921_504_606_846_975' ) ; - ok( '1024.000 PiB' eq bytes_display_string( 1_152_921_504_606_846_976 ), 'bytes_display_string: 1_152_921_504_606_846_976' ) ; + is( '1024.000 PiB', bytes_display_string( 1_152_921_504_606_846_975 ), 'bytes_display_string: 1_152_921_504_606_846_975' ) ; + is( '1024.000 PiB', bytes_display_string( 1_152_921_504_606_846_976 ), 'bytes_display_string: 1_152_921_504_606_846_976' ) ; - ok( '1048576.000 PiB' eq bytes_display_string( 1_180_591_620_717_411_303_424 ), 'bytes_display_string: 1_180_591_620_717_411_303_424' ) ; + is( '1048576.000 PiB', bytes_display_string( 1_180_591_620_717_411_303_424 ), 'bytes_display_string: 1_180_591_620_717_411_303_424' ) ; #myprint( bytes_display_string( 1_180_591_620_717_411_303_424 ), "\n" ) ; note( 'Leaving tests_bytes_display_string()' ) ; @@ -12257,27 +14164,31 @@ sub useheader_suggestion return ; } -sub stats +sub do_and_print_stats { my $mysync = shift ; - if ( ! $mysync->{stats} ) { + if ( ! $mysync->{can_do_stats} ) { return ; } my $timeend = time ; my $timediff = $timeend - $mysync->{timestart} ; - my $timeend_str = localtime $timeend ; + my $timeend_str = localtimez( $timeend ) ; + + my $cpu_time = cpu_time( $mysync ) ; + my $cpu_percent = cpu_percent( $mysync, $cpu_time, $timediff ) ; + my $cpu_percent_global = cpu_percent_global( $mysync, $cpu_percent ) ; my $memory_consumption_at_end = memory_consumption( ) || 0 ; my $memory_consumption_at_start = $mysync->{ memory_consumption_at_start } || 0 ; - my $memory_ratio = ($max_msg_size_in_bytes) ? - mysprintf('%.1f', $memory_consumption_at_end / $max_msg_size_in_bytes) : 'NA' ; + my $memory_ratio = ( $mysync->{ biggest_message_transferred } ) ? + mysprintf( '%.1f', $memory_consumption_at_end / $mysync->{ biggest_message_transferred } ) : 'NA' ; # my $useheader_suggestion = useheader_suggestion( $mysync ) ; myprint( "++++ Statistics\n" ) ; - myprint( "Transfer started on : $timestart_str\n" ) ; + myprint( "Transfer started on : $mysync->{ timestart_str }\n" ) ; myprint( "Transfer ended on : $timeend_str\n" ) ; myprintf( "Transfer time : %.1f sec\n", $timediff ) ; myprint( "Folders synced : $h1_folders_wanted_ct/$h1_folders_wanted_nb synced\n" ) ; @@ -12285,8 +14196,8 @@ sub stats myprint( "(could be $nb_msg_skipped_dry_mode without dry mode)" ) if ( $mysync->{dry} ) ; myprint( "\n" ) ; myprint( "Messages skipped : $mysync->{ nb_msg_skipped }\n" ) ; - myprint( "Messages found duplicate on host1 : $h1_nb_msg_duplicate\n" ) ; - myprint( "Messages found duplicate on host2 : $h2_nb_msg_duplicate\n" ) ; + myprint( "Messages found duplicate on host1 : $mysync->{ acc1 }->{ nb_msg_duplicate }\n" ) ; + myprint( "Messages found duplicate on host2 : $mysync->{ acc2 }->{ nb_msg_duplicate }\n" ) ; myprint( "Messages found crossduplicate on host2 : $mysync->{ h2_nb_msg_crossdup }\n" ) ; myprint( "Messages void (noheader) on host1 : $mysync->{ h1_nb_msg_noheader } ", useheader_suggestion( $mysync ), "\n" ) ; myprint( "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n" ) ; @@ -12294,8 +14205,8 @@ sub stats nb_messages_in_2_not_in_1( $mysync ) ; myprintf( "Messages found in host1 not in host2 : %s messages\n", $mysync->{ nb_messages_in_1_not_in_2 } ) ; myprintf( "Messages found in host2 not in host1 : %s messages\n", $mysync->{ nb_messages_in_2_not_in_1 } ) ; - myprint( "Messages deleted on host1 : $mysync->{ h1_nb_msg_deleted }\n" ) ; - myprint( "Messages deleted on host2 : $h2_nb_msg_deleted\n" ) ; + myprint( "Messages deleted on host1 : $mysync->{ acc1 }->{ nb_msg_deleted }\n" ) ; + myprint( "Messages deleted on host2 : $mysync->{ acc2 }->{ nb_msg_deleted }\n" ) ; myprintf( "Total bytes transferred : %s (%s)\n", $mysync->{total_bytes_transferred}, bytes_display_string( $mysync->{total_bytes_transferred} ) ) ; @@ -12311,10 +14222,10 @@ sub stats $memory_consumption_at_end / $KIBI / $KIBI, $memory_consumption_at_start / $KIBI / $KIBI ) ; myprint( "Load end is : " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $mysync->{cpu_number} cores\n" ) ; - - myprintf("Biggest message : %s bytes (%s)\n", - $max_msg_size_in_bytes, - bytes_display_string( $max_msg_size_in_bytes) ) ; + myprint( "CPU time and %cpu : $cpu_time sec $cpu_percent %cpu $cpu_percent_global %allcpus\n" ) ; + myprintf("Biggest message transferred : %s bytes (%s)\n", + $mysync->{ biggest_message_transferred }, + bytes_display_string( $mysync->{ biggest_message_transferred } ) ) ; myprint( "Memory/biggest message ratio : $memory_ratio\n" ) ; if ( $mysync->{ foldersizesatend } and $mysync->{ foldersizes } ) { @@ -12440,7 +14351,7 @@ sub load_modules } - +# Globals: $skipsize $wholeheaderifneeded sub parse_header_msg { my ( $mysync, $imap, $m_uid, $s_heads, $s_fir, $side, $s_hash ) = @_ ; @@ -12463,9 +14374,7 @@ sub parse_header_msg #myprint( Data::Dumper->Dump( [ $head, \%useheader ] ) ) ; - my $headstr ; - - $headstr = header_construct( $head, $side, $m_uid ) ; + my $headstr = header_construct( $mysync, $head, $side, $m_uid ) ; if ( ( ! $headstr ) and ( $mysync->{addheader} ) and ( $side eq 'Host1' ) ) { my $header = add_header( $m_uid ) ; @@ -12481,49 +14390,124 @@ sub parse_header_msg my $idate = $s_fir->{$m_uid}->{'INTERNALDATE'} ; $size = length $headstr unless ( $size ) ; my $m_md5 = md5_base64( $headstr ) ; - $mysync->{ debug } and myprint( "$side: uid $m_uid sig $m_md5 size $size idate $idate\n" ) ; + my $key ; - if ($skipsize) { + if ( $skipsize ) { $key = "$m_md5"; } else { $key = "$m_md5:$size"; } - # 0 return code is used to identify duplicate message hash - return 0 if exists $s_hash->{"$key"}; - $s_hash->{"$key"}{'5'} = $m_md5; - $s_hash->{"$key"}{'s'} = $size; - $s_hash->{"$key"}{'D'} = $idate; - $s_hash->{"$key"}{'F'} = $flags; - $s_hash->{"$key"}{'m'} = $m_uid; - return( 1 ) ; + if ( exists $s_hash->{"$key"} ) + { + # 0 return code is used to identify duplicate message hash + my $dup_ref = $s_hash->{"$key"}->{'U'} ; + my $num = scalar( @{ $dup_ref } ) ; + push( @{ $dup_ref }, $m_uid ) ; + my $keydup = "$key#$num" ; + $mysync->{ debug } and myprint( "$side: uid $m_uid sig $keydup size $size idate $idate dup @{ $dup_ref }\n" ) ; + if ( $mysync->{ syncduplicates } ) + { + $s_hash->{"$keydup"}{'5'} = $m_md5 ; + $s_hash->{"$keydup"}{'s'} = $size ; + $s_hash->{"$keydup"}{'D'} = $idate ; + $s_hash->{"$keydup"}{'F'} = $flags ; + $s_hash->{"$keydup"}{'m'} = $m_uid ; + } + return 0 ; + } + else + { + $s_hash->{"$key"}{'5'} = $m_md5 ; + $s_hash->{"$key"}{'s'} = $size ; + $s_hash->{"$key"}{'D'} = $idate ; + $s_hash->{"$key"}{'F'} = $flags ; + $s_hash->{"$key"}{'m'} = $m_uid ; + $s_hash->{"$key"}{'U'} = [ $m_uid ] ; # ? or [ ] ? + $mysync->{ debug } and myprint( "$side: uid $m_uid sig $key size $size idate $idate\n" ) ; + return( 1 ) ; + } + + # we should not be here + return ; } +sub tests_header_construct +{ + note( 'Entering tests_header_construct()' ) ; + + is( undef, header_construct( ), 'header_construct: no args => undef' ) ; + my $mysync = {} ; + my $head = { + 'key1' => [ 'val1_key1' ] + } ; + is( undef, header_construct( $mysync, $head, 'Host1', '1' ), 'header_construct: key1 val1_key1 no useheader => undef' ) ; + + $mysync->{useheader}->{ 'KEY1' } = 1 ; + is( 'KEY1: VAL1_KEY1', header_construct( $mysync, $head, 'Host1', '1' ), 'header_construct: key1 val1_key1 => KEY1: VAL1_KEY1' ) ; + + + + $head = { + 'key1' => [ 'val1_key1', 'val3_key1', 'val2_key1' ] + } ; + is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', '1' ), + 'header_construct: key1 val1_key1 val3_key1 val2_key1 => KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1' ) ; + + $head = { + 'key1' => [ 'val1_key1', 'val3_key1', ' val2_key1' ] + } ; + is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', '1' ), + 'header_construct: key1 val1_key1 val3_key1 val2_key1 => KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1' ) ; + + $mysync->{useheader}->{ 'ALL' } = 1 ; + + is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', '1' ), + 'header_construct: key1 val1_key1 val3_key1 val2_key1 useheader ALL => KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1' ) ; + + $mysync->{skipheader} = 'key1' ; + is( undef, header_construct( $mysync, $head, 'Host1', '1' ), + 'header_construct: key1 val1_key1 val3_key1 val2_key1 useheader ALL => undef' ) ; + + $head = { + 'key1' => [ 'val1_key1', 'val3_key1', ' val2_key1' ], + 'key2' => [ 'val1_key2', 'val3_key2', ' val2_key2' ] + } ; + is( 'KEY2: VAL1_KEY2KEY2: VAL2_KEY2KEY2: VAL3_KEY2', header_construct( $mysync, $head, 'Host1', '1' ), + 'header_construct: ... useheader ALL skipheader key1 => KEY2: VAL1_KEY2KEY2: VAL2_KEY2KEY2: VAL3_KEY2' ) ; + + + note( 'Leaving tests_header_construct()' ) ; + return ; +} + + +# No global in header_construct sub header_construct { + my( $mysync, $head, $side, $m_uid ) = @_ ; - my( $head, $side, $m_uid ) = @_ ; - - my $headstr ; + my @headstr ; foreach my $h ( sort keys %{ $head } ) { - next if ( not ( exists $useheader{ uc $h } ) - and ( not exists $useheader{ 'ALL' } ) + next if ( not ( exists $mysync->{useheader}->{ uc $h } ) + and ( not exists $mysync->{useheader}->{ 'ALL' } ) ) ; - foreach my $val ( sort @{$head->{$h}} ) { + foreach my $val ( @{$head->{$h}} ) { my $H = header_line_normalize( $h, $val ) ; # show stuff in debug mode - $sync->{ debug } and myprint( "$side uid $m_uid header [$H]", "\n" ) ; + $mysync->{ debug } and myprint( "$side uid $m_uid header [$H]", "\n" ) ; - if ($skipheader and $H =~ m/$skipheader/xi) { - $sync->{ debug } and myprint( "$side uid $m_uid skipping header [$H]\n" ) ; + if ( $mysync->{skipheader} and $H =~ m/$mysync->{skipheader}/xi) { + $mysync->{ debug } and myprint( "$side uid $m_uid skipping header [$H]\n" ) ; next ; } - $headstr .= "$H" ; + push @headstr, $H ; } } + my $headstr = join( '', sort @headstr ) || undef ; return( $headstr ) ; } @@ -12655,7 +14639,6 @@ sub tests_nthline is( q{}, nthline( 'W/tmp/tests/noexist.txt', 2 ), 'nthline: 2nd getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'nthline: mkpath W/tmp/tests/' ) ; - is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/nthline.txt' ), 'nthline: put L1\nL2\nL3\nL4\n in W/tmp/tests/nthline.txt' ) ; is( 'L3' , nthline( 'W/tmp/tests/nthline.txt', 3 ), 'nthline: get L3 from W/tmp/tests/nthline.txt' ) ; @@ -12689,21 +14672,44 @@ sub nthline } } +sub tests_file_to_array +{ + note( 'Entering tests_file_to_array()' ) ; + + is( undef, file_to_array( ), 'file_to_array: no args => undef' ) ; + is( undef, file_to_array( '/noexist' ), 'file_to_array: /noexist => undef' ) ; + is( undef, file_to_array( '/' ), 'file_to_array: reading a directory => undef' ) ; + + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'file_to_array: mkpath W/tmp/tests/' ) ; + is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/file_to_array.txt' ), 'file_to_array: put L1\nL2\nL3\nL4\n in W/tmp/tests/file_to_array.txt' ) ; + is_deeply( [ "L1\n", "L2\n", "L3\n", "L4\n" ] , [ file_to_array( 'W/tmp/tests/file_to_array.txt' ) ], 'file_to_array: get back L1\n L2\n L3\n L4\n from W/tmp/tests/file_to_array.txt' ) ; + + note( 'Leaving tests_file_to_array()' ) ; + return ; +} -# Should be unit tested and then be used by file_to_string, refactoring file_to_string sub file_to_array { my( $file ) = shift ; + if ( ! $file ) { return ; } + if ( ! -e $file ) { return ; } + if ( ! -f $file ) { return ; } + if ( ! -r $file ) { return ; } + my @string ; - open my $FILE, '<', $file or do { + if ( open my $FILE, '<', $file ) + { + @string = <$FILE> ; + close $FILE ; + return( @string ) ; + } + else + { myprint( "Error reading file $file : $OS_ERROR\n" ) ; return ; - } ; - @string = <$FILE> ; - close $FILE ; - return( @string ) ; + } } @@ -12735,15 +14741,8 @@ sub file_to_string if ( ! -e $file ) { return ; } if ( ! -f $file ) { return ; } if ( ! -r $file ) { return ; } - my @string ; - if ( open my $FILE, '<', $file ) { - @string = <$FILE> ; - close $FILE ; - return( join q{}, @string ) ; - }else{ - myprint( "Error reading file $file : $OS_ERROR\n" ) ; - return ; - } + + return( join q{}, file_to_array( $file ) ) ; } @@ -13157,7 +15156,7 @@ sub tests_version_from_rcs { note( 'Entering tests_version_from_rcs()' ) ; - is( undef, version_from_rcs( ), 'version_from_rcs: no args => UNKNOWN' ) ; + is( undef, version_from_rcs( ), 'version_from_rcs: no args => undef' ) ; is( 1.831, version_from_rcs( q{imapsync,v 1.831 2017/08/27} ), 'version_from_rcs: imapsync,v 1.831 2017/08/27 => 1.831' ) ; is( 'UNKNOWN', version_from_rcs( 1.831 ), 'version_from_rcs: 1.831 => UNKNOWN' ) ; @@ -13221,47 +15220,104 @@ sub tests_cpu_number { note( 'Entering tests_cpu_number()' ) ; - is( 1, is_an_integer( cpu_number( ) ), "cpu_number: is_an_integer" ) ; + is( 1, is_integer( cpu_number( ) ), "cpu_number: is_integer" ) ; ok( 1 <= cpu_number( ), "cpu_number: 1 or more" ) ; is( 1, cpu_number( 1 ), "cpu_number: 1 => 1" ) ; is( 1, cpu_number( $MINUS_ONE ), "cpu_number: -1 => 1" ) ; is( 1, cpu_number( 'lalala' ), "cpu_number: lalala => 1" ) ; is( $NUMBER_42, cpu_number( $NUMBER_42 ), "cpu_number: $NUMBER_42 => $NUMBER_42" ) ; + + note( "cpu_number = " . cpu_number( ) . "\n" ) ; + note( "hostname = " . hostname( ) . "\n" ) ; + SKIP: { + if ( ! ( 'i005' eq hostname() ) ) + { + skip( 'cpu_number on host != i005 (FreeBSD)', 1 ) ; + } + is( 4, cpu_number( ), "cpu_number: on i005 (FreeBSD) => 4" ) ; + } ; + + SKIP: { + if ( ! ( 'petite' eq hostname() ) ) + { + skip( 'cpu_number on host != petite (Linux)', 1 ) ; + } + is( 2, cpu_number( ), "cpu_number: on petite (Linux) => 2" ) ; + } ; + + SKIP: { + if ( ! ( skip_macosx( ) ) ) + { + skip( 'cpu_number on host != polarhome macosx (Darwin MacOS X 10.7.5 Lion)', 1 ) ; + } + is( 2, cpu_number( ), "cpu_number: on polarhome macosx (Darwin MacOS X 10.7.5 Lion) => 2" ) ; + } ; + + SKIP: { + if ( ! ( 'pcHPDV7-HP' eq hostname() ) ) + { + skip( 'cpu_number on host != pcHPDV7-HP (Windows 7, 64bits)', 1 ) ; + } + is( 2, cpu_number( ), "cpu_number: on pcHPDV7-HP (Windows 7, 64bits) => 2" ) ; + } ; + + SKIP: { + if ( ! ( 'CUILLERE' eq hostname() ) ) + { + skip( 'cpu_number on host != CUILLERE (Windows XP, 32bits)', 1 ) ; + } + is( 1, cpu_number( ), "cpu_number: on CUILLERE (Windows XP, 32bits) => 1" ) ; + } ; + + note( 'Leaving tests_cpu_number()' ) ; return ; } -sub cpu_number -{ + +sub cpu_number { my $cpu_number_forced = shift ; # Well, here 1 is better than 0 or undef my $cpu_number = 1 ; # Default value, erased if better found my @cpuinfo ; - if ( $ENV{"NUMBER_OF_PROCESSORS"} ) { + if ( $ENV{"NUMBER_OF_PROCESSORS"} ) + { # might be under a Windows system $cpu_number = $ENV{"NUMBER_OF_PROCESSORS"} ; - $sync->{ debug } and myprint( "Number of processors found by env var NUMBER_OF_PROCESSORS: $cpu_number\n" ) ; - }elsif ( 'darwin' eq $OSNAME or 'freebsd' eq $OSNAME ) { + #myprint( "Number of processors found by env var NUMBER_OF_PROCESSORS: $cpu_number\n" ) ; + } + + if ( 'darwin' eq $OSNAME ) + { $cpu_number = backtick( "sysctl -n hw.ncpu" ) ; chomp( $cpu_number ) ; - $sync->{ debug } and myprint( "Number of processors found by cmd 'sysctl -n hw.ncpu': $cpu_number\n" ) ; - }elsif ( ! -e '/proc/cpuinfo' ) { - $sync->{ debug } and myprint( "Number of processors not found so I might assume there is only 1\n" ) ; - $cpu_number = 1 ; - }elsif( @cpuinfo = file_to_array( '/proc/cpuinfo' ) ) { - $cpu_number = grep { /^processor/mxs } @cpuinfo ; - $sync->{ debug } and myprint( "Number of processors found via /proc/cpuinfo: $cpu_number\n" ) ; + #myprint( "Number of processors found by cmd 'sysctl -n hw.ncpu': $cpu_number\n" ) ; } - - if ( defined $cpu_number_forced ) { + + if ( 'freebsd' eq $OSNAME ) + { + $cpu_number = backtick( "sysctl -n kern.smp.cpus" ) ; + chomp( $cpu_number ) ; + #myprint( "Number of processors found by cmd 'sysctl -n kern.smp.cpus': $cpu_number\n" ) ; + } + + if ( 'linux' eq $OSNAME && -e '/proc/cpuinfo' ) + { + @cpuinfo = file_to_array( '/proc/cpuinfo' ) ; + $cpu_number = grep { /^processor/mxs } @cpuinfo ; + #myprint( "Number of processors found via /proc/cpuinfo: $cpu_number\n" ) ; + } + + if ( defined $cpu_number_forced ) + { $cpu_number = $cpu_number_forced ; } + return( integer_or_1( $cpu_number ) ) ; } - sub tests_integer_or_1 { note( 'Entering tests_integer_or_1()' ) ; @@ -13279,33 +15335,33 @@ sub tests_integer_or_1 sub integer_or_1 { my $number = shift ; - if ( is_an_integer( $number ) ) { + if ( is_integer( $number ) ) { return $number ; } # else return 1 ; } -sub tests_is_an_integer +sub tests_is_integer { - note( 'Entering tests_is_an_integer()' ) ; + note( 'Entering tests_is_integer()' ) ; - is( undef, is_an_integer( ), 'is_an_integer: no args => undef ' ) ; - ok( is_an_integer( 1 ), 'is_an_integer: 1 => yes ') ; - ok( is_an_integer( $NUMBER_42 ), 'is_an_integer: 42 => yes ') ; - ok( is_an_integer( "$NUMBER_42" ), 'is_an_integer: "$NUMBER_42" => yes ') ; - ok( is_an_integer( '42' ), 'is_an_integer: "42" => yes ') ; - ok( is_an_integer( $NUMBER_104_857_600 ), 'is_an_integer: 104_857_600 => yes') ; - ok( is_an_integer( "$NUMBER_104_857_600" ), 'is_an_integer: "$NUMBER_104_857_600" => yes') ; - ok( is_an_integer( '104857600' ), 'is_an_integer: 104857600 => yes') ; - ok( ! is_an_integer( 'blabla' ), 'is_an_integer: blabla => no' ) ; - ok( ! is_an_integer( q{} ), 'is_an_integer: empty string => no' ) ; + is( undef, is_integer( ), 'is_integer: no args => undef ' ) ; + ok( is_integer( 1 ), 'is_integer: 1 => yes ') ; + ok( is_integer( $NUMBER_42 ), 'is_integer: 42 => yes ') ; + ok( is_integer( "$NUMBER_42" ), 'is_integer: "$NUMBER_42" => yes ') ; + ok( is_integer( '42' ), 'is_integer: "42" => yes ') ; + ok( is_integer( $NUMBER_104_857_600 ), 'is_integer: 104_857_600 => yes') ; + ok( is_integer( "$NUMBER_104_857_600" ), 'is_integer: "$NUMBER_104_857_600" => yes') ; + ok( is_integer( '104857600' ), 'is_integer: 104857600 => yes') ; + ok( ! is_integer( 'blabla' ), 'is_integer: blabla => no' ) ; + ok( ! is_integer( q{} ), 'is_integer: empty string => no' ) ; - note( 'Leaving tests_is_an_integer()' ) ; + note( 'Leaving tests_is_integer()' ) ; return ; } -sub is_an_integer +sub is_integer { my $number = shift ; if ( ! defined $number ) { return ; } @@ -13470,48 +15526,38 @@ sub tests_load_and_delay is( undef, load_and_delay( ), 'load_and_delay: no args => undef ' ) ; is( undef, load_and_delay( 1 ), 'load_and_delay: not 4 args => undef ' ) ; is( undef, load_and_delay( 0, 1, 1, 1 ), 'load_and_delay: division per 0 => undef ' ) ; - is( 0, load_and_delay( 1, 1, 1, 1 ), 'load_and_delay: one core, loads are all 1 => ok ' ) ; - is( 0, load_and_delay( 1, 1, 1, 1, 'lalala' ), 'load_and_delay: five arguments is ok' ) ; - is( 0, load_and_delay( 2, 2, 2, 2 ), 'load_and_delay: two core, loads are all 2 => ok ' ) ; - is( 0, load_and_delay( 2, 2, 4, 5 ), 'load_and_delay: two core, load1m is 2 => ok ' ) ; -# Old behavior, rather strict - # is( 0, load_and_delay( 1, 0, 0, 0 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ; - # is( 0, load_and_delay( 1, 0, 0, 2 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ; - # is( 0, load_and_delay( 1, 0, 2, 0 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ; - # is( 0, load_and_delay( 1, 0, 2, 2 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; - # is( 1, load_and_delay( 1, 2, 0, 0 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=0 => 1 ' ) ; - # is( 1, load_and_delay( 1, 2, 0, 2 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=2 => 1 ' ) ; - # is( 5, load_and_delay( 1, 2, 2, 0 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=0 => 5 ' ) ; - # is( 15, load_and_delay( 1, 2, 2, 2 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=2 => 15 ' ) ; +# ( $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) - # is( 0, load_and_delay( 4, 0, 2, 2 ), 'load_and_delay: four core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; - # is( 1, load_and_delay( 4, 8, 0, 0 ), 'load_and_delay: four core, load1m=2 load5m=0 load15m=0 => 1 ' ) ; - # is( 1, load_and_delay( 4, 8, 0, 2 ), 'load_and_delay: four core, load1m=2 load5m=0 load15m=2 => 1 ' ) ; - # is( 5, load_and_delay( 4, 8, 8, 0 ), 'load_and_delay: four core, load1m=2 load5m=2 load15m=0 => 5 ' ) ; - # is( 15, load_and_delay( 4, 8, 8, 8 ), 'load_and_delay: four core, load1m=2 load5m=2 load15m=2 => 15 ' ) ; + is( 0, load_and_delay( 1, 1, 1, 1 ), 'load_and_delay: one core, loads are all 1 => ok ' ) ; + is( 0, load_and_delay( 1, 1, 1, 1, 'lalala' ), 'load_and_delay: five arguments is ok' ) ; + is( 0, load_and_delay( 2, 2, 2, 2 ), 'load_and_delay: two core, loads are all 2 => ok ' ) ; + is( 0, load_and_delay( 2, 2, 4, 5 ), 'load_and_delay: two core, load1m is 2 => ok ' ) ; -# New behavior, tolerate more load - is( 0, load_and_delay( 1, 0, 0, 0 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ; - is( 0, load_and_delay( 1, 0, 0, 2 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ; - is( 0, load_and_delay( 1, 0, 2, 0 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ; - is( 0, load_and_delay( 1, 0, 2, 2 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; - is( 0, load_and_delay( 1, 2, 0, 0 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=0 => 1 ' ) ; - is( 0, load_and_delay( 1, 2, 0, 2 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=2 => 1 ' ) ; - is( 0, load_and_delay( 1, 2, 2, 0 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=0 => 5 ' ) ; - is( 0, load_and_delay( 1, 2, 2, 2 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=2 => 15 ' ) ; + is( 0, load_and_delay( 1, 0, 0, 0 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 0, 0, 2 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 1, 0, 2, 0 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 0, 2, 2 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 1, 0, 3, 3 ), 'load_and_delay: one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 1, 0, 4, 4 ), 'load_and_delay: one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 1, 2, 0, 0 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 2, 0, 2 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 1, 2, 2, 0 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 2, 2, 2 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 1, 2.9, 2.9, 2.9 ), 'load_and_delay: one core, load1m=2.9 load5m=2.9 load15m=2.9 => 0 ' ) ; + + is( 0, load_and_delay( 1, 3, 0, 0 ), 'load_and_delay: one core, load1m=3 load5m=0 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 3, 2.9, 2.9 ), 'load_and_delay: one core, load1m=3 load5m=2.9 load15m=2.9 => 0 ' ) ; + is( 0, load_and_delay( 1, 3, 3, 2.9 ), 'load_and_delay: one core, load1m=3 load5m=3 load15m=2.9 => 0 ' ) ; + is( 0, load_and_delay( 1, 3, 3, 3 ), 'load_and_delay: one core, load1m=3 load5m=3 load15m=3 => 0 ' ) ; + + is( 1, load_and_delay( 1, 6, 0, 0 ), 'load_and_delay: one core, load1m=3 load5m=0 load15m=0 => 1 ' ) ; + is( 1, load_and_delay( 1, 6, 5.9, 5.9 ), 'load_and_delay: one core, load1m=3 load5m=2.9 load15m=2.9 => 1 ' ) ; + is( 5, load_and_delay( 1, 6, 6, 5.9 ), 'load_and_delay: one core, load1m=3 load5m=3 load15m=2.9 => 5 ' ) ; + is( 15, load_and_delay( 1, 6, 6, 6 ), 'load_and_delay: one core, load1m=3 load5m=3 load15m=3 => 15 ' ) ; - is( 1, load_and_delay( 1, 4, 0, 0 ), 'load_and_delay: one core, load1m=4 load5m=0 load15m=0 => 1 ' ) ; - is( 1, load_and_delay( 1, 4, 0, 4 ), 'load_and_delay: one core, load1m=4 load5m=0 load15m=4 => 1 ' ) ; - is( 5, load_and_delay( 1, 4, 4, 0 ), 'load_and_delay: one core, load1m=4 load5m=4 load15m=0 => 5 ' ) ; - is( 15, load_and_delay( 1, 4, 4, 4 ), 'load_and_delay: one core, load1m=4 load5m=4 load15m=4 => 15 ' ) ; - is( 0, load_and_delay( 4, 0, 9, 9 ), 'load_and_delay: four core, load1m=0 load5m=9 load15m=9 => 0 ' ) ; - is( 1, load_and_delay( 4, 9, 0, 0 ), 'load_and_delay: four core, load1m=9 load5m=0 load15m=0 => 1 ' ) ; - is( 1, load_and_delay( 4, 9, 0, 9 ), 'load_and_delay: four core, load1m=9 load5m=0 load15m=9 => 1 ' ) ; - is( 5, load_and_delay( 4, 9, 9, 0 ), 'load_and_delay: four core, load1m=9 load5m=9 load15m=0 => 5 ' ) ; - is( 15, load_and_delay( 4, 9, 9, 9 ), 'load_and_delay: four core, load1m=9 load5m=9 load15m=9 => 15 ' ) ; note( 'Leaving tests_load_and_delay()' ) ; return ; @@ -13531,12 +15577,123 @@ sub load_and_delay # Let divide by number of cores ( $avg_1_min, $avg_5_min, $avg_15_min ) = map { $_ / $cpu_num } ( $avg_1_min, $avg_5_min, $avg_15_min ) ; # One of avg ok => ok, for now it is a OR - if ( $avg_1_min <= 2 ) { return 0 ; } - if ( $avg_5_min <= 2 ) { return 1 ; } # Retry in 1 minute - if ( $avg_15_min <= 2 ) { return 5 ; } # Retry in 5 minutes + if ( $avg_1_min < 6 ) { return 0 ; } + if ( $avg_5_min < 6 ) { return 1 ; } # Retry in 1 minute + if ( $avg_15_min < 6 ) { return 5 ; } # Retry in 5 minutes return 15 ; # Retry in 15 minutes } + +sub tests_cpu_time +{ + note( 'Entering tests_cpu_time()' ) ; + + ok( is_number( cpu_time( ) ), 'cpu_time: no args => a number' ) ; + + my $mysync = { } ; + $mysync->{ debug } = 1 ; + ok( is_number( cpu_time( $mysync ) ), 'cpu_time: {} => a number' ) ; + + note( 'Leaving tests_cpu_time()' ) ; + return ; +} + +sub cpu_time +{ + my $mysync = shift ; + + my @cpu_times = times ; + if ( ! @cpu_times ) { return ; } + + my $cpu_time = 0 ; + # last element is the sum of all elements + $cpu_time = ( map { $cpu_time += $_ } @cpu_times )[ -1 ] ; + $mysync->{ debug } and myprint( join(' + ', @cpu_times), " = $cpu_time\n" ) ; + + return $cpu_time ; +} + + +sub tests_cpu_percent +{ + note( 'Entering tests_cpu_percent()' ) ; + + is( '0.0', cpu_percent( ), 'cpu_percent: no args => 0.0' ) ; + my $mysync = { } ; + $mysync->{ debug } = 1 ; + is( '0.0', cpu_percent( $mysync ), 'cpu_percent: {} => 0.0' ) ; + is( '0.0', cpu_percent( $mysync, 0 ), 'cpu_percent: {} 0 => 0.0' ) ; + is( '300.0', cpu_percent( $mysync, 3 ), 'cpu_percent: {} 3 => 300.0' ) ; + is( '30.0', cpu_percent( $mysync, 3, 10 ), 'cpu_percent: {} 3 10 => 30.0' ) ; + is( '0.0', cpu_percent( $mysync, 0, 10 ), 'cpu_percent: {} 0 10 => 0.0' ) ; + + note( 'Leaving tests_cpu_percent()' ) ; + return ; +} + +sub cpu_percent +{ + my $mysync = shift ; + my $cpu_time = shift || 0 ; + my $timediff = shift || 1 ; # no division by 0 + + if ( $cpu_time > $timediff ) + { + myprint( "Strange: cpu_time $cpu_time > timediff $timediff\n" ) ; + } + my $cpu_percent = 0 ; + $cpu_percent = mysprintf( '%.1f', 100 * $cpu_time / $timediff ) ; + $mysync->{ debug } and myprint( "cpu_percent: $cpu_percent \n" ) ; + + return $cpu_percent ; + +} + +sub tests_cpu_percent_global +{ + note( 'Entering tests_cpu_percent_global()' ) ; + + is( '0.0', cpu_percent_global( ), 'cpu_percent_global: no args => 0' ) ; + my $mysync = { } ; + $mysync->{ debug } = 1 ; + is( '0.0', cpu_percent_global( $mysync ), 'cpu_percent_global: {} => 0' ) ; + is( '0.0', cpu_percent_global( $mysync, 0 ), 'cpu_percent_global: {} 0 => 0' ) ; + + SKIP: { + if ( ! ( 'i005' eq hostname() ) ) + { + skip( 'cpu_percent_global on host != i005', 1 ) ; + } + is( '25.0', cpu_percent_global( $mysync, 100 ), 'cpu_percent_global: {} 100 => 25 on host i005' ) ; + } ; + + SKIP: { + if ( ! ( 'petite' eq hostname() ) ) + { + skip( 'cpu_percent_global on host != petite', 1 ) ; + } + is( '50.0', cpu_percent_global( $mysync, 100 ), 'cpu_percent_global: {} 100 => 50 on host petite' ) ; + } ; + + note( 'Leaving tests_cpu_percent_global()' ) ; + return ; +} + +sub cpu_percent_global +{ + my $mysync = shift ; + my $cpu_percent = shift || 0 ; + + my $cpu_number = cpu_number( ) ; + + my $cpu_percent_global ; + $cpu_percent_global = mysprintf( '%.1f', $cpu_percent / $cpu_number ) ; + $mysync->{ debug } and myprint( "cpu_percent_global: $cpu_percent_global \n" ) ; + + return( $cpu_percent_global ) ; +} + + sub ram_memory_info { # In GigaBytes so division by 1024 * 1024 * 1024 @@ -13623,7 +15780,7 @@ sub memory_consumption_of_pids #myprint( "ps: @ps" ) ; # Use IPC::Open3 from perlcrit -3 - # It stalls on Darwin, don't understand why! + # But it stalls on Darwin, I don't understand why! #my @ps = backtick( "ps -o vsz -p @pid" ) ; #myprint( "ps: @ps" ) ; @@ -13795,7 +15952,7 @@ sub check_binary_embed_all_dyn_libs else { # Found only embedded dynamic lib - myprint( "Found nothing\n" ) ; + myprint( "Found only embedded dynamic lib. Good!\n" ) ; return 1 ; } } @@ -13819,22 +15976,22 @@ sub search_dyn_lib_locale sub search_dyn_lib_locale_darwin { - my $command = qq{ lsof -p $PID | grep ' REG ' | grep .dylib | grep -v '/par-' } ; + my $command = qq{ lsof -p $PROCESS_ID | grep ' REG ' | grep .dylib | grep -v '/par-' } ; myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; return backtick( $command ) ; } sub search_dyn_lib_locale_linux { - my $command = qq{ lsof -p $PID | grep ' REG ' | grep -v '/tmp/par-' | grep '\.so' } ; + my $command = qq{ lsof -p $PROCESS_ID | grep ' REG ' | grep -v '/tmp/par-' | grep '\.so' } ; myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; return backtick( $command ) ; } sub search_dyn_lib_locale_MSWin32 { - my $command = qq{ Listdlls.exe $PID|findstr Strawberry } ; - # $command = qq{ Listdlls.exe $PID|findstr Strawberry } ; + my $command = qq{ Listdlls.exe $PROCESS_ID|findstr Strawberry } ; + # $command = qq{ Listdlls.exe $PROCESS_ID|findstr Strawberry } ; myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; return qx( $command ) ; } @@ -14229,6 +16386,8 @@ sub comment_on_final_diff_in_1_not_in_2 { myprint( "The sync is not finished, there are ", $mysync->{ nb_messages_in_1_not_in_2 }, + " among ", + $nb_identified_h1_messages, " identified messages in host1 that are not on host2.\n" ) ; } @@ -14242,7 +16401,7 @@ sub comment_on_final_diff_in_1_not_in_2 } else { - myprint( "There is no unidentified message\n" ) ; + myprint( "There is no unidentified message on host1.\n" ) ; } return ; @@ -14277,9 +16436,11 @@ sub comment_on_final_diff_in_2_not_in_1 { myprint( "The sync is not strict, there are ", $mysync->{ nb_messages_in_2_not_in_1 }, - " messages in host2 that are not on host1.", - " Use --delete2 to delete them and have a strict sync.", - " ($nb_identified_h2_messages identified messages in host2)\n" ) ; + " among ", + $nb_identified_h2_messages, + " identified messages in host2 that are not on host1.", + " Use --delete2 and sync again to delete them and have a strict sync.\n" + ) ; } return ; } @@ -15053,24 +17214,25 @@ sub setlogfile my( $mysync ) = shift ; # When aborting another process the log file name finishes with "_abort.txt" - my $abort_suffix = ( $mysync->{abort} ) ? '_abort' : q{} ; + my $abort_suffix = ( $mysync->{ abort } ) ? '_abort' : q{} ; + # When acting as a proxy the log file name finishes with "_remote.txt" - # proxy mode is not done yet - my $remote_suffix = ( $mysync->{remote} ) ? '_remote' : q{} ; + # proxy mode is not done in imapsync, it is done by proximapsync + my $remote_suffix = ( $mysync->{ remote } ) ? '_remote' : q{} ; my $suffix = ( - filter_forbidden_characters( slash_to_underscore( $mysync->{user1} ) ) || q{} ) + filter_forbidden_characters( slash_to_underscore( $mysync->{ user1 } ) ) || q{} ) . '_' - . ( filter_forbidden_characters( slash_to_underscore( $mysync->{user2} ) ) || q{} ) + . ( filter_forbidden_characters( slash_to_underscore( $mysync->{ user2 } ) ) || q{} ) . $remote_suffix . $abort_suffix ; - $mysync->{logdir} = defined $mysync->{logdir} ? $mysync->{logdir} : $DEFAULT_LOGDIR ; + $mysync->{ logdir } = defined $mysync->{ logdir } ? $mysync->{ logdir } : $DEFAULT_LOGDIR ; - $mysync->{logfile} = defined $mysync->{logfile} - ? "$mysync->{logdir}/$mysync->{logfile}" - : logfile( $mysync->{timestart}, $suffix, $mysync->{logdir} ) ; + $mysync->{ logfile } = defined $mysync->{ logfile } + ? "$mysync->{ logdir }/$mysync->{ logfile }" + : logfile( $mysync->{ timestart }, $suffix, $mysync->{ logdir } ) ; - return( $mysync->{logfile} ) ; + return( $mysync->{ logfile } ) ; } sub tests_logfile @@ -15082,7 +17244,8 @@ sub tests_logfile skip( 'Too hard to have a well known timezone on Windows', 10 ) if ( 'MSWin32' eq $OSNAME ) ; local $ENV{TZ} = 'GMT' ; - { POSIX::tzset unless ('MSWin32' eq $OSNAME) ; + { + POSIX::tzset unless ('MSWin32' eq $OSNAME) ; is( '1970_01_01_00_00_00_000.txt', logfile( ), 'logfile: no args => 1970_01_01_00_00_00.txt' ) ; is( '1970_01_01_00_00_00_000.txt', logfile( 0 ), 'logfile: 0 => 1970_01_01_00_00_00.txt' ) ; is( '1970_01_01_00_01_01_000.txt', logfile( 61 ), 'logfile: 0 => 1970_01_01_00_01_01.txt' ) ; @@ -15129,6 +17292,38 @@ sub logfile } +sub tests_localtimez +{ + note( 'Entering tests_localtimez()' ) ; + + SKIP: { + # Too hard to have a well known timezone on Windows + skip( 'Too hard to have a well known timezone on Windows', 1 ) if ( 'MSWin32' eq $OSNAME ) ; + local $ENV{TZ} = 'GMT' ; + like( localtimez( 0 ), qr'1970-01-01 00:00:00 \+0000 (GMT|UTC)', 'localtimez: 0 => match 1970-01-01 00:00:00 +0000 GMT' ) ; + } + + is( localtimez( ), localtimez( time ), 'localtimez: undef => equals currrent' ) ; + note( 'Leaving tests_localtimez()' ) ; + return ; +} + + + +sub localtimez +{ + my $time = shift ; + + $time = defined( $time ) ? $time : time ; + + my $datetimestr = POSIX::strftime( '%A %e %B %Y-%m-%d %H:%M:%S %z %Z', localtime( $time ) ) ; + + #myprint( "$datetimestr\n" ) ; + return $datetimestr ; +} + + + sub tests_slash_to_underscore { @@ -15227,6 +17422,8 @@ sub tests_teelaunch is( undef, teelaunch( $mysync ), 'teelaunch: arg empty {} => undef' ) ; $mysync->{logfile} = q{} ; is( undef, teelaunch( $mysync ), 'teelaunch: logfile empty string => undef' ) ; + + # First time, learning IO::Tee intrasics $mysync->{logfile} = 'W/tmp/tests/tests_teelaunch.txt' ; isa_ok( my $tee = teelaunch( $mysync ), 'IO::Tee' , 'teelaunch: logfile W/tmp/tests/tests_teelaunch.txt' ) ; is( 1, print( $tee "Hi!\n" ), 'teelaunch: write Hi!') ; @@ -15234,6 +17431,38 @@ sub tests_teelaunch is( 1, print( $tee "Hoo\n" ), 'teelaunch: write Hoo') ; is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\nHoo\n' ) ; + # closing so tee won't be happy + close $mysync->{logfile_handle} ; + is( undef, print( $tee "Argh1\n" ), 'teelaunch: write Argh1') ; + is( undef, print( $tee "Argh2\n" ), 'teelaunch: write Argh2') ; + # write not done + is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is still Hi!\nHoo\n' ) ; + print join( ' ', $tee->handles ), "\n"; + is( 2, scalar $tee->handles, 'teelaunch: 2 handles') ; + shift @{*{$tee}}; + print join(' ', $tee->handles), "\n" ; + is( 1, scalar $tee->handles, 'teelaunch: 1 handle') ; + is( 1, print( $tee "Argh3\n" ), 'teelaunch: write Argh3 yeah') ; + + shift @{*{$tee}}; + # will not print anything now + is( 0, scalar $tee->handles, 'teelaunch: 0 handle') ; + is( 1, print( $tee "Argh 4\n" ), 'teelaunch: write Argh4 no') ; + + # Second time, lesson learnt IO::Tee + $mysync->{logfile} = 'W/tmp/tests/tests_teelaunch2.txt' ; + isa_ok( $tee = teelaunch( $mysync ), 'IO::Tee' , 'teelaunch: logfile W/tmp/tests/tests_teelaunch2.txt' ) ; + is( 1, print( $tee "Hi!\n" ), 'teelaunch: write Hi!') ; + is( "Hi!\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch2.txt is Hi!\n' ) ; + is( 1, print( $tee "Hoo\n" ), 'teelaunch: write Hoo') ; + is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch2.txt is Hi!\nHoo\n' ) ; + + is( 1, teefinish( $mysync ), 'teefinish: return 1') ; + is( 1, print( $tee "Argh1\n" ), 'teelaunch: write Argh1') ; + is( 1, print( $tee "Argh2\n" ), 'teelaunch: write Argh2') ; + is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch2.txt is still Hi!\nHoo\n' ) ; + is( 1, teefinish( $mysync ), 'teefinish: still return 1') ; + note( 'Leaving tests_teelaunch()' ) ; return ; } @@ -15268,6 +17497,28 @@ sub teelaunch return $tee ; } +sub teefinish +{ + my $mysync = shift ; + + if ( ! defined( $mysync ) ) { return ; } + + my $tee = $mysync->{tee} ; + + if ( ! defined( $tee ) ) { return ; } + + if ( 2 == scalar $tee->handles ) + { + shift @{*{$tee}}; + } + else + { + # nothing + } + return scalar $tee->handles ; +} + + sub getpwuid_any_os { my $uid = shift ; @@ -15278,15 +17529,44 @@ sub getpwuid_any_os } + + +sub abortifneeded +{ + my $mysync = shift ; + if ( -e $mysync->{ abortfile } ) + { + myprint( "Asked to terminate by file $mysync->{ abortfile }\n" ) ; + do_and_print_stats( $mysync ) ; + myprint( "You should resynchronize those accounts by running a sync again,\n", + "since some messages and entire folders might still be missing on host2.\n" + ) ; + exit_clean( $mysync, $EXIT_BY_FILE ) ; + return ; + } + else + { + return ; + } +} + sub simulong { - my $max_seconds = shift ; + my $mysync = shift ; + + my $max_seconds = $mysync->{ simulong } ; + + if ( ! $max_seconds ) { return ; } + my $division = 5 ; - my $last_count = $division * $max_seconds ; + my $last_count = int( $division * $max_seconds ) ; + $mysync->{ debug } and myprint "last_count $last_count = int( division $division * max_seconds $max_seconds)\n" ; foreach my $i ( 1 .. ( $last_count ) ) { - myprint( "Are you still here ETA: " . ($last_count - $i) . "/$last_count msgs left\n" ) ; + myprint( "Are you still here ETA: " . ( $last_count - $i ) . "/$last_count msgs left\n" ) ; + #this one is for testing huge page behavior #myprint( "Are you still here ETA: " . ($last_count - $i) . "/$last_count msgs left\n" . ( "Ah" x 40 . "\n") x 4000 ) ; sleep( 1 / $division ) ; + abortifneeded( $mysync ) ; } return ; @@ -15302,12 +17582,14 @@ sub printenv return ; } -sub testsexit + +sub unittestssuite { my $mysync = shift ; if ( ! ( $mysync->{ tests } or $mysync->{ testsdebug } or $mysync->{ testsunit } ) ) { return ; } + my $test_builder = Test::More->builder ; tests( $mysync ) ; testsdebug( $mysync ) ; @@ -15323,16 +17605,12 @@ sub testsexit #$test_builder->reset( ) ; myprint( "Summary of tests: failed $nb_tests_failed tests, run $nb_tests_run tests, expected to run $nb_tests_expected tests.\n", "List of failed tests:\n", $tests_failed ) ; - exit $EXIT_TESTS_FAILED ; + return $EXIT_TESTS_FAILED ; } cleanup_mess_from_tests( ) ; - # Cover is larger with --tests --testslive - if ( ! $mysync->{ testslive } ) - { - exit ; - } - return ; + + return 0 ; } sub cleanup_mess_from_tests @@ -15476,8 +17754,8 @@ sub gmail12 $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; $mysync->{host2} ||= 'imap.gmail.com' ; $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ; - $mysync->{maxbytespersecond} ||= 20_000 ; # should be 10_000 when computed from Gmail documentation - $mysync->{maxbytesafter} ||= 1_000_000_000 ; + $mysync->{maxbytespersecond} ||= 20_000 ; # should be less than 10_000 when computed from Gmail documentation + $mysync->{maxbytesafter} ||= 1_000_000_000 ; # In fact it is documented as half: 500_000_000 $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ; $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ; $skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 0 ; @@ -15495,8 +17773,8 @@ sub gmail1 # Gmail at host2 $mysync->{host1} ||= 'imap.gmail.com' ; $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; - $mysync->{maxbytespersecond} ||= 40_000 ; # should be 20_000 computed from by Gmail documentation - $mysync->{maxbytesafter} ||= 2_500_000_000 ; + $mysync->{maxbytespersecond} ||= 40_000 ; # should be 30_000 computed from by Gmail documentation + $mysync->{maxbytesafter} ||= 3_000_000_000 ; # $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ; $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ; $skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 1 ; @@ -15507,24 +17785,24 @@ sub gmail1 return ; } -sub gmail2 +sub gmail2 { my $mysync = shift ; # Gmail at host2 - $mysync->{host2} ||= 'imap.gmail.com' ; - $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ; - $mysync->{maxbytespersecond} ||= 20_000 ; # should be 10_000 computed from by Gmail documentation - $mysync->{maxbytesafter} ||= 1_000_000_000 ; # In fact it is documented as half: 500_000_000 + $mysync->{ host2 } ||= 'imap.gmail.com' ; + $mysync->{ ssl2 } = ( defined $mysync->{ ssl2 } ) ? $mysync->{ ssl2 } : 1 ; + $mysync->{ maxbytespersecond } ||= 20_000 ; # should be less than 10_000 computed from by Gmail documentation + $mysync->{ maxbytesafter } ||= 1_000_000_000 ; # In fact it is documented as half: 500_000_000 - $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ; + $mysync->{ automap } = ( defined $mysync->{ automap } ) ? $mysync->{ automap } : 1 ; #$skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 1 ; $mysync->{ expunge1 } = ( defined $mysync->{ expunge1 } ) ? $mysync->{ expunge1 } : 1 ; - $mysync->{addheader} = ( defined $mysync->{addheader} ) ? $mysync->{addheader} : 1 ; - $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ; + $mysync->{ addheader } = ( defined $mysync->{ addheader } ) ? $mysync->{ addheader } : 1 ; + $mysync->{ maxsleep } = ( defined $mysync->{ maxsleep } ) ? $mysync->{ maxsleep } : $MAX_SLEEP ; ; - $mysync->{maxsize} = ( defined $mysync->{maxsize} ) ? $mysync->{maxsize} : $GMAIL_MAXSIZE ; + #$mysync->{ maxsize } = ( defined $mysync->{ maxsize } ) ? $mysync->{ maxsize } : $GMAIL_MAXSIZE ; - if ( ! $mysync->{noexclude} ) { + if ( ! $mysync->{ noexclude } ) { push @exclude, '\[Gmail\]$' ; } push @useheader, 'Message-Id' ; @@ -15571,7 +17849,7 @@ sub office2 $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ; $mysync->{ maxsize } ||= 45_000_000 ; $mysync->{maxmessagespersecond} ||= 4 ; - #push @regexflag, 's/\\\\Flagged//g' ; # No problem without! tested 2018_09_10 + #push @{ $mysync->{ regexflag } }, 's/\\\\Flagged//g' ; # No problem without! tested 2018_09_10 $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ; # I dislike double negation but here is one if ( ! $mysync->{noregexmess} ) @@ -15607,7 +17885,7 @@ sub exchange2 $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ; # I dislike double negation but here are two if ( ! $mysync->{noregexflag} ) { - push @regexflag, 's/\\\\Flagged//g' ; + push @{ $mysync->{ regexflag } }, 's/\\\\Flagged//g' ; } if ( ! $mysync->{noregexmess} ) { push @regexmess, 's,(.{10239}),$1\r\n,g' ; @@ -15649,14 +17927,17 @@ sub tests_resolv is( undef, resolv( 'hostnotexist' ), 'resolv: hostnotexist => undef' ) ; is( '127.0.0.1', resolv( '127.0.0.1' ), 'resolv: 127.0.0.1 => 127.0.0.1' ) ; is( '127.0.0.1', resolv( 'localhost' ), 'resolv: localhost => 127.0.0.1' ) ; - is( '5.135.158.182', resolv( 'imapsync.lamiral.info' ), 'resolv: imapsync.lamiral.info => 5.135.158.182' ) ; + is( '2001:41d0:2:84e0::1', resolv( 'imapsync.lamiral.info' ), 'resolv: imapsync.lamiral.info => 2001:41d0:2:84e0::1' ) ; # ip6-localhost ( in /etc/hosts ) is( '::1', resolv( 'ip6-localhost' ), 'resolv: ip6-localhost => ::1' ) ; is( '::1', resolv( '::1' ), 'resolv: ::1 => ::1' ) ; - # ks2 + # ks2ipv6 now has CNAME ks6ipv6 is( '2001:41d0:8:d8b6::1', resolv( '2001:41d0:8:d8b6::1' ), 'resolv: 2001:41d0:8:d8b6::1 => 2001:41d0:8:d8b6::1' ) ; - is( '2001:41d0:8:d8b6::1', resolv( 'ks2ipv6.lamiral.info' ), 'resolv: ks2ipv6.lamiral.info => 2001:41d0:8:d8b6::1' ) ; + is( '2001:41d0:8:9951::1', resolv( 'ks6ipv6.lamiral.info' ), 'resolv: ks6ipv6.lamiral.info => 2001:41d0:8:9951::1' ) ; + # ks6 + is( '2001:41d0:8:9951::1', resolv( '2001:41d0:8:9951::1' ), 'resolv: 2001:41d0:8:9951::1 => 2001:41d0:8:9951::1' ) ; + is( '2001:41d0:8:9951::1', resolv( 'ks6ipv6.lamiral.info' ), 'resolv: ks6ipv6.lamiral.info => 2001:41d0:8:9951::1' ) ; # ks3 is( '2001:41d0:8:bebd::1', resolv( '2001:41d0:8:bebd::1' ), 'resolv: 2001:41d0:8:bebd::1 => 2001:41d0:8:bebd::1' ) ; is( '2001:41d0:8:bebd::1', resolv( 'ks3ipv6.lamiral.info' ), 'resolv: ks3ipv6.lamiral.info => 2001:41d0:8:bebd::1' ) ; @@ -15692,6 +17973,7 @@ sub resolv_with_getaddrinfo { my $host = shift @ARG ; + $sync->{ debug } and myprint( "Entering resolv_with_getaddrinfo( $host )\n" ) ; if ( ! $host ) { return ; } my ( $err_getaddrinfo, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ; @@ -15706,14 +17988,17 @@ sub resolv_with_getaddrinfo if ( $err_getnameinfo ) { myprint( "Cannot getnameinfo of $host: $err_getnameinfo\n" ) ; return ; - } - $sync->{ debug } and myprint( "$host => $ipaddr\n" ) ; - push @addr, $ipaddr ; - my $reverse ; - ( $err_getnameinfo, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ; - $sync->{ debug } and myprint( "$host => $ipaddr => $reverse\n" ) ; - } + }else{ + $sync->{ debug } and myprint( "$host => $ipaddr\n" ) ; + push @addr, $ipaddr ; + my $reverse ; + ( $err_getnameinfo, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ; + $sync->{ debug } and myprint( "$host => $ipaddr => $reverse\n" ) ; + } + $sync->{ debug } and myprint( "$host => $ipaddr\n" ) ; + } + $sync->{ debug } and myprint( "Leaving resolv_with_getaddrinfo( $host => $addr[0])\n" ) ; return $addr[0] ; } @@ -15733,8 +18018,8 @@ sub tests_resolvrev is( 'ip6-localhost', resolvrev( 'ip6-localhost' ), 'resolvrev: ip6-localhost => ip6-localhost' ) ; is( 'ip6-localhost', resolvrev( '::1' ), 'resolvrev: ::1 => ip6-localhost' ) ; # ks2 - is( 'ks2ipv6.lamiral.info', resolvrev( '2001:41d0:8:d8b6::1' ), 'resolvrev: 2001:41d0:8:d8b6::1 => ks2ipv6.lamiral.info' ) ; - is( 'ks2ipv6.lamiral.info', resolvrev( 'ks2ipv6.lamiral.info' ), 'resolvrev: ks2ipv6.lamiral.info => ks2ipv6.lamiral.info' ) ; + is( 'ks6ipv6.lamiral.info', resolvrev( '2001:41d0:8:d8b6::1' ), 'resolvrev: 2001:41d0:8:d8b6::1 => ks6ipv6.lamiral.info' ) ; + is( 'ks6ipv6.lamiral.info', resolvrev( 'ks6ipv6.lamiral.info' ), 'resolvrev: ks6ipv6.lamiral.info => ks6ipv6.lamiral.info' ) ; # ks3 is( 'ks3ipv6.lamiral.info', resolvrev( '2001:41d0:8:bebd::1' ), 'resolvrev: 2001:41d0:8:bebd::1 => ks3ipv6.lamiral.info' ) ; is( 'ks3ipv6.lamiral.info', resolvrev( 'ks3ipv6.lamiral.info' ), 'resolvrev: ks3ipv6.lamiral.info => ks3ipv6.lamiral.info' ) ; @@ -15793,7 +18078,7 @@ sub tests_imapsping is( undef, imapsping( ), 'imapsping: no args => undef' ) ; is( undef, imapsping( 'hostnotexist' ), 'imapsping: hostnotexist => undef' ) ; is( 1, imapsping( 'imapsync.lamiral.info' ), 'imapsping: imapsync.lamiral.info => 1' ) ; - is( 1, imapsping( 'ks2ipv6.lamiral.info' ), 'imapsping: ks2ipv6.lamiral.info => 1' ) ; + is( 1, imapsping( 'ks6ipv6.lamiral.info' ), 'imapsping: ks6ipv6.lamiral.info => 1' ) ; note( 'Leaving tests_imapsping()' ) ; return ; } @@ -15873,7 +18158,7 @@ sub tests_sslcheck $mysync = { sslcheck => 1, - host1 => 'imapsync.lamiral.info', + host1 => 'test1.lamiral.info', tls1 => 1, } ; @@ -15881,32 +18166,32 @@ sub tests_sslcheck $mysync = { sslcheck => 1, - host1 => 'imapsync.lamiral.info', + host1 => 'test1.lamiral.info', } ; - is( 1, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info => 1' ) ; - is( 1, $mysync->{ssl1}, 'sslcheck: imapsync.lamiral.info => ssl1 1' ) ; + is( 1, sslcheck( $mysync ), 'sslcheck: test1.lamiral.info => 1' ) ; + is( 1, $mysync->{ssl1}, 'sslcheck: test1.lamiral.info => ssl1 1' ) ; $mysync->{sslcheck} = 0 ; is( undef, sslcheck( $mysync ), 'sslcheck: sslcheck off => undef' ) ; $mysync = { sslcheck => 1, - host1 => 'imapsync.lamiral.info', + host1 => 'test1.lamiral.info', host2 => 'test2.lamiral.info', } ; - is( 2, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info + test2.lamiral.info => 2' ) ; + is( 2, sslcheck( $mysync ), 'sslcheck: test1.lamiral.info + test2.lamiral.info => 2' ) ; $mysync = { sslcheck => 1, - host1 => 'imapsync.lamiral.info', + host1 => 'test1.lamiral.info', host2 => 'test2.lamiral.info', tls1 => 1, } ; - is( 1, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info + test2.lamiral.info + tls1 => 1' ) ; + is( 1, sslcheck( $mysync ), 'sslcheck: test1.lamiral.info + test2.lamiral.info + tls1 => 1' ) ; note( 'Leaving tests_sslcheck()' ) ; return ; @@ -15977,10 +18262,10 @@ sub testslive_init sub testslive6_init { my $mysync = shift ; - $mysync->{host1} ||= 'ks2ipv6.lamiral.info' ; + $mysync->{host1} ||= 'ks6ipv6.lamiral.info' ; $mysync->{user1} ||= 'test1' ; $mysync->{password1} ||= 'secret1' ; - $mysync->{host2} ||= 'ks2ipv6.lamiral.info' ; + $mysync->{host2} ||= 'ks6ipv6.lamiral.info' ; $mysync->{user2} ||= 'test2' ; $mysync->{password2} ||= 'secret2' ; return ; @@ -16143,7 +18428,6 @@ sub mygetppid } - sub tests_toggle_sleep { note( 'Entering tests_toggle_sleep()' ) ; @@ -16318,6 +18602,147 @@ EOF return( $usage ) ; } + + + +sub setvalfromcgikey +{ + my ( $mysync, $mycgi, $key, $val ) = @ARG ; + + my $badthings = 0 ; + + + my ( $name, $type, $struct ) ; + if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/mxs ) + { + $badthings++ ; + next ; # Unknown item + } + else + { + $name = [ split '|', $1, 1 ]->[0] ; # option name ab|cd|ef => keep only ab + $type = $2 ; # = or : followed by i or s or f + $struct = $3 ; # + or ! or @ or % + } + + if ( ( $struct || q{} ) eq '+' ) + { + ${$val} = $mycgi->param( $name ) ; # "Incremental" integer + } + elsif ( $type ) + { + my @values = $mycgi->multi_param( $name ) ; + + #myprint( "type[$type]values[@values]\$struct[", $struct || q{}, "]val[$val]ref(val)[", ref($val), "]\n" ) ; + if ( ( $struct || q{} ) eq '%' or ref( $val ) eq 'HASH' ) + { + setvalfromhash( $val, $type, @values ) ; + } + else + { + setvalfromlist( $mysync, $val, $name, $type, $struct, @values ) ; + } + } + else + { + setvalfromcheckbox( $mysync, $mycgi, $key, $name, $val ) ; + } + + return $badthings ; +} + +sub setvalfromlist +{ + my ( $mysync, $val, $name, $type, $struct, @values ) = @ARG ; + if ( $type =~ m/i$/mxs ) + { + @values = map { q{} ne $_ ? int $_ : undef } @values ; + } + elsif ( $type =~ m/f$/mxs ) + { + @values = map { 0 + $_ } @values ; + } + + if ( ( $struct || q{} ) eq '@' ) + { + @{ ${$val} } = @values ; + my @option = map { +( "--$name", "$_" ) } @values ; + push @{ $mysync->{ cmdcgi } }, @option ; + } + elsif ( ref( $val ) eq 'ARRAY' ) + { + @{$val} = @values ; + } + elsif ( my $value = $values[0] ) + { + ${$val} = $value ; + push @{ $mysync->{ cmdcgi } }, "--$name", $value ; + } + else + { + } + + return ; +} +sub setvalfromhash +{ + my ( $val, $type, @values ) = @ARG ; + + my %values = map { split /=/mxs, $_ } @values ; + + if ( $type =~ m/i$/mxs ) + { + foreach my $k ( keys %values ) + { + $values{$k} = int $values{$k} ; + } + } + elsif ( $type =~ m/f$/mxs ) + { + foreach my $k ( keys %values ) { + $values{$k} = 0 + $values{$k}; + } + } + + if ( 'REF' eq ref $val ) + { + %{ ${$val} } = %values ; + } + else + { + %{$val} = %values ; + } + + return ; +} + + +sub setvalfromcheckbox +{ + my ( $mysync, $mycgi, $key, $name, $val ) = @ARG ; + + # Checkbox + # --noname is set by name=0 or name= + my $value = $mycgi->param( $name ) ; + if ( defined $value ) + { + ${$val} = $value ; + if ( $value ) + { + push @{ $mysync->{ cmdcgi } }, "--$name" ; + } + else + { + push @{ $mysync->{ cmdcgi } }, "--no$name" ; + } + } + else + { + ${$val} = undef ; + } + return ; +} + sub myGetOptions { @@ -16325,6 +18750,7 @@ sub myGetOptions # https://metacpan.org/release/Getopt-Long-CGI # So this sub function is under the same license as Getopt-Long-CGI Luke Ross wants it, # which was Perl 5.6 or later licenses at the date of the copy. + # It also applies for the sub functions called from this one. my $mysync = shift @ARG ; my $arguments_ref = shift @ARG ; @@ -16345,84 +18771,10 @@ sub myGetOptions foreach my $key ( sort keys %options ) { my $val = $options{$key} ; - if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/mxs ) { - $badthings++ ; - next ; # Unknown item - } + $badthings += setvalfromcgikey( $mysync, $mycgi, $key, $val ) ; - my $name = [ split '|', $1, 1 ]->[0] ; - - if ( ( $3 || q{} ) eq '+' ) { - ${$val} = $mycgi->param( $name ) ; # "Incremental" integer - } - elsif ( $2 ) { - my @values = $mycgi->multi_param( $name ) ; - my $type = $2 ; - - #myprint( "type[$type]values[@values]\$3[", $3 || q{}, "]val[$val]ref(val)[", ref($val), "]\n" ) ; - if ( ( $3 || q{} ) eq '%' or ref( $val ) eq 'HASH' ) { - my %values = map { split /=/mxs, $_ } @values ; - - if ( $type =~ m/i$/mxs ) { - foreach my $k ( keys %values ) { - $values{$k} = int $values{$k} ; - } - } - elsif ( $type =~ m/f$/mxs ) { - foreach my $k ( keys %values ) { - $values{$k} = 0 + $values{$k}; - } - } - if ( 'REF' eq ref $val ) { - %{ ${$val} } = %values ; - } - else { - %{$val} = %values ; - } - } - else { - if ( $type =~ m/i$/mxs ) { - @values = map { q{} ne $_ ? int $_ : undef } @values ; - } - elsif ( $type =~ m/f$/mxs ) { - @values = map { 0 + $_ } @values ; - } - if ( ( $3 || q{} ) eq '@' ) { - @{ ${$val} } = @values ; - my @option = map { +( "--$name", "$_" ) } @values ; - push @{ $mysync->{ cmdcgi } }, @option ; - } - elsif ( ref( $val ) eq 'ARRAY' ) { - @{$val} = @values ; - } - elsif ( my $value = $values[0] ) - { - ${$val} = $value ; - push @{ $mysync->{ cmdcgi } }, "--$name", $value ; - } - else - { - - } - } - } - else - { - # Checkbox - # Considers only --name - # Should consider also --no-name and --noname - my $value = $mycgi->param( $name ) ; - if ( $value ) - { - ${$val} = 1 ; - push @{ $mysync->{ cmdcgi } }, "--$name" ; - } - else - { - ${$val} = undef ; - } - } } + if ( $badthings ) { return ; # undef or () } @@ -16432,11 +18784,12 @@ sub myGetOptions } -my @blabla ; # just used to check get_options_cgi() with an array + sub tests_get_options_cgi_context { - note( 'Entering tests_get_options_cgi()' ) ; + note( 'Entering tests_get_options_cgi_context()' ) ; + # Temporary, have to think harder about testing CGI context in command line --tests # API: @@ -16454,15 +18807,21 @@ sub tests_get_options_cgi_context my $mysync ; is( undef, get_options( $mysync ), 'get_options cgi context: no CGI module => undef' ) ; - require CGI ; - CGI->import( qw( -no_debug -utf8 ) ) ; + # skip all next tests if the CGI module is not available + + SKIP: { + if ( ! eval { require CGI ; } ) { + skip( "CGI Perl module is not installed", 19 ) ; + } + + CGI->import( qw( -no_debug -utf8 ) ) ; is( undef, get_options( $mysync ), 'get_options cgi context: no CGI param => undef' ) ; # Testing boolean $mysync->{cgi} = CGI->new( 'version=on&debugenv=on' ) ; local $ENV{'QUERY_STRING'} = 'version=on&debugenv=on' ; is( 22, get_options( $mysync ), 'get_options cgi context: QUERY_STRING => 22' ) ; - is( 1, $mysync->{ version }, 'get_options cgi context: --version => 1' ) ; + is( 'on', $mysync->{ version }, 'get_options cgi context: --version => on' ) ; # debugenv is not allowed in cgi context is( undef, $mysync->{debugenv}, 'get_options cgi context: $mysync->{debugenv} => undef' ) ; @@ -16474,14 +18833,6 @@ sub tests_get_options_cgi_context is( 'test1', $mysync->{user1}, 'get_options cgi context: $mysync->{user1} => test1' ) ; #local $ENV{'QUERY_STRING'} = undef ; - # Testing @ - $mysync->{cgi} = CGI->new( 'blabla=fd1' ) ; - get_options( $mysync ) ; - is_deeply( [ 'fd1' ], [ @blabla ], 'get_options cgi context: @blabla => fd1' ) ; - $mysync->{cgi} = CGI->new( 'blabla=fd1&blabla=fd2' ) ; - get_options( $mysync ) ; - is_deeply( [ 'fd1', 'fd2' ], [ @blabla ], 'get_options cgi context: @blabla => fd1, fd2' ) ; - # Testing s@ as ref $mysync->{cgi} = CGI->new( 'folder=fd1' ) ; get_options( $mysync ) ; @@ -16522,10 +18873,21 @@ sub tests_get_options_cgi_context #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; $mysync ={} ; - $mysync->{cgi} = CGI->new( 'justfoldersizes=on' ) ; + $mysync->{cgi} = CGI->new( 'testslive=on' ) ; get_options( $mysync ) ; - is( 1, $mysync->{ justfoldersizes }, 'get_options cgi context: --justfoldersizes=1 => justfoldersizes => 1' ) ; - myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + is( 'on', $mysync->{ testslive }, 'get_options cgi context: --testslive=on => testslive => on' ) ; + #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + + $mysync ={} ; + $mysync->{cgi} = CGI->new( 'log=0' ) ; + get_options( $mysync ) ; + is( 0, $mysync->{ log }, 'get_options cgi context: --log=0 => log => 0' ) ; + #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + + + # What is this fucked up indentation? + } + note( 'Leaving tests_get_options_cgi_context()' ) ; return ; @@ -16545,41 +18907,43 @@ sub get_options_cgi my $opt_ret = myGetOptions( $mysync, \@arguments, - 'abort' => \$mysync->{abort}, + 'abort' => \$mysync->{ abort }, + 'abortbyfile' => \$mysync->{ abortbyfile }, 'host1=s' => \$mysync->{ host1 }, 'host2=s' => \$mysync->{ host2 }, 'user1=s' => \$mysync->{ user1 }, 'user2=s' => \$mysync->{ user2 }, - 'password1=s' => \$mysync->{password1}, - 'password2=s' => \$mysync->{password2}, - 'dry!' => \$mysync->{dry}, - 'version' => \$mysync->{version}, - 'ssl1!' => \$mysync->{ssl1}, - 'ssl2!' => \$mysync->{ssl2}, - 'tls1!' => \$mysync->{tls1}, - 'tls2!' => \$mysync->{tls2}, - 'justlogin!' => \$mysync->{justlogin}, - 'justconnect!' => \$mysync->{justconnect}, - 'addheader!' => \$mysync->{addheader}, - 'automap!' => \$mysync->{automap}, - 'justautomap!' => \$mysync->{justautomap}, - 'gmail1' => \$mysync->{gmail1}, - 'gmail2' => \$mysync->{gmail2}, - 'office1' => \$mysync->{office1}, - 'office2' => \$mysync->{office2}, - 'exchange1' => \$mysync->{exchange1}, - 'exchange2' => \$mysync->{exchange2}, - 'domino1' => \$mysync->{domino1}, - 'domino2' => \$mysync->{domino2}, - 'f1f2=s@' => \$mysync->{f1f2}, - 'f1f2h=s%' => \$mysync->{f1f2h}, - 'folder=s@' => \$mysync->{ folder }, - 'blabla=s' => \@blabla, - 'testslive!' => \$mysync->{testslive}, - 'testslive6!' => \$mysync->{testslive6}, - 'releasecheck!' => \$mysync->{releasecheck}, - 'simulong=i' => \$mysync->{simulong}, - 'debugsleep=f' => \$mysync->{debugsleep}, + 'password1=s' => \$mysync->{ password1 }, + 'password2=s' => \$mysync->{ password2 }, + 'dry!' => \$mysync->{ dry }, + 'dry1!' => \$mysync->{ dry1 }, + 'version' => \$mysync->{ version }, + 'ssl1!' => \$mysync->{ ssl1 }, + 'ssl2!' => \$mysync->{ ssl2 }, + 'tls1!' => \$mysync->{ tls1 }, + 'tls2!' => \$mysync->{ tls2 }, + 'justbanner!' => \$mysync->{ justbanner }, + 'justlogin!' => \$mysync->{ justlogin }, + 'justconnect!' => \$mysync->{ justconnect }, + 'addheader!' => \$mysync->{ addheader }, + 'automap!' => \$mysync->{ automap }, + 'justautomap!' => \$mysync->{ justautomap }, + 'gmail1' => \$mysync->{ gmail1 }, + 'gmail2' => \$mysync->{ gmail2 }, + 'office1' => \$mysync->{ office1 }, + 'office2' => \$mysync->{ office2 }, + 'exchange1' => \$mysync->{ exchange1 }, + 'exchange2' => \$mysync->{ exchange2 }, + 'domino1' => \$mysync->{ domino1 }, + 'domino2' => \$mysync->{ domino2 }, + 'f1f2=s@' => \$mysync->{ f1f2 }, + 'f1f2h=s%' => \$mysync->{ f1f2h }, + 'folder=s@' => \$mysync->{ folder }, + 'testslive!' => \$mysync->{ testslive }, + 'testslive6!' => \$mysync->{ testslive6 }, + 'releasecheck!' => \$mysync->{ releasecheck }, + 'simulong=f' => \$mysync->{ simulong }, + 'debugsleep=f' => \$mysync->{ debugsleep }, 'subfolder1=s' => \$mysync->{ subfolder1 }, 'subfolder2=s' => \$mysync->{ subfolder2 }, 'justfolders!' => \$mysync->{ justfolders }, @@ -16587,9 +18951,15 @@ sub get_options_cgi 'delete1!' => \$mysync->{ delete1 }, 'delete2!' => \$mysync->{ delete2 }, 'delete2duplicates!' => \$mysync->{ delete2duplicates }, - 'tail!' => \$mysync->{tail}, + 'tail!' => \$mysync->{ tail }, + 'tmphash=s' => \$mysync->{ tmphash }, + 'exitwhenover=i' => \$mysync->{ exitwhenover }, + 'syncduplicates!' => \$mysync->{ syncduplicates }, + 'log!' => \$mysync->{ log }, + 'loglogfile!' => \$mysync->{ loglogfile }, + -# blabla and f1f2h=s% could be removed but +# f1f2h=s% could be removed but # tests_get_options_cgi() should be split before # with a sub tests_myGetOptions() ) ; @@ -16624,9 +18994,9 @@ sub get_options_cmd 'debugcontent!' => \$debugcontent, 'debugsleep=f' => \$mysync->{debugsleep}, 'debugflags!' => \$debugflags, - 'debugimap!' => \$debugimap, - 'debugimap1!' => \$debugimap1, - 'debugimap2!' => \$debugimap2, + 'debugimap!' => \$mysync->{ debugimap }, + 'debugimap1!' => \$mysync->{ acc1 }->{ debugimap }, + 'debugimap2!' => \$mysync->{ acc2 }->{ debugimap }, 'debugdev!' => \$debugdev, 'debugmemory!' => \$mysync->{debugmemory}, 'debugfolders!' => \$mysync->{debugfolders}, @@ -16635,8 +19005,11 @@ sub get_options_cmd 'debugenv!' => \$mysync->{debugenv}, 'debugsig!' => \$mysync->{debugsig}, 'debuglabels!' => \$mysync->{debuglabels}, - 'simulong=i' => \$mysync->{simulong}, + + 'simulong=f' => \$mysync->{simulong}, 'abort' => \$mysync->{abort}, + 'abortbyfile' => \$mysync->{abortbyfile}, + 'host1=s' => \$mysync->{ host1 }, 'host2=s' => \$mysync->{ host2 }, 'port1=i' => \$mysync->{port1}, @@ -16653,8 +19026,8 @@ sub get_options_cmd 'exchange2' => \$mysync->{exchange2}, 'domino1' => \$mysync->{domino1}, 'domino2' => \$mysync->{domino2}, - 'domain1=s' => \$domain1, - 'domain2=s' => \$domain2, + 'domain1=s' => \$mysync->{ acc1 }->{ domain }, + 'domain2=s' => \$mysync->{ acc2 }->{ domain }, 'password1=s' => \$mysync->{password1}, 'password2=s' => \$mysync->{password2}, 'passfile1=s' => \$mysync->{ passfile1 }, @@ -16662,6 +19035,15 @@ sub get_options_cmd 'authmd5!' => \$authmd5, 'authmd51!' => \$authmd51, 'authmd52!' => \$authmd52, + + 'trylogin!' => \$mysync->{ trylogin }, + + 'oauthdirect1=s' => \$mysync->{ acc1 }->{ oauthdirect }, + 'oauthdirect2=s' => \$mysync->{ acc2 }->{ oauthdirect }, + + 'oauthaccesstoken1=s' => \$mysync->{ acc1 }->{ oauthaccesstoken }, + 'oauthaccesstoken2=s' => \$mysync->{ acc2 }->{ oauthaccesstoken }, + 'sep1=s' => \$mysync->{ sep1 }, 'sep2=s' => \$mysync->{ sep2 }, 'sanitize!' => \$mysync->{ sanitize }, @@ -16687,10 +19069,11 @@ sub get_options_cmd 'pipemess=s' => \@pipemess, 'pipemesscheck!' => \$pipemesscheck, 'disarmreadreceipts!' => \$disarmreadreceipts, - 'regexflag=s' => \@regexflag, - 'noregexflag' => \$mysync->{noregexflag}, - 'filterflags!' => \$filterflags, - 'flagscase!' => \$flagscase, + 'regexflag=s@' => \$mysync->{ regexflag }, + 'noregexflag' => \$mysync->{ noregexflag }, + 'filterflags!' => \$mysync->{ filterflags }, + 'filterbuggyflags!' => \$mysync->{ filterbuggyflags }, + 'flagscase!' => \$mysync->{ flagscase }, 'syncflagsaftercopy!' => \$syncflagsaftercopy, 'resyncflags!' => \$mysync->{ resyncflags }, 'synclabels!' => \$mysync->{ synclabels }, @@ -16703,7 +19086,7 @@ sub get_options_cmd 'delete2foldersbutnot=s' => \$delete2foldersbutnot, 'syncinternaldates!' => \$syncinternaldates, 'idatefromheader!' => \$idatefromheader, - 'syncacls!' => \$syncacls, + 'syncacls!' => \$mysync->{ syncacls }, 'maxsize=i' => \$mysync->{ maxsize }, 'appendlimit=i' => \$mysync->{ appendlimit }, 'truncmess=i' => \$mysync->{ truncmess }, @@ -16716,51 +19099,52 @@ sub get_options_cmd 'foldersizes!' => \$mysync->{ foldersizes }, 'foldersizesatend!' => \$mysync->{ foldersizesatend }, 'dry!' => \$mysync->{dry}, + 'dry1!' => \$mysync->{dry1}, 'expunge1|expunge!' => \$mysync->{ expunge1 }, 'expunge2!' => \$mysync->{ expunge2 }, 'uidexpunge2!' => \$mysync->{ uidexpunge2 }, 'subscribed' => \$subscribed, 'subscribe!' => \$subscribe, 'subscribeall|subscribe_all!' => \$subscribeall, - 'justbanner!' => \$justbanner, + 'justbanner!' => \$mysync->{ justbanner }, 'justfolders!'=> \$mysync->{ justfolders }, 'justfoldersizes!' => \$mysync->{ justfoldersizes }, 'fast!' => \$fast, 'version' => \$mysync->{version}, 'help' => \$help, - 'timeout=i' => \$timeout, - 'timeout1=i' => \$mysync->{h1}->{timeout}, - 'timeout2=i' => \$mysync->{h2}->{timeout}, - 'skipheader=s' => \$skipheader, + 'timeout=f' => \$mysync->{timeout}, + 'timeout1=f' => \$mysync->{ acc1 }->{timeout}, + 'timeout2=f' => \$mysync->{ acc2 }->{timeout}, + 'skipheader=s' => \$mysync->{ skipheader }, 'useheader=s' => \@useheader, 'wholeheaderifneeded!' => \$wholeheaderifneeded, 'messageidnodomain!' => \$messageidnodomain, 'skipsize!' => \$skipsize, 'allowsizemismatch!' => \$allowsizemismatch, - 'fastio1!' => \$fastio1, - 'fastio2!' => \$fastio2, + 'fastio1!' => \$mysync->{ acc1 }->{ fastio }, + 'fastio2!' => \$mysync->{ acc2 }->{ fastio }, 'sslcheck!' => \$mysync->{sslcheck}, 'ssl1!' => \$mysync->{ssl1}, 'ssl2!' => \$mysync->{ssl2}, - 'ssl1_ssl_version=s' => \$mysync->{h1}->{sslargs}->{SSL_version}, - 'ssl2_ssl_version=s' => \$mysync->{h2}->{sslargs}->{SSL_version}, - 'sslargs1=s%' => \$mysync->{h1}->{sslargs}, - 'sslargs2=s%' => \$mysync->{h2}->{sslargs}, + 'ssl1_ssl_version=s' => \$mysync->{ acc1 }->{sslargs}->{SSL_version}, + 'ssl2_ssl_version=s' => \$mysync->{ acc2 }->{sslargs}->{SSL_version}, + 'sslargs1=s%' => \$mysync->{ acc1 }->{sslargs}, + 'sslargs2=s%' => \$mysync->{ acc2 }->{sslargs}, 'tls1!' => \$mysync->{tls1}, 'tls2!' => \$mysync->{tls2}, 'uid1!' => \$uid1, 'uid2!' => \$uid2, - 'authmech1=s' => \$authmech1, - 'authmech2=s' => \$authmech2, - 'authuser1=s' => \$authuser1, - 'authuser2=s' => \$authuser2, - 'proxyauth1' => \$proxyauth1, - 'proxyauth2' => \$proxyauth2, + 'authmech1=s' => \$mysync->{ acc1 }->{ authmech }, + 'authmech2=s' => \$mysync->{ acc2 }->{ authmech }, + 'authuser1=s' => \$mysync->{ acc1 }->{ authuser }, + 'authuser2=s' => \$mysync->{ acc2 }->{ authuser }, + 'proxyauth1' => \$mysync->{ acc1 }->{ proxyauth }, + 'proxyauth2' => \$mysync->{ acc2 }->{ proxyauth }, 'split1=i' => \$split1, 'split2=i' => \$split2, 'buffersize=i' => \$buffersize, - 'reconnectretry1=i' => \$reconnectretry1, - 'reconnectretry2=i' => \$reconnectretry2, + 'reconnectretry1=i' => \$mysync->{ acc1 }->{ reconnectretry }, + 'reconnectretry2=i' => \$mysync->{ acc2 }->{ reconnectretry }, 'tests!' => \$mysync->{ tests }, 'testsdebug|tests_debug!' => \$mysync->{ testsdebug }, 'testsunit=s@' => \$mysync->{testsunit}, @@ -16816,15 +19200,23 @@ sub get_options_cmd 'nof1f2' => \$mysync->{nof1f2}, 'f1f2h=s%' => \$mysync->{f1f2h}, 'justfolderlists!' => \$mysync->{justfolderlists}, - 'delete1emptyfolders' => \$mysync->{delete1emptyfolders}, + 'delete1emptyfolders' => \$mysync->{delete1emptyfolders}, + 'checknoabletosearch!' => \$mysync->{checknoabletosearch}, + 'syncduplicates!' => \$mysync->{ syncduplicates }, + 'dockercontext!' => \$mysync->{ dockercontext }, + + ) ; #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; $mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ; my $numopt_after = scalar @arguments ; #myprint( "get options: [$opt_ret][$numopt][$numopt_after]\n" ) ; - if ( $numopt_after ) { + + # The $arguments[0] test is just because parallel adds "" when it is + # used with {=7=} in sync_parallel_unix.sh + if ( $numopt_after and $arguments[0] ) { myprint( - "Extra arguments found: @arguments\n", + "Found ", scalar( @arguments ), " extra arguments : [@arguments]\n", "It usually means a quoting issue in the command line ", "or some misspelling options.\n", ) ; @@ -16915,6 +19307,25 @@ sub get_options return $ret ; } + +sub condition_to_leave_after_tests +{ + my $mysync = shift ; + if ( $mysync->{ testslive } or $mysync->{ testslive6 } ) + { + return 0 ; + } + + if ( $mysync->{ tests } + or $mysync->{ testsdebug } + or $mysync->{ testsunit } + ) + { + return 1 ; + } +} + + sub testunitsession { my $mysync = shift ; @@ -17055,7 +19466,9 @@ sub testsdebug #tests_killpid_by_brother( ) ; #tests_kill_zero( ) ; #tests_connect_socket( ) ; - tests_probe_imapssl( ) ; + #tests_probe_imapssl( ) ; + tests_cpu_number( ) ; + tests_mailimapclient_connect( ) ; #tests_always_fail( ) ; note( 'Leaving testsdebug()' ) ; @@ -17077,7 +19490,7 @@ sub tests tests_compare_lists( ) ; tests_regexmess( ) ; tests_skipmess( ) ; - tests_flags_regex(); + tests_regexflags( ); tests_ucsecond( ) ; tests_permanentflags(); tests_flags_filter( ) ; @@ -17186,7 +19599,7 @@ sub tests tests_remove_pidfile_not_running( ) ; tests_match_a_pid_number( ) ; tests_prefix_seperator_invertion( ) ; - tests_is_an_integer( ) ; + tests_is_integer( ) ; tests_integer_or_1( ) ; tests_is_number( ) ; tests_sig_install( ) ; @@ -17232,16 +19645,37 @@ sub tests tests_abort( ) ; tests_probe_imapssl( ) ; tests_mailimapclient_connect( ) ; + tests_checknoabletosearch( ) ; + tests_errorsdump( ) ; + tests_errorsanalyse( ) ; + tests_most_common_error( ) ; + tests_errorclassify( ) ; + tests_error_type( ) ; + tests_sanitize_host( ) ; + tests_hmac_sha1_hex( ) ; + tests_total_bytes_max_reached( ) ; + tests_header_construct( ) ; + tests_remove_doublequotes_if_any( ) ; + tests_login_imap( ) ; + tests_login_imap_oauth( ) ; + tests_skipmess_neg( ) ; + tests_localtimez( ) ; + tests_file_to_array( ) ; + tests_cpu_time( ) ; + tests_cpu_percent( ) ; + tests_cpu_percent_global( ) ; + tests_flags_for_host2( ) ; + tests_under_docker_context( ) ; #tests_resolv( ) ; - - # Those three are for later use, when webserver will be inside imapsync + + # Those three are for later use, when webserver will be inside imapsync # or will be deleted them if I abandon the project. #tests_killpid_by_parent( ) ; #tests_killpid_by_brother( ) ; #tests_kill_zero( ) ; - + #tests_always_fail( ) ; - done_testing( 1496 ) ; + done_testing( 1742 ) ; note( 'Leaving tests()' ) ; } return ; @@ -17251,11 +19685,19 @@ sub tests_template { note( 'Entering tests_template()' ) ; - is( undef, undef, 'template: no args => undef' ) ; + is( undef, template( ), 'template: no args => undef' ) ; + my $mysync = { } ; + is( undef, template( $mysync ), 'template: undef => undef' ) ; is_deeply( {}, {}, 'template: a hash is a hash' ) ; is_deeply( [], [], 'template: an array is an array' ) ; + note( 'Leaving tests_template()' ) ; return ; } - +sub template +{ + my $mysync = shift @ARG ; + + return ; +}