From c145f858e22ce312d30167a8a9188da482a849ce Mon Sep 17 00:00:00 2001 From: FreddleSpl0it <75116288+FreddleSpl0it@users.noreply.github.com> Date: Thu, 22 Oct 2026 18:27:49 +0200 Subject: [PATCH] [Web][Dovecot] imapsync: update to 2.314, refresh OAuth tokens of running jobs, add source presets --- data/Dockerfiles/dovecot/Dockerfile | 1 + data/Dockerfiles/dovecot/imapsync | 10123 +++++++++++----- data/Dockerfiles/dovecot/imapsync_runner.py | 97 +- .../Controller/ImapsyncApiController.php | 23 +- .../inc/lib/mailcow/Imapsync/Model/Source.php | 2 +- .../mailcow/Imapsync/Service/OAuthService.php | 27 +- .../Imapsync/Service/SourceService.php | 10 + data/web/inc/vars.inc.php | 2 +- data/web/js/site/imapsync.js | 78 +- data/web/lang/lang.de-de.json | 7 +- data/web/lang/lang.en-gb.json | 7 +- .../web/templates/modals/imapsync_source.twig | 30 + .../Imapsync/Controller/ApiControllerTest.php | 14 + .../php/Imapsync/Service/OAuthServiceTest.php | 28 +- .../Imapsync/Service/SourceServiceTest.php | 17 + 15 files changed, 7060 insertions(+), 3406 deletions(-) diff --git a/data/Dockerfiles/dovecot/Dockerfile b/data/Dockerfiles/dovecot/Dockerfile index bd57f1adf..42d3b8742 100644 --- a/data/Dockerfiles/dovecot/Dockerfile +++ b/data/Dockerfiles/dovecot/Dockerfile @@ -83,6 +83,7 @@ RUN addgroup -g 5000 vmail \ perl-test-warn \ perl-try-tiny \ perl-unicode-string \ + perl-proc-processtable \ perl-app-cpanminus \ procps \ python3 \ diff --git a/data/Dockerfiles/dovecot/imapsync b/data/Dockerfiles/dovecot/imapsync index de63d658c..f6beca4b0 100755 --- a/data/Dockerfiles/dovecot/imapsync +++ b/data/Dockerfiles/dovecot/imapsync @@ -1,6 +1,6 @@ #!/usr/bin/env perl -# $Id: imapsync,v 2.178 2022/01/12 21:28:37 gilles Exp gilles $ +# $Id: imapsync,v 2.314 2025/09/23 16:55:17 gilles Exp gilles $ # structure # pod documentation # use pragmas @@ -19,13 +19,12 @@ =head1 NAME -imapsync - Email IMAP tool for syncing, copying, migrating -and archiving email mailboxes between two imap servers, one way, +imapsync - Email tool for syncing two IMAP accounts, one way, and without duplicates. =head1 VERSION -This documentation refers to Imapsync $Revision: 2.178 $ +This documentation refers to Imapsync $Revision: 2.314 $ =head1 USAGE @@ -42,100 +41,120 @@ This documentation refers to Imapsync $Revision: 2.178 $ =head1 DESCRIPTION We sometimes need to transfer mailboxes from one imap server to -one another. +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. +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. -All folders are transferred, recursively, meaning -the whole folder hierarchy is taken, all messages in them, -and all message flags (\Seen \Answered \Flagged etc.) -are synced too. +All folders are transferred, recursively, meaning the whole folder +hierarchy is taken, all sub-folders, all messages in them, 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 strict sync and delete them. +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. There is no deletions by default. See the --delete2 option +to have strict sync and delete them. -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, -most often a duplicate problem is solved by using ---useheader "Message-Id" +How does 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. +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. +All flags are preserved, unread messages will stay unread, read ones +will stay read, and deleted ones will stay deleted. -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 -to abort the program. Hit Ctr-c just once makes -imapsync reconnect to both imap servers. +Flags are also resynchronized at each run, unless the option +--noresyncflags is used. + +A point about message deletions. In the IMAP protocol, a deleted +message is not deleted, it is marked \Deleted and can be undeleted. +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 Ctrl-c twice within two seconds to abort the program. Hit +Ctrl-c just once to make 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: +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 ) + Exiting with return value 0 (EX_OK: successful termination) 0/50 nb_errors/max_errors PID 20332 + Removing pidfile /home/gilles/tmp/imapsync.pid + Log file is LOG_imapsync/2023_08_21_11_51_27_651_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 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. +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: +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 +Imapsync mentions the total sizes of both accounts at the beginning of +the sync and also at the end. Sometimes, even with a strict sync, +those total sizes differ, and sometimes they differ a lot. The +difference is not a good criterion to conclude the sync went wrong. -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. +Why? That's because message sizes given by the imap servers are not +always accurate; they are not always the same as the actual message +sizes of the messages transferred by imapsync. Imapsync uses the sizes +given by the imap servers to calculate the total size. They can +differ. In the early days, Imapsync used the sizes of the messages as +one of the criteria to identify the messages; different sizes implied +different messages. But it was a mistake, the same message had +different sizes on both sides sometimes, depending on the imap +servers. -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 destroyed, it's a mandatory -folder in IMAP so imapsync doesn't even try to remove it. +Another explanation for a big total size difference is that Gmail +doesn't count the size of duplicate messages across folders twice, +while imapsync does. + + +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 means +that all messages in A will be in B but no more. + +For a strict synchronization, use the option --delete2. The option +--delete2 deletes the 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 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, +will only have messages that are not on the destination yet, i.e., messages that arrived after a sync or that failed to be transferred. In that case, use the --delete1 option. Option --delete1 implies also -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. +the option --expunge1, so all messages marked deleted on host1 will be +deleted. In the 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. You can also decide to remove empty folders once all of their messages have been transferred. Add --delete1emptyfolders to obtain this behavior. - -Imapsync is not adequate for maintaining two active imap accounts -in synchronization when the user plays independently on both sides. -Use offlineimap (written by John Goerzen) or mbsync (written by -Michael R. Elkins) for a 2 ways synchronization. +Imapsync is not adequate for maintaining two active imap accounts in +synchronization when the user plays independently on both sides. Use +offlineimap (written by John Goerzen) or mbsync (written by Michael +R. Elkins) for a 2 ways synchronization. =head1 OPTIONS @@ -143,32 +162,43 @@ 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 login into the IMAP -servers. These six values are a hostname, a username, and a password, two times. +Three values on each side are needed to login to the IMAP +servers. These six values are a hostname, a username, and a password, +twice. -Conventions used in the following descriptions of the options: +Here are the conventions used in the following descriptions of the +options: - str means string - int means integer number - flo means float number - reg means regular expression - cmd means command + str means a string + int means an integer number + flo means a float number + reg means a regular expression + cmd means a command - --dry : Makes imapsync doing nothing for real; it just print what + --dry : Makes imapsync do nothing for real; it just prints what would be done without --dry. =head2 OPTIONS/credentials - --host1 str : Source or "from" imap server. + --host1 str : Source or "from" imap server. + It can be a hostname or an IP address. + --port1 int : Port to connect on host1. - Optional since default ports are the - well known ports imap/143 or imaps/993. + Optional since the default port is the + well-known port imap/143 or imaps/993. + Add --ssl1 if you want an SSL/TLS connection on host1. + --user1 str : User to login on host1. + --password1 str : Password of user1. --host2 str : "destination" imap server. - --port2 int : Port to connect on host2. Optional + --port2 int : Port to connect on host2. + Optional since the default port is the + well-known port imap/143 or imaps/993. + Add --ssl2 if you want an SSL/TLS connection on host2. + --user2 str : User to login on host2. --password2 str : Password of user2. @@ -186,31 +216,44 @@ Conventions used in the following descriptions of the options: You can also pass the passwords in the environment variables 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. +then imapsync will prompt you to enter the password on the terminal. +Same thing for the user2 password. =head2 OPTIONS/encryption - --nossl1 : Do not use a SSL connection on host1. - --ssl1 : Use a SSL connection on host1. On by default if possible. + --nossl1 : Do not use an IMAP over SSL/TLS connection on host1. - --nossl2 : Do not use a SSL connection on host2. - --ssl2 : Use a SSL connection on host2. On by default if possible. + --ssl1 : Use an IMAP over SSL/TLS connection on host1. + It is imaps. The default port is 993. + Used by default, if possible. - --notls1 : Do not use a TLS connection on host1. - --tls1 : Use a TLS connection on host1. On by default if possible. + --nossl2 : Do not use an IMAP over SSL/TLS connection on host2. - --notls2 : Do not use a TLS connection on host2. - --tls2 : Use a TLS connection on host2. On by default if possible. + --ssl2 : Use an IMAP over SSL/TLS connection on host2. + Same as --ssl1 but for host2. - --debugssl int : SSL debug mode from 0 to 4. + --notls1 : Do not try a "STARTTLS" SSL/TLS connection on host1. - --sslargs1 str : Pass any ssl parameter for host1 ssl or tls connection. Example: - --sslargs1 SSL_verify_mode=1 --sslargs1 SSL_version=SSLv3 + --tls1 : Use a "STARTTLS" SSL/TLS encryption on host1. + The default port is 143. + Used by default, after imaps probing failed, + and if possible. + + --notls2 : Do not use a "STARTTLS" SSL/TLS connection on host2. + + --tls2 : Use a STARTTLS SSL/TLS encryption on host2. + Same as --tls1 but for host2. + + --debugssl int : SSL/TLS debug mode from 0 to 4. + + --sslargs1 str : Pass any SSL/TLS parameter for the host1 connection. + Example: + --sslargs1 SSL_verify_mode=1 --sslargs1 SSL_version=TLSv1_3 See all possibilities in the new() method of IO::Socket::SSL http://search.cpan.org/perldoc?IO::Socket::SSL#Description_Of_Methods - --sslargs2 str : Pass any ssl parameter for host2 ssl or tls connection. - See --sslargs1 + + --sslargs2 str : Pass any SSL/TLS parameter for the host2 connection. + Same as --sslargs1 but for host2. =head2 OPTIONS/authentication @@ -232,27 +275,31 @@ Same thing for user2 password. --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. + --oauthaccesstoken1 str : The access token to authenticate with OAUTH2 on + host1. It will be combined with the --user1 value to + form the string to pass with XOAUTH2 authentication. + Instead of the access token itself, the value can be + the 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 + and takes 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 + imapsync can read it again when it needs to reconnect during a run. + --oauthaccesstoken2 str : same thing as --oauthaccesstoken1 but for host2. - --oauthaccesstoken2 str : same thing as --oauthaccesstoken1 + --oauthdirect1 str : The direct string to pass with XOAUTH2 authentication + for host1. - --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 but for host2. + + --oauthrefreshcmd1 str : An optional command to call, to refresh the host1 + token before any oauth authentication. + It can have arguments like "cmd arg1 arg2 ..." + + --oauthrefreshcmd2 str : same thing as --oauthrefreshcmd1 but for host2. + - --oauthdirect2 str : same thing as oauthdirect1 =head2 OPTIONS/folders @@ -260,7 +307,7 @@ Same thing for user2 password. --folder str : Sync this folder. --folder str : and this one, etc. - --folderrec str : Sync this folder recursively. + --folderrec str : Sync this folder and all its sub-folders. --folderrec str : and this one, etc. --folderfirst str : Sync this folder first. Ex. --folderfirst "INBOX" @@ -270,9 +317,9 @@ Same thing for user2 password. --nomixfolders : Do not merge folders when host1 is case-sensitive while host2 is not (like Exchange). Only the first - similar folder is synced (example: with folders - "Sent", "SENT" and "sent" - on host1 only "Sent" will be synced to host2). + similar folder is synced. Example: with folders + "Sent", "SENT" and "sent" on host1, only "Sent" + will be synced to host2. --skipemptyfolders : Empty host1 folders are not created on host2. @@ -285,24 +332,25 @@ Same thing for user2 password. --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3. --exclude reg : or this one, etc. - --automap : guesses folders mapping, for folders well known as + --automap : guesses folder mapping, for folders well known as "Sent", "Junk", "Drafts", "All", "Archive", "Flagged". --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. + Option --f1f2 is a one-to-one-only folder mapping, + and str1 and str2 must be full path folder names. + Use --regextrans2 for more general mappings. --subfolder2 str : Syncs the whole host1 folders hierarchy under the host2 folder named str. It does it internally by adding three --regextrans2 options before all others. - Add --debug to see what's really going on. + Add --debug to see what's going on. --subfolder1 str : Syncs the host1 folders hierarchy which is under folder str to the root hierarchy of host2. - It's the couterpart of a sync done by --subfolder2 + It's the counterpart of a sync done by --subfolder2 when doing it in the reverse order. Backup/Restore scenario: Use --subfolder2 str for a backup to the folder str @@ -319,7 +367,7 @@ Same thing for user2 password. --prefix1 str : Remove prefix str to all destination folders, usually "INBOX." or "INBOX/" or an empty string "". - imapsync guesses the prefix if host1 imap server + imapsync guesses the prefix if the host1 imap server does not have NAMESPACE capability. So this option should not be used most of the time. --prefix2 str : Add prefix to all host2 folders. See --prefix1 @@ -328,12 +376,12 @@ Same thing for user2 password. most of the time. Imapsync gets the separator from the server itself, by using NAMESPACE, or it tries to guess it - from the folders listing (it counts + from the folder listing (it counts characters / . \\ \ in folder names and choose the more frequent, or finally / if nothing is found. --sep2 str : Host2 separator. See --sep1 - --regextrans2 reg : Apply the whole regex to each destination folders. + --regextrans2 reg : Apply the whole regex to each destination folder. --regextrans2 reg : and this one. etc. When you play with the --regextrans2 option, first add also the safe options --dry --justfolders @@ -347,9 +395,11 @@ Same thing for user2 password. =head2 OPTIONS/folders sizes --nofoldersizes : Do not calculate the size of each folder at the - beginning of the sync. Default is to calculate them. + beginning of the sync. The default behaviour + calculates them. --nofoldersizesatend: Do not calculate the size of each folder at the - end of the sync. Default is to calculate them. + end of the sync. The default behaviour + calculates them. --justfoldersizes : Exit after having printed the initial folder sizes. @@ -358,12 +408,15 @@ Same thing for user2 password. --tmpdir str : Where to store temporary files and subdirectories. Will be created if it doesn't exist. - Default is system specific, Unix is /tmp but - /tmp is often too small and deleted at reboot. - --tmpdir /var/tmp should be better. + Default is $HOME/tmp. It used to be /tmp on Unix, + before imapsync 2.250. But /tmp is not safe, see + https://github.com/imapsync/imapsync/issues/399 + https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2023-34204 + - --pidfile str : The file where imapsync pid is written, - it can be dirname/filename complete path. + --pidfile str : The file where the imapsync pid is written. + It can be specified with the form dirname/filename, + ie, a complete path. The default name is imapsync.pid in tmpdir. --pidfilelocking : Abort if pidfile already exists. Useful to avoid @@ -372,19 +425,20 @@ Same thing for user2 password. =head2 OPTIONS/log - --nolog : Turn off logging on file + --nolog : Turn off logging on file. By default in Docker context. + --log : Turn on logging on file. By default in normal and CGI contextes. --logfile str : Change the default log filename (can be dirname/filename). --logdir str : Change the default log directory. Default is LOG_imapsync/ -The default logfile name is for example +The default logfile name is, for example: LOG_imapsync/2019_12_22_23_57_59_532_user1_user2.txt where: - 2019_12_22_23_57_59_532 is nearly the date of the start - YYYY_MM_DD_HH_MM_SS_mmm - year_month_day_hour_minute_seconde_millisecond + 2019_12_22_23_57_59_532 is nearly the date of the start in the format + YYYY_MM_DD_HH_MM_SS_mmm corresponding to the meaning + year_month_day_hour_minute_second_millisecond and user1 user2 are the --user1 --user2 values. @@ -421,17 +475,22 @@ and user1 user2 are the --user1 --user2 values. Example: 's/\000/ /g' # to replace null characters by spaces. --regexmess reg : and this one, etc. - - --truncmess int : truncates messages when their size exceed the int - value, specified in bytes. Good to sync too big - messages or to "suppress" attachments. - Have in mind that this way, messages become + + --truncmess int : truncates messages when their size exceeds the int + value, specified in bytes. Good to sync too big + messages or to "suppress" attachments. + Have in mind that this way, messages become uncoherent somehow. + --nodry1 : makes imapsync fetching messages from host1, + even when --dry is on. + --dry --nodry1 is useful when debugging transformation + options like --pipemess or --regexmess + =head2 OPTIONS/labels -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 +Gmail presents labels as folders in imap. Imapsync can accelerate the sync +by syncing X-GM-LABELS; it will avoid to transferring messages when they are already on host2 in another folder. @@ -448,7 +507,7 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt =head2 OPTIONS/flags - If you encounter flag problems see also: + If you encounter flag problems, see also: https://imapsync.lamiral.info/FAQ.d/FAQ.Flags.txt --regexflag reg : Apply the whole regex to each flags list. @@ -458,7 +517,7 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --resyncflags : Resync flags for already transferred messages. On by default. --noresyncflags : Do not resync flags for already transferred messages. - May be useful when a user has already started to play + It 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 @@ -468,18 +527,18 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --delete1 : Deletes messages on host1 server after a successful transfer. Option --delete1 has the following behavior: - it marks messages as deleted with the IMAP flag - \Deleted, then messages are really deleted with an + It marks messages with the IMAP flag + \Deleted, then the messages are deleted with an EXPUNGE IMAP command. If expunging after each message - slows down too much the sync then use + slows down the sync too much, then use --noexpungeaftereach to speed up, expunging will then be done only twice per folder, one at the beginning and one at the end of a folder sync. --expunge1 : Expunge messages on host1 just before syncing a folder. Expunge is done per folder. - Expunge aims is to really delete messages marked deleted. - An expunge is also done after each message copied + Expunge aims to really delete messages marked \Deleted. + An expunge is also done after each message is copied if option --delete1 is set (unless --noexpungeaftereach). --noexpunge1 : Do not expunge messages on host1. @@ -494,11 +553,13 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --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. + detected with a 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. + Only the selected folders are considered; all folders by + default but not all with --exclude --include --folder etc. For safety, first try it like this, it is safe: --delete2folders --dry --justfolders --nofoldersizes and see what folders will be deleted. @@ -522,9 +583,9 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt https://imapsync.lamiral.info/FAQ.d/FAQ.Dates.txt --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 usually). - --idatefromheader : Sets the internal dates on host2 as same as the + Turned on by default. The internal date is the date + when a message arrives on a host (Unix mtime usually). + --idatefromheader : Sets the internal dates on host2 to the same as the ones in "Date:" headers. @@ -535,19 +596,19 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --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 + The final stats (skipped) don't count the older messages. + See also --minage --minage int : Skip messages newer than int days. - final stats (skipped) don't count newer messages - You can do (+ zone are the messages selected): + The final stats (skipped) don't count newer messages + What you can do (+ zone are the messages selected): past|----maxage+++++++++++++++>now past|+++++++++++++++minage---->now past|----maxage+++++minage---->now (intersection) - past|++++minage-----maxage++++>now (union) + past|++++minage-----maxage++++>now (union, magic!) --search str : Selects only messages returned by this IMAP SEARCH command. Applied on both sides. - For a complete set of what can be search see + For a complete set of what can be searched, see https://imapsync.lamiral.info/FAQ.d/FAQ.Messages_Selection.txt --search1 str : Same as --search but for selecting host1 messages only. @@ -556,16 +617,16 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --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 + "Date:" header. The 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. + --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 much more. --useheader str : Use this header to compare messages on both sides. @@ -585,11 +646,11 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt =head2 OPTIONS/miscellaneous - --syncacls : Synchronizes acls (Access Control Lists). - Acls in IMAP are not standardized, be careful - since one acl code on one side may signify something - else on the other one. - --nosyncacls : Does not synchronize acls. This is the default. + --syncacls : Synchronizes ACLs (Access Control Lists). + ACLs in IMAP are not standardized; be careful, + since one ACL code on one side may signify something + else on the other side. + --nosyncacls : Does not synchronize ACLs. This is the default. --addheader : When a message has no headers to be identified, --addheader adds a "Message-Id" header, @@ -600,22 +661,26 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt =head2 OPTIONS/debugging - --debug : Debug mode. - --debugfolders : Debug mode for the folders part only. - --debugcontent : Debug content of the messages transferred. Huge output. - --debugflags : Debug mode for flags. - --debugimap1 : IMAP debug mode for host1. Very verbose. - --debugimap2 : IMAP debug mode for host2. Very verbose. - --debugimap : IMAP debug mode for host1 and host2. Twice very verbose. - --debugmemory : Debug mode showing memory consumption after each copy. + --debug : Show debug notes. + --debugfolders : Show debug notes for the folders part only. + --debugcontent : Show content of the messages transferred. Huge output. + --debugflags : Show debug notes for flags. + --debugimap1 : Show IMAP notes for host1. Very verbose. + --debugimap2 : Show IMAP notes for host2. Very verbose. + --debugimap : Show IMAP notes for host1 and host2. Twice very verbose. + --debugmemory : Show the memory consumption after each copy. - --errorsmax int : Exit when int number of errors is reached. Default is 50. + --errorsmax int : Exit when int number of errors is reached. + The default is 50 errors to quit. + + --tests : Run local non-regression tests. + Exit code 0 means everything is ok. - --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 ks6ipv6.lamiral.info imap server. - Useful to check the ipv6 connectivity. Needs internet. + Useful to check the basics. It needs an internet connection. + + --testslive6 : Run a live test with tests1ipv6.lamiral.info imap server. + Useful to check the IPv6 connectivity. Needs internet. =head2 OPTIONS/specific @@ -640,22 +705,22 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --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. + Caveat emptor. Under CGI context, you may encounter a timeout + from the web server, killing imapsync and the imap connections. See the document INSTALL.OnlineUI.txt and search for "Timeout" for how to deal with this issue. --keepalive1 : https://metacpan.org/pod/Mail::IMAPClient#Keepalive - Some firewalls and network gears like to timeout connections + Some firewalls and network gears like to timeout connections prematurely if the connection sits idle. This option enables SO_KEEPALIVE on the host1 socket. --keepalive1 is on by default since imapsync release 2.169 Use --nokeepalive1 to disable it. - + --keepalive2 : Same as --keepalive2 but for host2. Use --nokeepalive2 to disable it. - --maxmessagespersecond flo : limits the average number of messages + --maxmessagespersecond flo : limits the average number of messages transferred per second. --maxbytespersecond int : limits the average transfer rate per second. @@ -674,10 +739,17 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --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 + It is an HTTP GET request to http://imapsync.lamiral.info/prj/imapsync/VERSION - --noid : Do not send/receive IMAP "ID" command to imap servers. + --emailreport1 : Put the email final report in host1 INBOX + --emailreport2 : Put the email final report in host2 INBOX + + --noemailreport1 : Do not put the email final report in host1 INBOX + --noemailreport2 : Do not put the email final report in host2 INBOX + + --noid : Do not send/receive the IMAP "ID" command + to the imap servers. --justconnect : Just connect to both servers and print useful information. Need only --host1 and --host2 options. @@ -691,10 +763,10 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt --help : print this help. - Example: to synchronize imap account "test1" on "test1.lamiral.info" - to imap account "test2" on "test2.lamiral.info" - with test1 password "secret1" - and test2 password "secret2" + Example: to synchronize the IMAP account "test1" on "test1.lamiral.info" + to the imap account "test2" on "test2.lamiral.info" + with the test1 account password being "secret1" + and the test2 account password being "secret2" imapsync \ --host1 test1.lamiral.info --user1 test1 --password1 secret1 \ @@ -710,40 +782,43 @@ https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt =head1 SECURITY -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 -dangerous because of the 'ps auxwwwwe' command. So, saving -the password in a well protected file (600 or rw-------) is -the best solution. +You can use --passfile1 instead of --password1 to mention the password, +since it is safer. With the --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 dangerous +because of the 'ps auxwwwwe' command. So, saving the password in a +well-protected file (600 or rw-------) is the best solution. -Imapsync activates ssl or tls encryption by default, if possible. +Imapsync activates SSL/TLS encryption by default, if possible. What detailed behavior is under this "if possible"? -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 with STARTTLS. +Imapsync activates the SSL/TLS mechanism if the well-known port imaps +port (993) is open on the imap servers. If the imaps port is closed, +then imapsync opens a normal (clear) connection on port 143. But then it +looks for STARTTLS support in the CAPABILITY list of the servers. If +STARTTLS is supported, then imapsync goes to an SSL/TLS encryption with +the STARTTLS IMAP command. -If the automatic ssl and the tls detections fail then imapsync will -not protect against sniffing activities on the network, especially -for passwords. +If the automatic SSL/TLS detections fail then imapsync uses clear-text +communication. Clear-text communication does not protect against +sniffing activities on the network, especially passwords. -If you want to force ssl or tls just use --ssl1 --ssl2 or --tls1 --tls2 +If you want to force SSL/TLS just use --ssl1, --ssl2 or --tls1 +--tls2. Imapsync won't go to clear-text communication with any of +these options. -See also the document FAQ.Security.txt in the FAQ.d/ directory -or at https://imapsync.lamiral.info/FAQ.d/FAQ.Security.txt +See also the document FAQ.Security.txt in the FAQ.d/ directory or at +https://imapsync.lamiral.info/FAQ.d/FAQ.Security.txt =head1 EXIT STATUS -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. +Imapsync will exit with a 0 status (return code) if everything goes +well. 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: @@ -772,6 +847,8 @@ egrep '^Readonly my.*\$EX' imapsync | egrep -o 'EX.*' | sed 's_^_ _' EXIT_ERR_SELECT => 117 ; EXIT_TRANSFER_EXCEEDED => 118 ; EXIT_ERR_APPEND_VIRUS => 119 ; + EXIT_ERR_FLAGS => 120 ; + EXIT_ERR_SEARCH => 121 ; EXIT_TESTS_FAILED => 254 ; # Like Test::More API EXIT_CONNECTION_FAILURE_HOST1 => 101 ; EXIT_CONNECTION_FAILURE_HOST2 => 102 ; @@ -781,10 +858,10 @@ egrep '^Readonly my.*\$EX' imapsync | egrep -o 'EX.*' | sed 's_^_ _' =head1 LICENSE AND COPYRIGHT -Imapsync is free, open, public but not always gratis software -cover by the NOLIMIT Public License, now called NLPL. -See the LICENSE file included in the distribution or just read this -simple sentence as it IS the licence text: +Imapsync is a free, open, and public but not always gratis software +tool covered by the NOLIMIT Public License, now called NLPL. See the +LICENSE file included in the distribution, or just read the following +simple sentence as it IS the license text: "No limits to do anything with this work and this license." @@ -801,12 +878,11 @@ Gilles LAMIRAL Good feedback is always welcome. Bad feedback is very often welcome. -Gilles LAMIRAL earns his living by writing, installing, -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, -your servitor, a good way to maintain and support free open public -software tools over decades. +Gilles LAMIRAL earns his living by writing, installing, configuring, +and sometimes teaching free, open, and often gratis software. Imapsync +used to be always gratis, but now it is only often gratis. It's +because imapsync is sold by its author, your servitor, a good way to +maintain and support free open public software tools over decades. =head1 BUGS AND LIMITATIONS @@ -818,10 +894,9 @@ See https://imapsync.lamiral.info/S/imapservers.shtml =head1 HUGE MIGRATION -If you have many mailboxes to migrate think about a little -shell program. Write a file called file.txt (for example) -containing users and passwords. -The separator used in this example is ';' +If you have many mailboxes to migrate, think about a little shell +program. Write a file called file.txt (for example) containing users +and passwords. The separator used in this example is ';' The file.txt file contains: @@ -832,21 +907,21 @@ user004_1;password004_1;user004_2;password004_2 user005_1;password005_1;user005_2;password005_2 ... -On Unix the shell program can be: +On Unix, the shell program can be: { while IFS=';' read u1 p1 u2 p2; do imapsync --host1 imap.side1.org --user1 "$u1" --password1 "$p1" \ --host2 imap.side2.org --user2 "$u2" --password2 "$p2" ... done ; } < file.txt -On Windows the batch program can be: +On Windows, the batch program can be: FOR /F "tokens=1,2,3,4 delims=; eol=#" %%G IN (file.txt) DO imapsync ^ --host1 imap.side1.org --user1 %%G --password1 %%H ^ --host2 imap.side2.org --user2 %%I --password2 %%J ... The ... have to be replaced by nothing or any imapsync option. -Welcome in shell or batch programming ! +Welcome to shell or batch programming! You will find already written scripts at https://imapsync.lamiral.info/examples/ @@ -855,36 +930,36 @@ https://imapsync.lamiral.info/examples/ Imapsync works under any Unix with Perl. - Imapsync works under most Windows (2000, XP, Vista, Seven, Eight, Ten - 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 32bit binary called imapsync_32bit.exe + Imapsync works under most Windows (2000, XP, Vista, Seven, Eight, + Ten, Eleven, 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 to avoid always typing the + options. See https://imapsync.lamiral.info/README_Windows.txt - Imapsync works under OS X as a standalone binary - software called imapsync_bin_Darwin + Imapsync works under OS X as a standalone binary software called + imapsync_bin_Darwin See + https://imapsync.lamiral.info/INSTALL.d/INSTALL.Darwin.txt - Purchase latest imapsync at + Purchase the latest imapsync at https://imapsync.lamiral.info/ - You'll receive a link to a compressed tarball called imapsync-x.xx.tgz - where x.xx is the version number. Untar the tarball where - you want (on Unix): + You'll receive a link to a compressed tarball called + imapsync-2.xxx.tgz, where 2.xxx is the version number. Untar the + tarball where you want (on Unix): - tar xzvf imapsync-x.xx.tgz + tar xzvf imapsync-2.xxx.tgz - Go into the directory imapsync-x.xx and read the INSTALL file. - As mentioned at https://imapsync.lamiral.info/#install - the INSTALL file can also be found at - https://imapsync.lamiral.info/INSTALL.d/INSTALL.ANY.txt - It is now split in several files for each system + Go into the directory imapsync-x.xx and read the INSTALL file. As + mentioned at https://imapsync.lamiral.info/#install, the INSTALL file + can also be found at + https://imapsync.lamiral.info/INSTALL.d/INSTALL.ANY.txt It is now + split into several files for each system https://imapsync.lamiral.info/INSTALL.d/ =head1 CONFIGURATION -There is no specific configuration file for imapsync, -everything is specified by the command line parameters -and the default behavior. +There is no specific configuration file for imapsync; everything is +specified by the command line parameters and the default behavior. =head1 HACKING @@ -894,62 +969,28 @@ Feel free to hack imapsync as the NOLIMIT license permits it. =head1 SIMILAR SOFTWARE - See also https://imapsync.lamiral.info/S/external.shtml - for a better up to date list. + See https://imapsync.lamiral.info/S/external.shtml -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 - imaputils: https://github.com/mtsatsenko/imaputils (very old imap_tools fork) - 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) - imaprepl: https://bl0rg.net/software/ http://freecode.com/projects/imap-repl/ - imapcopy (Pascal): http://www.ardiehl.de/imapcopy/ - imapcopy (Java): https://code.google.com/archive/p/imapcopy/ - imapsize: http://www.broobles.com/imapsize/ - migrationtool: http://sourceforge.net/projects/migrationtool/ - imapmigrate: http://sourceforge.net/projects/cyrus-utils/ - larch: https://github.com/rgrove/larch (derived from wonko_imapsync, good at Gmail) - wonko_imapsync: http://wonko.com/article/554 (superseded by larch) - pop2imap: http://www.linux-france.org/prj/pop2imap/ (I wrote that too) - exchange-away: http://exchange-away.sourceforge.net/ - SyncBackPro: http://www.2brightsparks.com/syncback/sbpro.html - ImapSyncClient: https://github.com/ridaamirini/ImapSyncClient - MailStore: https://www.mailstore.com/en/products/mailstore-home/ - mnIMAPSync: https://github.com/manusa/mnIMAPSync - imap-upload: http://imap-upload.sourceforge.net/ (A tool for uploading a local mbox file to IMAP4 server) - 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 -I initially wrote imapsync in July 2001 because an enterprise, -called BaSystemes, paid me to install a new imap server -without losing huge old mailboxes located in a far -away remote imap server, accessible by an -often broken low-bandwidth ISDN link. +I initially wrote imapsync in July 2001 because an enterprise, called +BaSystemes, paid me to install a new imap server without losing huge +old mailboxes located in a far-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 -design was made with the beautiful rsync command in mind. +I had to verify every mailbox was well transferred, all folders, and +all messages, 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 -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 +Imapsync originated as a patch to the copy_folder.pl 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 changes happened since then that I wonder -if it remains any lines of the original -copy_folder.pl in imapsync source code. +So many changes have happened since then that I wonder if any lines of +the original copy_folder.pl in the imapsync source code remain. =cut @@ -966,6 +1007,7 @@ use Compress::Zlib ; use Data::Dumper ; use Digest::HMAC_SHA1 qw( hmac_sha1 hmac_sha1_hex ) ; use Digest::MD5 qw( md5 md5_hex md5_base64 ) ; +use Digest::SHA ; use Encode ; use Encode::IMAPUTF7 ; use English qw( -no_match_vars ) ; @@ -978,9 +1020,11 @@ use File::Path qw( mkpath rmtree ) ; use File::Spec ; use File::stat ; use Getopt::Long ( ) ; +# This allows to notice the unknown options given +Getopt::Long::Configure("pass_through") ; use IO::File ; use IO::Socket qw( :crlf SOL_SOCKET SO_KEEPALIVE ) ; -use IO::Socket::INET6 ; +#use IO::Socket::INET6 ; use IO::Socket::SSL ; use IO::Tee ; use IPC::Open3 'open3' ; @@ -1051,6 +1095,7 @@ Readonly my $EXIT_TRANSFER_EXCEEDED => 118 ; Readonly my $EXIT_ERR_APPEND_VIRUS => 119 ; Readonly my $EXIT_ERR_FLAGS => 120 ; +Readonly my $EXIT_ERR_SEARCH => 121 ; Readonly my $EXIT_TESTS_FAILED => 254 ; # Like Test::More API @@ -1082,6 +1127,7 @@ Readonly my %EXIT_TXT => ( $EXIT_ERR_APPEND_VIRUS => 'EXIT_ERR_APPEND_VIRUS', $EXIT_ERR_FETCH => 'EXIT_ERR_FETCH', $EXIT_ERR_FLAGS => 'EXIT_ERR_FLAGS', + $EXIT_ERR_SEARCH => 'EXIT_ERR_SEARCH', $EXIT_ERR_CREATE => 'EXIT_ERR_CREATE', $EXIT_ERR_SELECT => 'EXIT_ERR_SELECT', $EXIT_TESTS_FAILED => 'EXIT_TESTS_FAILED', @@ -1102,6 +1148,7 @@ Readonly my %EXIT_VALUE_OF_ERR_TYPE => ( ERR_SELECT => $EXIT_ERR_SELECT, ERR_Host1_FETCH => $EXIT_ERR_FETCH, ERR_FLAGS => $EXIT_ERR_FLAGS, + ERR_SEARCH => $EXIT_ERR_SEARCH, ERR_UNCLASSIFIED => $EXIT_WITH_ERRORS, ERR_NOTHING_REPORTED => $EXIT_WITH_ERRORS, ERR_TRANSFER_EXCEEDED => $EXIT_TRANSFER_EXCEEDED, @@ -1123,6 +1170,7 @@ Readonly my %COMMENT_OF_ERR_TYPE => ( ERR_SELECT => \&comment_err_blank, ERR_Host1_FETCH => \&comment_err_blank, ERR_FLAGS => \&comment_err_flags, + ERR_SEARCH => \&comment_err_search, ERR_UNCLASSIFIED => \&comment_err_blank, ERR_NOTHING_REPORTED => \&comment_err_blank, ERR_TRANSFER_EXCEEDED => \&comment_err_transfer_exceeded, @@ -1140,11 +1188,21 @@ sub comment_err_blank } + +sub comment_err_search +{ + my $mysync = shift @ARG ; + + my $comment = "Check your --search option(s), usually a syntax issue. See https://imapsync.lamiral.info/FAQ.d/FAQ.Messages_Selection.txt" ; + return $comment ; +} + + sub comment_err_append_size { my $mysync = shift @ARG ; - - my $comment = "The destination server refuses too big messages. Use --truncmess option. Read https://imapsync.lamiral.info/FAQ.d/FAQ.Messages_Too_Big.txt" ; + + my $comment = "The destination server refuses too big messages. Use --truncmess option. See https://imapsync.lamiral.info/FAQ.d/FAQ.Messages_Too_Big.txt" ; return $comment ; } @@ -1152,7 +1210,7 @@ sub comment_err_append_size sub comment_err_authentication_failure_host1 { my $mysync = shift @ARG ; - + my $comment = "Check the credentials for $mysync->{ user1 }." ; return $comment ; } @@ -1160,7 +1218,7 @@ sub comment_err_authentication_failure_host1 sub comment_err_authentication_failure_host2 { my $mysync = shift @ARG ; - + my $comment = "Check the credentials for $mysync->{ user2 }." ; return $comment ; } @@ -1169,7 +1227,7 @@ sub comment_err_authentication_failure_host2 sub comment_err_connection_failure_host1 { my $mysync = shift @ARG ; - + my $comment = "Check that host1 $mysync->{ host1 } on port $mysync->{ port1 } is the right IMAP server to be contacted for your mailbox." ; return $comment ; } @@ -1177,7 +1235,7 @@ sub comment_err_connection_failure_host1 sub comment_err_connection_failure_host2 { my $mysync = shift @ARG ; - + my $comment = "Check that host1 $mysync->{ host2 } on port $mysync->{ port2 } is the right IMAP server to be contacted for your mailbox." ; return $comment ; } @@ -1185,7 +1243,7 @@ sub comment_err_connection_failure_host2 sub comment_err_overquota { my $mysync = shift @ARG ; - + my $comment = 'The destination mailbox is 100% full, get free space on it and then resume the sync.' ; return $comment ; } @@ -1194,7 +1252,7 @@ sub comment_err_overquota sub comment_err_transfer_exceeded { my $mysync = shift @ARG ; - + my $size_limit_human = bytes_display_string_dec( $mysync->{ exitwhenover } ) ; my $comment = "The maximum transfer size for a single sync is reached ( over $size_limit_human ). Relaunch the sync to sync more." ; return $comment ; @@ -1203,7 +1261,7 @@ sub comment_err_transfer_exceeded sub comment_err_flags { my $mysync = shift @ARG ; - + my $comment = 'Many STORE errors with FLAGS. Retry with the option --noresyncflags' ; return $comment ; } @@ -1212,10 +1270,8 @@ sub comment_err_flags Readonly my $DEFAULT_LOGDIR => 'LOG_imapsync' ; -Readonly my $ERRORS_MAX => 50 ; # exit after 50 errors. -Readonly my $ERRORS_MAX_CGI => 20 ; # exit after 20 errors in CGI context. - - +Readonly my $ERRORS_MAX => 50 ; # exit after 50 errors. +Readonly my $ERRORS_MAX_CGI => 500 ; # exit after 500 errors in CGI context. Readonly my $INTERVAL_TO_EXIT => 2 ; # interval max to exit instead of reconnect @@ -1294,9 +1350,8 @@ Readonly my $FORCE => 1 ; my( $sync, $acc1, $acc2, - $debugflags, - $debuglist, $debugdev, $debugmaxlinelength, $debugcgi, - @include, @exclude, @folderrec, + $debugmaxlinelength, + @include, @exclude, @folderfirst, @folderlast, @h1_folders_all, %h1_folders_all, @h2_folders_all, %h2_folders_all, @@ -1307,19 +1362,10 @@ my( %h1_subscribed_folder, %h2_subscribed_folder, %h2_folders_from_1_wanted, %h2_folders_from_1_several, - $prefix1, $prefix2, - @regexmess, @skipmess, @pipemess, $pipemesscheck, - $syncflagsaftercopy, - $syncinternaldates, - $idatefromheader, - $minsize, $maxage, $minage, - $search, - @useheader, %useheader, + @regexmess, @skipmess, @pipemess, $skipsize, $allowsizemismatch, $buffersize, $authmd5, $authmd51, $authmd52, $subscribed, $subscribe, $subscribeall, - $help, - $nb_msg_skipped_dry_mode, $h2_nb_msg_noheader, $h1_bytes_processed, $h1_nb_msg_end, $h1_bytes_end, @@ -1327,31 +1373,20 @@ my( $timestart_int, $uid1, $uid2, $split1, $split2, - $modulesversion, - $delete2folders, $delete2foldersonly, $delete2foldersbutnot, - $usecache, $debugcache, $cacheaftercopy, - $wholeheaderifneeded, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess, - $checkmessageexists, + $wholeheaderifneeded, %h1_msgs_copy_by_uid, $h2_uidguess, $messageidnodomain, - $fixInboxINBOX, - $maxlinelength, $maxlinelengthcmd, - $minmaxlinelength, - $fixcolonbug, - $create_folder_old, - $skipcrossduplicates, $debugcrossduplicates, - $disarmreadreceipts, + $maxlinelength, $mixfolders, - $fetch_hash_set, $cgidir, %month_abrev, $SSL_VERIFY_POLICY, -) ; +) ; -single_sync( $sync, $acc1, $acc2 ); +exit( single_sync( $sync, $acc1, $acc2 ) ) ; -sub single_sync +sub single_sync { # main program @@ -1363,7 +1398,8 @@ sub single_sync # or $acc1->{variable_name} # or $acc1->{variable_name} -# +# Yes, the indentation sucks, among other things. + $acc1 = {} ; $acc2 = {} ; $sync->{ acc1 } = $acc1 ; @@ -1374,30 +1410,19 @@ $acc2->{ Side } = 'Host2' ; $acc1->{ N } = '1' ; $acc2->{ N } = '2' ; -$sync->{timestart} = time ; # Is a float because of use Time::HiRres +$sync->{ timestart } = time ; # Is a float because of use Time::HiRres -$sync->{rcs} = q{$Id: imapsync,v 2.178 2022/01/12 21:28:37 gilles Exp gilles $} ; - -$sync->{ memory_consumption_at_start } = memory_consumption( ) || 0 ; +$sync->{ rcs } = q{$Id: imapsync,v 2.314 2025/09/23 16:55:17 gilles Exp gilles $} ; +$sync->{ memory_consumption_at_start } = memory_consumption_of_myself( ) || 0 ; my @loadavg = loadavg( ) ; -$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( ) ; - - - $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->{ nb_msg_skipped } = $sync->{ nb_msg_skipped_dry_mode } = 0 ; $sync->{ acc1 }->{ nb_msg_deleted } = 0 ; $sync->{ acc2 }->{ nb_msg_deleted } = 0 ; @@ -1417,8 +1442,9 @@ $sync->{ h1_nb_msg_processed } = $h1_bytes_processed = 0 ; $sync->{ h2_nb_msg_crossdup } = 0 ; -#$h1_nb_msg_end = $h1_bytes_end = 0 ; -#$h2_nb_msg_end = $h2_bytes_end = 0 ; + +$sync->{ deleted_folders_host2 } = 0 ; +$sync->{ deleted_folders_host2_failures } = 0 ; $sync->{ nb_errors } = 0; $sync->{ biggest_message_transferred } = 0; @@ -1439,6 +1465,14 @@ $sync->{ biggest_message_transferred } = 0; ); +my %SSL_VERIFY_STR ; + +Readonly $SSL_VERIFY_POLICY => IO::Socket::SSL::SSL_VERIFY_NONE( ) ; +Readonly %SSL_VERIFY_STR => ( + IO::Socket::SSL::SSL_VERIFY_NONE( ) => 'SSL_VERIFY_NONE, ie, do not check the server certificate.' , + IO::Socket::SSL::SSL_VERIFY_PEER( ) => 'SSL_VERIFY_PEER, ie, check the server certificate.' , +) ; + # Just create a CGI object if under cgi context only. # Needed for the get_options() call @@ -1446,54 +1480,86 @@ 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 ) ; + + +# No exit on heavy load by default in normal context. +# But exit on heavy load in CGI context +setexitonload( $sync ) ; + +$sync->{ cpu_number } = cpu_number( ) ; +$sync->{ heavy_load_reached } = heavy_load_reached( $sync ) ; +#$sync->{ heavy_load_reached} = 0 ; # uncomment this line if you want to go on no matter the load. +$sync->{ diskspace_available } = diskspace_available( '/var/tmp/imapsync_test_diskspace_available' ) ; + +$sync->{ loadavg } = join( q{ }, $loadavg[ 0 ] ) + . " on $sync->{cpu_number} cores and " + . ram_memory_info( $sync ) ; + # Is it the first myprint? cgibuildheader( $sync ) ; docker_context( $sync ) ; print_output_if_needed( $sync ) ; - - output_reset_with( $sync ) ; -# don't go on if options are not all known. + +# Do not go on if options are not all known. if ( ! defined $options_good ) { exit $EX_USAGE ; } +# Do not go on if no disk space available in CGI context. +cgi_exit_on_no_disk_space( $sync ) ; + # If you want releasecheck not to be done by default (like the github maintainer), # then just uncomment the first "$sync->{releasecheck} =" line, the line ending with "0 ;", -# the second line (ending with "1 ;") can then stay active or be commented, -# the result will be the same: no releasecheck by default (because 0 is then the defined value). +# the second line (ending with "1 ;") can stay active or be commented, +# the result will be the same: no releasecheck by default (because 0 is then a defined value). -#$sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 0 ; -$sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 1 ; +$sync->{ releasecheck } = defined $sync->{ releasecheck } ? $sync->{ releasecheck } : 0 ; +#$sync->{ releasecheck } = defined $sync->{ releasecheck } ? $sync->{ releasecheck } : 1 ; + + +#$sync->{debugenv} = 1 ; +$sync->{ debugenv } and printenv( $sync ) ; # if option --debugenv +load_modules( ) ; # just the version -if ( $sync->{ version } ) { +if ( $sync->{ version } ) +{ myprint( imapsync_version( $sync ), "\n" ) ; return 0 ; } -#$sync->{debugenv} = 1 ; -$sync->{debugenv} and printenv( $sync ) ; # if option --debugenv -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" ) ; +make_var_array_to_a_hash( $sync ) ; + # Under CGI environment, fix caveat emptor potential issues cgisetcontext( $sync ) ; -get_options_extra( $sync ) ; +get_options_extra_from_file( $sync ) ; +get_options_extra_from_param( $sync ) ; + +if ( under_cgi_context( $sync ) ) { output( $sync, cgienvcontext( $sync ) ) } ; # --gmail --gmail --exchange --office etc. easyany( $sync ) ; + $sync->{ sanitize } = defined $sync->{ sanitize } ? $sync->{ sanitize } : 1 ; sanitize( $sync ) ; -$sync->{ tmpdir } ||= File::Spec->tmpdir( ) ; +$sync->{ tmpdir } = tmpdir( $sync ) ; + +output( $sync, 'Current directory is ' . getcwd( ) . "\n" ) ; +output( $sync, "Temp directory is $sync->{ tmpdir } ( to change it use --tmpdir dirpath )\n" ) ; +output( $sync, "Creating temp directory $sync->{ tmpdir }\n" ) ; + +eval { mkpath( $sync->{ tmpdir } ) } && chmod( 0755, $sync->{ tmpdir } ) ; + # Unit tests my $unittestssuite = unittestssuite( $sync ) ; @@ -1501,7 +1567,7 @@ my $unittestssuite = unittestssuite( $sync ) ; if ( condition_to_leave_after_tests( $sync ) ) { - return $unittestssuite ; + return( $unittestssuite ) ; } # init live varaiables @@ -1511,6 +1577,11 @@ if ( $sync->{ testslive } ) testslive_init( $sync ) ; } +if ( $sync->{ testslive2 } ) +{ + testslive2_init( $sync ) ; +} + if ( $sync->{ testslive6 } ) { testslive6_init( $sync ) ; @@ -1521,32 +1592,53 @@ if ( $sync->{ abortbyfile } ) { $sync->{ abort } = 1 ; } install_signals( $sync ) ; -$sync->{ log } = defined $sync->{ log } ? $sync->{ log } : 1 ; +$sync->{ loglogfilename } = '../list_all_logs_auto.txt' ; + + +# $sync->{ log } = defined $sync->{ log } ? $sync->{ log } : 1 ; + +setlog( $sync ) ; + $sync->{ errorsdump } = defined $sync->{ errorsdump } ? $sync->{ errorsdump } : 1 ; $sync->{ errorsmax } = defined $sync->{ errorsmax } ? $sync->{ errorsmax } : $ERRORS_MAX ; +$sync->{ emailreport1 } = defined $sync->{ emailreport1 } ? $sync->{ emailreport1 } : 0 ; +$sync->{ emailreport2 } = defined $sync->{ emailreport2 } ? $sync->{ emailreport2 } : 0 ; + + # log and output binmode STDOUT, ":encoding(UTF-8)" ; -if ( $sync->{ log } ) { - setlogfile( $sync ) ; - teelaunch( $sync ) ; +if ( $sync->{ log } ) +{ + $sync->{ logdir } = setlogdir( $sync ) ; + $sync->{ logfile } = setlogfile( $sync, $sync->{ logfile } ) ; + $sync->{ tee } = teelaunch( $sync, $sync->{ logfile } ) ; # now $sync->{tee} is a filehandle to STDOUT and the logfile -} +} #binmode STDERR, ":encoding(UTF-8)" ; -# STDERR goes to the same place: LOG and STDOUT (if logging is on) -# Useful only for --debugssl -$sync->{tee} and local *STDERR = *${$sync->{tee}}{IO} ; +# STDERR goes to the same place: LOG and STDOUT if logging is on +# or just STDOUT +# + +stderr_to_stdout( $sync ) ; + + +if ( usecache_and_skipcrossduplicates( $sync ) ) +{ + $sync->{ nb_errors }++ ; + exit_clean( $sync, $EX_USAGE, "Error: can not have both --usecache and --skipcrossduplicates\n" ) ; +} -$timestart_int = int( $sync->{timestart} ) ; -$sync->{timebefore} = $sync->{timestart} ; +$timestart_int = int( $sync->{ timestart } ) ; +$sync->{timebefore} = $sync->{ timestart } ; -$sync->{ timestart_str } = localtimez( $sync->{timestart} ) ; +$sync->{ timestart_str } = localtimez( $sync->{ timestart } ) ; # The prints in the log starts here @@ -1555,12 +1647,12 @@ myprint( "Transfer started at $sync->{ timestart_str }\n" ) ; myprint( "PID is $PROCESS_ID my PPID is ", mygetppid( ), "\n" ) ; 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" ) ; +#myprintf( "Memory consumption so far: %.1f MiB\n", memory_consumption_of_myself( ) / $KIBI / $KIBI ) ; +#myprint( 'Current directory is ' . getcwd( ) . "\n" ) ; myprint( 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ; myprint( 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ; -$modulesversion = defined $modulesversion ? $modulesversion : 1 ; +$sync->{ modulesversion } = defined $sync->{ modulesversion } ? $sync->{ modulesversion } : 1 ; $sync->{ warn_release } = ( $sync->{ releasecheck } ) ? check_last_release( ) : $STR_use_releasecheck ; @@ -1568,32 +1660,30 @@ $sync->{ warn_release } = ( $sync->{ releasecheck } ) ? check_last_release( ) : $wholeheaderifneeded = defined $wholeheaderifneeded ? $wholeheaderifneeded : 1; # 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->{ usecache } = 1 if ( $sync->{ useuid } and ( ! defined $sync->{ usecache } ) ) ; +$sync->{ cacheaftercopy } = 1 if ( $sync->{ usecache } and ( ! defined $sync->{ cacheaftercopy } ) ) ; $sync->{ checkfoldersexist } = defined $sync->{ checkfoldersexist } ? $sync->{ checkfoldersexist } : 1 ; -$checkmessageexists = defined $checkmessageexists ? $checkmessageexists : 0 ; +$sync->{ checkmessageexists } = defined $sync->{ checkmessageexists } ? $sync->{ checkmessageexists } : 0 ; $sync->{ expungeaftereach } = defined $sync->{ expungeaftereach } ? $sync->{ expungeaftereach } : 1 ; # abletosearch is on by default -$sync->{abletosearch} = defined $sync->{abletosearch} ? $sync->{abletosearch} : 1 ; -$sync->{abletosearch1} = defined $sync->{abletosearch1} ? $sync->{abletosearch1} : $sync->{abletosearch} ; -$sync->{abletosearch2} = defined $sync->{abletosearch2} ? $sync->{abletosearch2} : $sync->{abletosearch} ; -$checkmessageexists = 0 if ( not $sync->{abletosearch1} ) ; +$sync->{ abletosearch } = defined $sync->{ abletosearch } ? $sync->{ abletosearch } : 1 ; +$sync->{ abletosearch1 } = defined $sync->{ abletosearch1 } ? $sync->{ abletosearch1 } : $sync->{ abletosearch } ; +$sync->{ abletosearch2 } = defined $sync->{ abletosearch2 } ? $sync->{ abletosearch2 } : $sync->{ abletosearch } ; +$sync->{ 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 ; -$create_folder_old = defined $create_folder_old ? $create_folder_old : 0 ; -$mixfolders = defined $mixfolders ? $mixfolders : 1 ; -$sync->{automap} = defined $sync->{automap} ? $sync->{automap} : 0 ; +$sync->{ trylogin } = defined $sync->{ trylogin } ? $sync->{ trylogin } : 1 ; +$sync->{ showpasswords } = defined $sync->{ showpasswords } ? $sync->{showpasswords} : 0 ; +$sync->{ fixslash2 } = defined $sync->{ fixslash2 } ? $sync->{ fixslash2 } : 1 ; +$sync->{ fixInboxINBOX } = defined $sync->{ fixInboxINBOX } ? $sync->{ fixInboxINBOX } : 1 ; +$sync->{ create_folder_old } = defined $sync->{ create_folder_old } ? $sync->{ create_folder_old } : 0 ; +$mixfolders = defined $mixfolders ? $mixfolders : 1 ; +$sync->{automap} = defined $sync->{automap} ? $sync->{automap} : 0 ; + +$sync->{ delete2duplicates } = determine_delete2duplicates( $sync ) ; -$sync->{ delete2duplicates } = 1 if ( $sync->{ delete2 } and ( ! defined $sync->{ delete2duplicates } ) ) ; $sync->{maxmessagespersecond} = defined $sync->{maxmessagespersecond} ? $sync->{maxmessagespersecond} : 0 ; $sync->{maxbytespersecond} = defined $sync->{maxbytespersecond} ? $sync->{maxbytespersecond} : 0 ; @@ -1602,12 +1692,11 @@ $sync->{sslcheck} = defined $sync->{sslcheck} ? $sync->{sslcheck} : 1 ; myprint( banner_imapsync( $sync, @ARGV ) ) ; -myprint( "Temp directory is $sync->{ tmpdir } ( to change it use --tmpdir dirpath )\n" ) ; myprint( output( $sync ) ) ; output_reset_with( $sync ) ; -do_valid_directory( $sync->{ tmpdir } ) || croak "Error creating tmpdir $sync->{ tmpdir } : $OS_ERROR" ; +make_valid_directory( $sync, $sync->{ tmpdir } ) || croak "Error creating tmpdir $sync->{ tmpdir } : $OS_ERROR" ; remove_pidfile_not_running( $sync->{ pidfile } ) ; @@ -1619,7 +1708,8 @@ if ( $sync->{ tail } and tail( $sync ) ) exit $EX_OK ; } -if ( ! write_pidfile( $sync ) ) { +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 PID $PROCESS_ID\n" ) ; exit $EXIT_PID_FILE_ERROR ; } @@ -1637,23 +1727,26 @@ if ( $sync->{ abort } ) exit $EX_OK ; } -# simulong is just a loop printing some lines for xx seconds with option "--simulong xx". +if ( $sync->{ memorystress } ) { tests_memory_stress() ; } + + +# simulong is just a loop printing some fake ETA lines for xx seconds with option "--simulong xx". simulong( $sync ) ; +debugsleep( $sync ) ; - -# New place for cgiload 2019_03_03 +# New place for cgi_exit_on_heavy_load 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 ) ; +# Have in mind the CGI header has already a 503 Service Unavailable printed. +cgi_exit_on_heavy_load( $sync ) ; -$fixcolonbug = defined $fixcolonbug ? $fixcolonbug : 1 ; +$sync->{ fixcolonbug } = defined $sync->{ fixcolonbug } ? $sync->{ fixcolonbug } : 1 ; -if ( $usecache and $fixcolonbug ) { tmpdir_fix_colon_bug( $sync ) } ; +if ( $sync->{ usecache } and $sync->{ fixcolonbug } ) { tmpdir_fix_colon_bug( $sync ) } ; -$modulesversion and myprint( "Modules version list ( use --no-modulesversion to turn off printing this Perl modules list ):\n", modulesversion(), "\n" ) ; +$sync->{ 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 @@ -1661,7 +1754,7 @@ check_lib_version( $sync ) or -if ( $sync->{ justbanner } ) +if ( $sync->{ justbanner } ) { myprint( "Exiting because of --justbanner\n" ) ; exit_clean( $sync, $EX_OK ) ; @@ -1679,31 +1772,32 @@ filterbuggyflags( $sync ) ; # sync flags just after an APPEND, some servers ignore the flags given in the APPEND # like MailEnable IMAP server. # Off by default since it takes time. -$syncflagsaftercopy = defined $syncflagsaftercopy ? $syncflagsaftercopy : 0 ; +$sync->{ syncflagsaftercopy } = defined $sync->{ syncflagsaftercopy } ? $sync->{ syncflagsaftercopy } : 0 ; # update flags on host2 for already transferred messages $sync->{resyncflags} = defined $sync->{resyncflags} ? $sync->{resyncflags} : 1 ; -if ( $sync->{resyncflags} ) { +if ( $sync->{resyncflags} ) +{ myprint( "Info: will resync flags for already transferred messages. Use --noresyncflags to not resync flags.\n" ) ; }else{ myprint( "Info: will not resync flags for already transferred messages. Use --resyncflags to resync flags.\n" ) ; } - +# Must call host1_port1_folderrec_from_host1() before sslcheck(). +host1_port1_folderrec_from_host1( $sync ) ; +host2_port2_subfolder2_from_host2( $sync ) ; sslcheck( $sync ) ; -#print Data::Dumper->Dump( [ \$sync ] ) ; -$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 ; +$split1 ||= $SPLIT ; +$split2 ||= $SPLIT ; + $acc1->{ debugimap } = $acc2->{ debugimap } = 1 if ( $sync->{ debugimap } ) ; # Set on debug mode if one of the imap dialogs are in debug. @@ -1722,91 +1816,98 @@ $subscribe = defined $subscribe ? $subscribe : 1; $allowsizemismatch = defined $allowsizemismatch ? $allowsizemismatch : 1; -if ( defined $delete2foldersbutnot or defined $delete2foldersonly ) { - $delete2folders = 1 ; +if ( defined( $sync->{ delete2foldersbutnot } ) or ( defined $sync->{ delete2foldersonly } ) ) +{ + $sync->{ delete2folders } = 1 ; } -my %SSL_VERIFY_STR ; - -Readonly $SSL_VERIFY_POLICY => IO::Socket::SSL::SSL_VERIFY_NONE( ) ; -Readonly %SSL_VERIFY_STR => ( - IO::Socket::SSL::SSL_VERIFY_NONE( ) => 'SSL_VERIFY_NONE, ie, do not check the certificate server.' , - IO::Socket::SSL::SSL_VERIFY_PEER( ) => 'SSL_VERIFY_PEER, ie, check the certificate server' , -) ; - -$IO::Socket::SSL::DEBUG = defined( $sync->{debugssl} ) ? $sync->{debugssl} : 1 ; +$IO::Socket::SSL::DEBUG = defined( $sync->{ debugssl } ) ? $sync->{ debugssl } : 1 ; -if ( $sync->{ssl1} or $sync->{ssl2} or $sync->{tls1} or $sync->{tls2}) { +if ( $sync->{ ssl1 } or $sync->{ ssl2 } or $sync->{ tls1 } or $sync->{ tls2 } ) +{ myprint( "SSL debug mode level is --debugssl $IO::Socket::SSL::DEBUG (can be set from 0 meaning no debug to 4 meaning max debug)\n" ) ; } -if ( $sync->{ssl1} ) { +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} ) { +if ( $sync->{ ssl2 } ) +{ myprint( qq{Host2: SSL default mode is like --sslargs2 "SSL_verify_mode=$SSL_VERIFY_POLICY", meaning for host2 $SSL_VERIFY_STR{$SSL_VERIFY_POLICY}\n} ) ; myprint( 'Host2: Use --sslargs2 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " to have $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} of host2\n" ) ; } # ID on by default since 1.832 -$sync->{id} = defined $sync->{id} ? $sync->{id} : 1 ; +$sync->{ id } = defined $sync->{ id } ? $sync->{ id } : 1 ; -if ( $sync->{justconnect} - or not $sync->{user1} - or not $sync->{user2} - or not $sync->{host1} - or not $sync->{host2} - ) +my $justconnect1 = '' ; +my $justconnect2 = '' ; + +if ( trigger_justconnect1( $sync ) ) { - my $justconnect = justconnect( $sync ) ; + $justconnect1 = justconnect1( $sync ) ; +} - myprint( debugmemory( $sync, " after justconnect() call" ) ) ; +if ( trigger_justconnect2( $sync ) ) +{ + $justconnect2 = justconnect2( $sync ) ; +} + + +if ( $justconnect1 and $justconnect2 ) +{ exit_clean( $sync, $EX_OK, - "Exiting after a justconnect on host(s): $justconnect\n" + "Exiting after a justconnect on host(s): $justconnect1 $justconnect2\n" ) ; } -#$sync->{user1} || missing_option( $sync, '--user1' ) ; -#$sync->{user2} || missing_option( $sync, '--user2' ) ; - -$syncinternaldates = defined $syncinternaldates ? $syncinternaldates : 1; +$sync->{ syncinternaldates } = defined $sync->{ syncinternaldates } ? $sync->{ syncinternaldates } : 1 ; # Turn on expunge if there is not explicit option --noexpunge1 and option # --delete1 is given. # Done because --delete1 --noexpunge1 is very dangerous on the second run: # the Deleted flag is then synced to all previously transferred messages. # So --delete1 implies --expunge1 is a better usability default behavior. -if ( $sync->{ delete1 } ) { - if ( ! defined $sync->{ expunge1 } ) { +if ( $sync->{ delete1 } ) +{ + if ( ! defined $sync->{ expunge1 } ) + { myprint( "Info: turning on --expunge1 because --delete1 --noexpunge1 is very dangerous on the second run.\n" ) ; $sync->{ expunge1 } = 1 ; } - myprint( "Info: if expunging after each message slows down too much the sync then use --noexpungeaftereach to speed up\n" ) ; + myprint( "Info: if expunging after each message slows down too much the sync then use --noexpungeaftereach to speed up\n" ) ; } -if ( $sync->{ uidexpunge2 } and not Mail::IMAPClient->can( 'uidexpunge' ) ) { +if ( $sync->{ uidexpunge2 } and not Mail::IMAPClient->can( 'uidexpunge' ) ) +{ myprint( "Failure: uidexpunge not supported (IMAPClient release < 3.17), use nothing or --expunge2 instead\n" ) ; - $sync->{nb_errors}++ ; + $sync->{ nb_errors }++ ; exit_clean( $sync, $EX_SOFTWARE ) ; } -if ( ( $sync->{ delete2 } or $sync->{ delete2duplicates } ) and not defined $sync->{ uidexpunge2 } ) { - if ( Mail::IMAPClient->can( 'uidexpunge' ) ) { +if ( ( $sync->{ delete2 } or $sync->{ delete2duplicates } ) and not defined $sync->{ uidexpunge2 } ) +{ + if ( Mail::IMAPClient->can( 'uidexpunge' ) ) + { myprint( "Info: will act as --uidexpunge2\n" ) ; $sync->{ uidexpunge2 } = 1 ; - }elsif ( not defined $sync->{ expunge2 } ) { + } + elsif ( not defined $sync->{ expunge2 } ) + { myprint( "Info: will act as --expunge2 (no uidexpunge support)\n" ) ; $sync->{ expunge2 } = 1 ; } } -if ( $sync->{ delete1 } and $sync->{ delete2 } ) { +if ( $sync->{ delete1 } and $sync->{ delete2 } ) +{ 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. " @@ -1815,32 +1916,37 @@ if ( $sync->{ delete1 } and $sync->{ delete2 } ) { exit_clean( $sync, $EX_USAGE ) ; } -if ( $idatefromheader ) { +if ( $sync->{ idatefromheader } ) +{ myprint( 'Turned ON idatefromheader, ', "will set the internal dates on host2 from the 'Date:' header line.\n" ) ; - $syncinternaldates = 0 ; + $sync->{ syncinternaldates } = 0 ; } -if ( $syncinternaldates ) { +if ( $sync->{ syncinternaldates } ) +{ myprint( 'Info: turned ON syncinternaldates, ', "will set the internal dates (arrival dates) on host2 same as host1.\n" ) ; }else{ myprint( "Info: turned OFF syncinternaldates\n" ) ; } -if ( defined $authmd5 and $authmd5 ) { +if ( defined $authmd5 and $authmd5 ) +{ $authmd51 = 1 ; $authmd52 = 1 ; } -if ( defined $authmd51 and $authmd51 ) { +if ( defined $authmd51 and $authmd51 ) +{ $acc1->{ authmech } ||= 'CRAM-MD5' ; } else{ $acc1->{ authmech } ||= $acc1->{ authuser } ? 'PLAIN' : 'LOGIN' ; } -if ( defined $authmd52 and $authmd52 ) { +if ( defined $authmd52 and $authmd52 ) +{ $acc2->{ authmech } ||= 'CRAM-MD5'; } else{ @@ -1912,47 +2018,46 @@ $acc2->{ reconnectretry } = defined $acc2->{ reconnectretry } ? $acc2->{ recon -if ( ! @useheader ) { @useheader = qw( Message-Id Received ) ; } - -# Make a hash %useheader of each --useheader 'key' in uppercase -for ( @useheader ) { $sync->{useheader}->{ uc $_ } = undef } ; - -#myprint( Data::Dumper->Dump( [ \%useheader ] ) ) ; -#exit ; - -myprint( "Host1: IMAP server [$sync->{host1}] port [$sync->{port1}] user [$sync->{user1}]\n" ) ; -myprint( "Host2: IMAP server [$sync->{host2}] port [$sync->{port2}] user [$sync->{user2}]\n" ) ; - -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} ) { - $sync->{dry_message} = "\t(not really since --dry mode)" ; +if ( ! exists( $sync->{ useheader } ) or ! @{ $sync->{ useheader } } ) +{ + @{ $sync->{ useheader } } = qw( Message-Id Received ) ; } -$sync->{ search1 } ||= $search if ( $search ) ; -$sync->{ search2 } ||= $search if ( $search ) ; +# Make a hash ref $sync->{ useheader_h } of each --useheader 'key' in uppercase +for ( @{ $sync->{ useheader } } ) +{ + $sync->{ useheader_h }->{ uc $_ } = undef ; -if ( $disarmreadreceipts ) +} + + +$sync->{ dry1 } = defined $sync->{ dry1 } ? $sync->{ dry1 } : $sync->{ dry } ; + +$sync->{ dry_message } = q{} ; +if( $sync->{ dry } ) +{ + $sync->{ dry_message } = "\t(not really since --dry mode)" ; +} + +$sync->{ search1 } ||= $sync->{ search } if ( $sync->{ search } ) ; +$sync->{ search2 } ||= $sync->{ search } if ( $sync->{ search } ) ; + +if ( $sync->{ disarmreadreceipts } ) { push @regexmess, q{s{\A((?:[^\n]+\r\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims} ; } -$pipemesscheck = ( defined $pipemesscheck ) ? $pipemesscheck : 1 ; +$sync->{ pipemesscheck } = ( defined $sync->{ pipemesscheck } ) ? $sync->{ pipemesscheck } : 1 ; -if ( @pipemess and $pipemesscheck ) { +if ( @pipemess and $sync->{ pipemesscheck } ) +{ myprint( 'Checking each --pipemess command, ' . join( q{, }, @pipemess ) . ", with an space string. ( Can avoid this check with --nopipemesscheck )\n" ) ; my $string = pipemess( q{ }, @pipemess ) ; # string undef means something was bad. - if ( not ( defined $string ) ) { + if ( not ( defined $string ) ) + { $sync->{nb_errors}++ ; exit_clean( $sync, $EX_USAGE, "Error: one of --pipemess command is bad, check it\n" @@ -1961,26 +2066,14 @@ if ( @pipemess and $pipemesscheck ) { myprint( "Ok with each --pipemess @pipemess\n" ) ; } -if ( $maxlinelengthcmd ) { - myprint( "Checking --maxlinelengthcmd command, - $maxlinelengthcmd, with an space string.\n" - ) ; - my $string = pipemess( q{ }, $maxlinelengthcmd ) ; - # string undef means something was bad. - if ( not ( defined $string ) ) { - $sync->{nb_errors}++ ; - exit_clean( $sync, $EX_USAGE, - "Error: --maxlinelengthcmd command is bad, check it\n" - ) ; - } - myprint( "Ok with --maxlinelengthcmd $maxlinelengthcmd\n" ) ; -} -if ( @regexmess ) { +if ( @regexmess ) +{ my $string = regexmess( q{ } ) ; myprint( "Checking each --regexmess command with an space string.\n" ) ; # string undef means one of the eval regex was bad. - if ( not ( defined $string ) ) { + if ( not ( defined $string ) ) + { #errors_incr( $sync, 'Warning: one of --regexmess option may be bad, check them' ) ; exit_clean( $sync, $EX_USAGE, "Error: one of --regexmess option is bad, check it\n" @@ -1989,11 +2082,13 @@ if ( @regexmess ) { myprint( "Ok with each --regexmess\n" ) ; } -if ( @skipmess ) { +if ( @skipmess ) +{ myprint( "Checking each --skipmess command with an space string.\n" ) ; my $match = skipmess( q{ } ) ; # match undef means one of the eval regex was bad. - if ( not ( defined $match ) ) { + if ( not ( defined $match ) ) + { $sync->{nb_errors}++ ; exit_clean( $sync, $EX_USAGE, "Error: one of --skipmess option is bad, check it\n" @@ -2002,11 +2097,13 @@ if ( @skipmess ) { myprint( "Ok with each --skipmess\n" ) ; } -if ( $sync->{ regexflag } ) { +if ( $sync->{ regexflag } ) +{ myprint( "Checking each --regexflag command with an space string.\n" ) ; my $string = regexflags( $sync, q{ } ) ; # string undef means one of the eval regex was bad. - if ( not ( defined $string ) ) { + if ( not ( defined $string ) ) + { $sync->{nb_errors}++ ; exit_clean( $sync, $EX_USAGE, "Error: one of --regexflag option is bad, check it\n" @@ -2015,48 +2112,64 @@ if ( $sync->{ regexflag } ) { myprint( "Ok with each --regexflag\n" ) ; } -$sync->{imap1} = login_imap( $sync->{host1}, $sync->{port1}, $sync->{user1}, $sync->{password1}, - $sync->{ssl1}, $sync->{tls1}, +if ( $sync->{ host1 } ) +{ + myprint( "Host1: IMAP server [$sync->{ host1 }] port [$sync->{ port1 }] user [" . ( $sync->{ user1 } || '?' ) . "]\n" ) ; +} + +if ( $sync->{ host2 } ) +{ + myprint( "Host2: IMAP server [$sync->{ host2 }] port [$sync->{ port2 }] user [" . ( $sync->{ user2 } || '?' ) . "]\n" ) ; +} + +get_password1( $sync ) ; +get_password2( $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}, $sync->{password2}, - $sync->{ssl2}, $sync->{tls2}, +$sync->{ imap2 } = login_imap( $sync->{ host2 }, $sync->{ port2 }, $sync->{ user2 }, $sync->{ password2 }, + $sync->{ ssl2 }, $sync->{ tls2 }, $uid2, $split2, $sync->{ acc2 }, $sync ) ; -$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" ) ; +$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} || ! $sync->{imap2} ) +if ( ! $sync->{ imap1 } || ! $sync->{ imap2 } ) { exit_most_errors( $sync ) ; } - myprint( "Host1: state Authenticated\n" ) ; myprint( "Host2: state Authenticated\n" ) ; -myprint( 'Host1 capability once authenticated: ', join(q{ }, @{ $sync->{imap1}->capability() || [] }), "\n" ) ; +myprint( 'Host1 capability once authenticated: ', join(q{ }, @{ $sync->{ imap1 }->capability() || [] }), "\n" ) ; -#myprint( Data::Dumper->Dump( [ $sync->{imap1} ] ) ) ; -#myprint( "imap4rev1: " . $sync->{imap1}->imap4rev1() . "\n" ) ; +#myprint( Data::Dumper->Dump( [ $sync->{ imap1 } ] ) ) ; +#myprint( "imap4rev1: " . $sync->{ imap1 }->imap4rev1() . "\n" ) ; -myprint( 'Host2 capability once authenticated: ', join(q{ }, @{ $sync->{imap2}->capability() || [] }), "\n" ) ; +myprint( 'Host2 capability once authenticated: ', join(q{ }, @{ $sync->{ imap2 }->capability() || [] }), "\n" ) ; imap_id_stuff( $sync ) ; -#quota( $sync, $sync->{imap1}, 'h1' ) ; # quota on host1 is useless and pollute host2 output. -quota( $sync, $sync->{imap2}, 'h2' ) ; +#quota( $sync, $sync->{ imap1 }, 'h1' ) ; # quota on host1 is useless and pollute host2 output. +quota( $sync, $sync->{ imap2 }, 'h2' ) ; maxsize_setting( $sync ) ; acc_compress_imap( $acc1 ) ; acc_compress_imap( $acc2 ) ; +myprint( "Compression often generates annoying errors, especially with SSL connexions, Gmail, Office365. So, avoid it.\n" ) ; -if ( $sync->{ justlogin } ) { - $sync->{imap1}->logout( ) ; - $sync->{imap2}->logout( ) ; + +if ( $sync->{ justlogin } ) +{ + $sync->{ imap1 }->logout( ) ; + $sync->{ imap2 }->logout( ) ; exit_clean( $sync, $EX_OK, "Exiting because of --justlogin\n" ) ; } @@ -2070,8 +2183,8 @@ $h1_folders_wanted_ct = 0 ; # counter of folders done. # All folders on host1 and host2 -@h1_folders_all = sort $sync->{imap1}->folders( ) ; -@h2_folders_all = sort $sync->{imap2}->folders( ) ; +@h1_folders_all = sort $sync->{ imap1 }->folders( ) ; +@h2_folders_all = sort $sync->{ imap2 }->folders( ) ; myprint( 'Host1: found ', scalar @h1_folders_all , " folders.\n" ) ; myprint( 'Host2: found ', scalar @h2_folders_all , " folders.\n" ) ; @@ -2096,22 +2209,27 @@ private_folders_separators_and_prefixes( ) ; # Make a hash of subscribed folders in both servers. -for ( $sync->{imap1}->subscribed( ) ) { $h1_subscribed_folder{ $_ } = 1 } ; -for ( $sync->{imap2}->subscribed( ) ) { $h2_subscribed_folder{ $_ } = 1 } ; +for ( $sync->{ imap1 }->subscribed( ) ) { $h1_subscribed_folder{ $_ } = 1 } ; +for ( $sync->{ imap2 }->subscribed( ) ) { $h2_subscribed_folder{ $_ } = 1 } ; -if ( defined $sync->{ subfolder1 } ) { +if ( defined $sync->{ subfolder1 } ) +{ subfolder1( $sync ) ; } - - -if ( defined $sync->{ subfolder2 } ) { +# subfolder2() put subfolder2 value in @exclude +if ( defined $sync->{ subfolder2 } ) +{ subfolder2( $sync ) ; } -if ( $fixInboxINBOX and ( my $reg = fix_Inbox_INBOX_mapping( \%h1_folders_all, \%h2_folders_all ) ) ) { +# subfolder2_with_delete2folders() adds --delete2foldersonly m{subfolder2} +subfolder2_with_delete2folders( $sync ) ; + +if ( $sync->{ fixInboxINBOX } and ( my $reg = fix_Inbox_INBOX_mapping( $sync, \%h1_folders_all, \%h2_folders_all ) ) ) +{ push @{ $sync->{ regextrans2 } }, $reg ; } @@ -2119,29 +2237,34 @@ if ( $fixInboxINBOX and ( my $reg = fix_Inbox_INBOX_mapping( \%h1_folders_all, \ if ( ( $sync->{ folder } and scalar @{ $sync->{ folder } } ) or $subscribed - or scalar @folderrec ) + or ( $sync->{ folderrec } and scalar @{ $sync->{ folderrec } } ) + ) { # folders given by option --folder - if ( $sync->{ folder } and scalar @{ $sync->{ folder } } ) { + if ( $sync->{ folder } and scalar @{ $sync->{ folder } } ) + { add_to_requested_folders( @{ $sync->{ folder } } ) ; } # option --subscribed - if ( $subscribed ) { + if ( $subscribed ) + { add_to_requested_folders( keys %h1_subscribed_folder ) ; } # option --folderrec - if ( scalar @folderrec ) { - foreach my $folderrec ( @folderrec ) { - add_to_requested_folders( $sync->{imap1}->folders( $folderrec ) ) ; + if ( $sync->{ folderrec } and scalar @{ $sync->{ folderrec } } ) + { + foreach my $folderrec ( @{ $sync->{ folderrec } } ) { + add_to_requested_folders( $sync->{ imap1 }->folders( $folderrec ) ) ; } } } else { # no include, no folder/subscribed/folderrec options => all folders - if ( not scalar @include ) { + if ( not scalar @include ) + { myprint( "Including all folders found by default. Use --subscribed or --folder or --folderrec or --include to select specific folders. Use --exclude to unselect specific folders.\n" ) ; add_to_requested_folders( @h1_folders_all ) ; } @@ -2149,7 +2272,8 @@ else # consider (optional) includes and excludes -if ( scalar @include ) { +if ( scalar @include ) +{ foreach my $include ( @include ) { # No, do not add /x after the regex, never. # Users would kill you! @@ -2159,7 +2283,8 @@ if ( scalar @include ) { } } -if ( scalar @exclude ) { +if ( scalar @exclude ) +{ foreach my $exclude ( @exclude ) { my @requested_folder = sort keys %requested_folder ; # No, do not add /x after the regex, never. @@ -2179,15 +2304,19 @@ $sync->{h1_folders_wanted} = [ sort_requested_folders( ) ] ; # Remove no selectable folders -if ( $sync->{ checkfoldersexist } ) { +if ( $sync->{ checkfoldersexist } ) +{ my @h1_folders_wanted_exist ; myprint( "Host1: Checking wanted folders exist. Use --nocheckfoldersexist to avoid this check (shared of public namespace targeted).\n" ) ; foreach my $folder ( @{ $sync->{h1_folders_wanted} } ) { ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Checking $folder exists on host1\n" ) ; - if ( ! exists $h1_folders_all{ $folder } ) { + if ( ! exists $h1_folders_all{ $folder } ) + { myprint( "Host1: warning! ignoring folder $folder because it is not in host1 whole folders list.\n" ) ; next ; - }else{ + } + else + { push @h1_folders_wanted_exist, $folder ; } } @@ -2202,7 +2331,7 @@ checkselectable( $sync ) ; -# Bugfix OpenFind folders named like "kk \*123" are in fact "kk *123" (no \) +# Local bugfix. OpenFind folders named like "kk \*123" are in fact "kk *123" (no \) #foreach my $folder ( @{ $sync->{ h1_folders_wanted } } ) #{ # $folder =~ s{ \\\*}{ *}g ; @@ -2211,7 +2340,8 @@ checkselectable( $sync ) ; # this hack is because LWP post does not pass well a hash in the $form parameter # but it does pass well an array -%{ $sync->{f1f2h} } = split_around_equal( @{ $sync->{f1f2} } ) ; +#%{ $sync->{f1f2h} } = split_around_equal( @{ $sync->{f1f2} } ) ; +make_f1f2_array_to_a_hash( $sync ) ; automap( $sync ) ; @@ -2220,7 +2350,8 @@ foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) { my $h2_fold ; $h2_fold = imap2_folder_name( $sync, $h1_fold ) ; $h2_folders_from_1_wanted{ $h2_fold }++ ; - if ( 1 < $h2_folders_from_1_wanted{ $h2_fold } ) { + if ( 1 < $h2_folders_from_1_wanted{ $h2_fold } ) + { $h2_folders_from_1_several{ $h2_fold }++ ; } } @@ -2256,19 +2387,20 @@ END_LISTING myprint( "Host1: folders list (first the raw imap format then the [X] = [Y]):\n", - $sync->{imap1}->list( ), + $sync->{ imap1 }->list( ), "\n", jux_utf8_list( @h1_folders_all ), "\n", "Host2: folders list (first the raw imap format then the [X] = [Y]):\n", - $sync->{imap2}->list( ), + $sync->{ imap2 }->list( ), "\n", jux_utf8_list( @h2_folders_all ), "\n", q{} ) ; -if ( $subscribed ) { +if ( $subscribed ) +{ myprint( 'Host1 subscribed folders list: ', jux_utf8_list( sort keys %h1_subscribed_folder ), "\n", @@ -2279,13 +2411,15 @@ if ( $subscribed ) { @h2_folders_not_in_1 = list_folders_in_2_not_in_1( ) ; -if ( @h2_folders_not_in_1 ) { +if ( @h2_folders_not_in_1 ) +{ myprint( "Folders in host2 not in host1:\n", jux_utf8_list( @h2_folders_not_in_1 ), "\n" ) ; } -if ( keys %{ $sync->{f1f2auto} } ) { +if ( keys %{ $sync->{f1f2auto} } ) +{ myprint( "Folders mapping from --automap feature (use --f1f2 to override any mapping):\n" ) ; foreach my $h1_fold ( keys %{ $sync->{f1f2auto} } ) { my $h2_fold = $sync->{f1f2auto}{$h1_fold} ; @@ -2295,12 +2429,14 @@ if ( keys %{ $sync->{f1f2auto} } ) { myprint( "\n" ) ; } -if ( keys %{ $sync->{f1f2h} } ) { +if ( keys %{ $sync->{f1f2h} } ) +{ myprint( "Folders mapping from --f1f2 options, it overrides --automap:\n" ) ; foreach my $h1_fold ( keys %{ $sync->{f1f2h} } ) { my $h2_fold = $sync->{f1f2h}{$h1_fold} ; my $warn = q{} ; - if ( not exists $h1_folders_all{ $h1_fold } ) { + if ( not exists $h1_folders_all{ $h1_fold } ) + { $warn = "BUT $h1_fold does NOT exist on host1!" ; } myprintf( "%-40s -> %-40s %s\n", @@ -2339,7 +2475,8 @@ if ( $sync->{ checknoabletosearch } ) -if ( $sync->{ foldersizes } ) { +if ( $sync->{ foldersizes } ) +{ foldersizes_at_the_beggining( $sync ) ; #foldersizes_at_the_beggining_old( $sync ) ; @@ -2352,13 +2489,18 @@ if ( $sync->{ justfoldersizes } ) exit_clean( $sync, $EX_OK, "Exiting because of --justfoldersizes\n" ) ; } -$sync->{can_do_stats} = 1 ; +$sync->{ can_do_stats } = 1 ; -if ( $sync->{ delete1emptyfolders } ) { +if ( $sync->{ delete1emptyfolders } ) +{ delete1emptyfolders( $sync ) ; } -delete_folders_in_2_not_in_1( ) if $delete2folders ; + +if ( $sync->{ delete2folders } ) +{ + delete_folders_in_2_not_in_1( $sync, @h2_folders_not_in_1 ) ; +} # folder loop $h1_folders_wanted_nb = scalar @{ $sync->{h1_folders_wanted} } ; @@ -2389,7 +2531,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) myprint( debugmemory( $sync, " at folder loop" ) ) ; # host1 can not be fetched read only, select is needed because of expunge. - select_folder( $sync, $sync->{imap1}, $h1_fold, 'Host1' ) or next FOLDER ; + select_folder( $sync, $sync->{ imap1 }, $h1_fold, 'Host1' ) or next FOLDER ; debugsleep( $sync ) ; @@ -2398,10 +2540,11 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) my $h1_msgs_nb ; my $h1_msgs_nb_from_select ; - $h1_msgs_nb_from_select = count_from_select( $sync->{imap1}->History ) ; + $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 ) { + if ( $sync->{ skipemptyfolders } and 0 == $h1_msgs_nb_from_select ) + { myprint( "Host1: skipping empty host1 folder [$h1_fold]\n" ) ; next FOLDER ; } @@ -2409,27 +2552,29 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) # Code added from https://github.com/imapsync/imapsync/issues/95 # 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). + # even if there are messages by SELECT (not real empty, but empty for the user point of view). if ( $sync->{ skipemptyfolders } or $sync->{ dry } ) { $h1_msgs_all_hash_ref = { } ; - @h1_msgs = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref, $sync->{ search1 }, $sync->{abletosearch1}, $h1_fold ) ; + @h1_msgs = select_msgs( $sync, $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 } ) { + 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 } ) { + if ( ! exists $h2_folders_all{ $h2_fold } ) + { # 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 ( ! create_folder( $sync, $sync->{ imap2 }, $h2_fold, $h1_fold ) ) { if ( $sync->{ dry } ) { - $nb_msg_skipped_dry_mode += $h1_msgs_nb ; + $sync->{ nb_msg_skipped_dry_mode } += $h1_msgs_nb ; } next FOLDER ; } @@ -2439,24 +2584,24 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) # Sometimes the folder on host2 is listed (it exists) but is # not selectable but becomes selectable by a create (Gmail) - select_folder( $sync, $sync->{imap2}, $h2_fold, 'Host2' ) - or ( create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold ) - and select_folder( $sync, $sync->{imap2}, $h2_fold, 'Host2' ) ) + select_folder( $sync, $sync->{ imap2 }, $h2_fold, 'Host2' ) + or ( create_folder( $sync, $sync->{ imap2 }, $h2_fold, $h1_fold ) + and select_folder( $sync, $sync->{ imap2 }, $h2_fold, 'Host2' ) ) or next FOLDER ; - my @select_results = $sync->{imap2}->Results( ) ; + my @select_results = $sync->{ imap2 }->Results( ) ; my $h2_fold_nb_messages = count_from_select( @select_results ) ; myprint( "Host2: folder [$h2_fold] has $h2_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ; - my $permanentflags2 = permanentflags( $sync, @select_results ) ; - myprint( "Host2: folder [$h2_fold] permanentflags: $permanentflags2\n" ) ; + $sync->{ permanentflags2 } = permanentflags( $sync, @select_results ) ; + myprint( "Host2: folder [$h2_fold] permanentflags: $sync->{ permanentflags2 }\n" ) ; if ( $sync->{ expunge1 } ) { - myprint( "Host1: Expunging $h1_fold $sync->{dry_message}\n" ) ; - if ( ! $sync->{dry} ) + myprint( "Host1: Expunging $h1_fold $sync->{ dry_message }\n" ) ; + if ( ! $sync->{ dry } ) { - $sync->{imap1}->expunge( ) ; + $sync->{ imap1 }->expunge( ) ; } } @@ -2464,7 +2609,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) and not exists $h2_subscribed_folder{ $h2_fold } ) { myprint( "Host2: Subscribing to folder $h2_fold\n" ) ; - if ( ! $sync->{dry} ) { $sync->{imap2}->subscribe( $h2_fold ) } ; + if ( ! $sync->{ dry } ) { $sync->{ imap2 }->subscribe( $h2_fold ) } ; } next FOLDER if ( $sync->{ justfolders } ) ; @@ -2475,7 +2620,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) 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 = select_msgs( $sync, $sync->{ imap1 }, $h1_msgs_all_hash_ref, $sync->{ search1 }, $sync->{abletosearch1}, $h1_fold ); $h1_msgs_nb = scalar @h1_msgs ; }else{ # select_msgs already done. @@ -2484,18 +2629,18 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 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 } or $sync->{ 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" ) ; my $h2_msgs_all_hash_ref = { } ; - my @h2_msgs = select_msgs( $sync->{imap2}, $h2_msgs_all_hash_ref, $sync->{ search2 }, $sync->{abletosearch2}, $h2_fold ) ; + my @h2_msgs = select_msgs( $sync, $sync->{ imap2 }, $h2_msgs_all_hash_ref, $sync->{ search2 }, $sync->{abletosearch2}, $h2_fold ) ; if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } my $h2_msgs_nb = scalar @h2_msgs ; myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages\n" ) ; - ( $sync->{ debug } or $debuglist ) and myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages, LIST gives: @h2_msgs\n" ) ; + ( $sync->{ debug } or $sync->{ debuglist } ) and myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages, LIST gives: @h2_msgs\n" ) ; $sync->{ debug } and myprint( "Host2: selecting messages of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ; my $cache_base = "$sync->{ tmpdir }/imapsync_cache/" ; @@ -2503,16 +2648,17 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) "$sync->{host1}/$sync->{user1}/$sync->{host2}/$sync->{user2}", $h1_fold, $h2_fold ) ; my ( $cache_1_2_ref, $cache_2_1_ref ) = ( {}, {} ) ; - my $h1_uidvalidity = $sync->{imap1}->uidvalidity( ) || q{} ; - my $h2_uidvalidity = $sync->{imap2}->uidvalidity( ) || q{} ; + my $h1_uidvalidity = $sync->{ imap1 }->uidvalidity( ) || q{} ; + my $h2_uidvalidity = $sync->{ imap2 }->uidvalidity( ) || q{} ; if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } - if ( $usecache ) { + if ( $sync->{ usecache } ) + { myprint( "Local cache directory: $cache_dir ( " . length( $cache_dir ) . " characters long )\n" ) ; mkpath( "$cache_dir" ) ; ( $cache_1_2_ref, $cache_2_1_ref ) - = get_cache( $cache_dir, \@h1_msgs, \@h2_msgs, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; + = get_cache( $sync, $cache_dir, \@h1_msgs, \@h2_msgs, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; myprint( 'CACHE h1 h2: ', scalar keys %{ $cache_1_2_ref } , " files\n" ) ; $sync->{ debug } and myprint( '[', map ( { "$_->$cache_1_2_ref->{$_} " } keys %{ $cache_1_2_ref } ), " ]\n" ) ; @@ -2541,38 +2687,42 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) my @h2_msgs_delete2_not_in_cache = () ; %h1_msgs_copy_by_uid = ( ) ; - if ( $useuid ) { + if ( $sync->{ useuid } ) + { # use uid so we have to avoid getting header @h1_msgs_copy_by_uid{ @h1_msgs_not_in_cache } = ( ) ; - @h2_msgs_delete2_not_in_cache = @h2_msgs_not_in_cache if $usecache ; + @h2_msgs_delete2_not_in_cache = @h2_msgs_not_in_cache if $sync->{ usecache } ; @h1_msgs_not_in_cache = ( ) ; @h2_msgs_not_in_cache = ( ) ; #myprint( "delete2: @h2_msgs_delete2_not_in_cache\n" ) ; } - - $sync->{ debug } and myprint( "Host1: parsing headers of folder [$h1_fold]\n" ) ; - - my ($h1_heads_ref, $h1_fir_ref) = ({}, {}); - $h1_heads_ref = $sync->{imap1}->parse_headers([@h1_msgs_not_in_cache], @useheader) if (@h1_msgs_not_in_cache); + + if ( $sync->{ debug } or ( 5000 <= scalar( @h1_msgs_not_in_cache ) ) ) + { + myprint( "Host1: parsing headers of folder [$h1_fold]. It can take time for huge folders. Be patient.\n" ) ; + } + + my ( $h1_heads_ref, $h1_fir_ref ) = ( {}, {} ) ; + $h1_heads_ref = $sync->{ imap1 }->parse_headers( [ @h1_msgs_not_in_cache ], @{ $sync->{ useheader } } ) if ( @h1_msgs_not_in_cache ) ; $sync->{ debug } and myprint( "Host1: parsing headers of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ; - @{ $h1_fir_ref }{@h1_msgs} = ( undef ) ; + @{ $h1_fir_ref }{ @h1_msgs } = ( undef ) ; - $sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold]\n" ) ; + $sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold]\n" ) ; my @h1_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ; if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h1_common_fetch_param, 'X-GM-LABELS' ; } - if ( $sync->{abletosearch1} ) + if ( $sync->{ abletosearch1 } ) { - $h1_fir_ref = $sync->{imap1}->fetch_hash( \@h1_msgs, @h1_common_fetch_param, $h1_fir_ref ) + $h1_fir_ref = $sync->{ imap1 }->fetch_hash( \@h1_msgs, @h1_common_fetch_param, $h1_fir_ref ) if ( @h1_msgs ) ; } else { - 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 ) + my $fetch_hash_uids = $sync->{ fetch_hash_set } || "1:*" ; + $h1_fir_ref = $sync->{ imap1 }->fetch_hash( $fetch_hash_uids, @h1_common_fetch_param, $h1_fir_ref ) if ( @h1_msgs ) ; } @@ -2580,7 +2730,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) if ( ! $h1_fir_ref ) { my $error = join( q{}, "Host1: folder $h1_fold : Could not fetch_hash ", - scalar @h1_msgs, ' msgs: ', $sync->{imap1}->LastError || q{}, "\n" ) ; + scalar @h1_msgs, ' msgs: ', $sync->{ imap1 }->LastError || q{}, "\n" ) ; errors_incr( $sync, $error ) ; next FOLDER ; } @@ -2588,7 +2738,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) my @h1_msgs_duplicate; foreach my $m ( @h1_msgs_not_in_cache ) { - my $rc = parse_header_msg( $sync, $sync->{imap1}, $m, $h1_heads_ref, $h1_fir_ref, 'Host1', \%h1_hash ) ; + my $rc = parse_header_msg( $sync, $sync->{ imap1 }, $m, $h1_fold, $h1_heads_ref, $h1_fir_ref, 'Host1', \%h1_hash ) ; if ( ! defined $rc ) { my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0; @@ -2605,7 +2755,8 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0; $sync->{ acc1 }->{ nb_msg_duplicate } += 1; - if ( ! $sync->{ syncduplicates } ) { + if ( ! $sync->{ syncduplicates } ) + { $sync->{ nb_msg_skipped } += 1 ; $sync->{ h1_nb_msg_processed } +=1 ; } @@ -2619,30 +2770,34 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) $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 ; } - $sync->{ debug } and myprint( "Host2: parsing headers of folder [$h2_fold]\n" ) ; + if ( $sync->{ debug } or ( 5000 <= scalar( @h2_msgs_not_in_cache ) ) ) + { + myprint( "Host2: parsing headers of folder [$h2_fold]. It can take time for huge folders. Be patient.\n" ) ; + } - my ($h2_heads_ref, $h2_fir_ref) = ( {}, {} ); - $h2_heads_ref = $sync->{imap2}->parse_headers([@h2_msgs_not_in_cache], @useheader) if (@h2_msgs_not_in_cache); + my ( $h2_heads_ref, $h2_fir_ref ) = ( {}, {} ); + $h2_heads_ref = $sync->{ imap2 }->parse_headers( [ @h2_msgs_not_in_cache ], @{ $sync->{ useheader } } ) if ( @h2_msgs_not_in_cache ); $sync->{ debug } and myprint( "Host2: parsing headers of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ; $sync->{ debug } and myprint( "Host2: getting flags idate and sizes of folder [$h2_fold]\n" ) ; - @{ $h2_fir_ref }{@h2_msgs} = ( ); # fetch_hash can select by uid with last arg as ref + @{ $h2_fir_ref }{ @h2_msgs } = ( ); # fetch_hash can select by uid with last arg as ref my @h2_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ; if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h2_common_fetch_param, 'X-GM-LABELS' ; } - 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 $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 ( $sync->{ abletosearch2 } and scalar( @h2_msgs ) ) + { + $h2_fir_ref = $sync->{ imap2 }->fetch_hash( \@h2_msgs, @h2_common_fetch_param, $h2_fir_ref ) ; + } + else + { + my $fetch_hash_uids = $sync->{ fetch_hash_set } || "1:*" ; + $h2_fir_ref = $sync->{ imap2 }->fetch_hash( $fetch_hash_uids, @h2_common_fetch_param, $h2_fir_ref ) if ( @h2_msgs ) ; } @@ -2650,12 +2805,15 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) my @h2_msgs_duplicate; foreach my $m (@h2_msgs_not_in_cache) { - my $rc = parse_header_msg( $sync, $sync->{imap2}, $m, $h2_heads_ref, $h2_fir_ref, 'Host2', \%h2_hash ) ; + my $rc = parse_header_msg( $sync, $sync->{ imap2 }, $m, $h2_fold, $h2_heads_ref, $h2_fir_ref, 'Host2', \%h2_hash ) ; my $h2_size = $h2_fir_ref->{$m}->{'RFC822.SIZE'} || 0 ; - if (! defined $rc ) { + if (! defined $rc ) + { myprint( "Host2: $h2_fold/$m size $h2_size ignored (no wanted headers so we ignore this message)\n" ) ; $h2_nb_msg_noheader += 1 ; - } elsif( 0 == $rc ) { + } + elsif( 0 == $rc ) + { # duplicate $sync->{ acc2 }->{ nb_msg_duplicate } += 1 ; push @h2_msgs_duplicate, $m ; @@ -2691,75 +2849,87 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) # Deletions on account2. - if( $sync->{ delete2duplicates } and not exists $h2_folders_from_1_several{ $h2_fold } ) { + if( $sync->{ delete2duplicates } and not exists $h2_folders_from_1_several{ $h2_fold } ) + { my @h2_expunge ; foreach my $h2_msg ( @h2_msgs_duplicate ) { - myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2 $sync->{dry_message}\n" ) ; + 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 } ) { + if ( ! $sync->{ dry } ) + { $sync->{ imap2 }->delete_message( $h2_msg ) ; $sync->{ acc2 }->{ nb_msg_deleted } += 1 ; } } my $cnt = scalar @h2_expunge ; - if( @h2_expunge and not $sync->{ expunge2 } ) { - myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; - $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; + if( @h2_expunge and not $sync->{ expunge2 } ) + { + myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{ dry_message }\n" ) ; + $sync->{ imap2 }->uidexpunge( \@h2_expunge ) if ! $sync->{ dry } ; } if ( $sync->{ expunge2 } ){ - myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; - $sync->{imap2}->expunge( ) if ! $sync->{dry} ; + myprint( "Host2: Expunging folder $h2_fold $sync->{ dry_message }\n" ) ; + $sync->{ imap2 }->expunge( ) if ! $sync->{ dry } ; } } - if( $sync->{ delete2 } and not exists $h2_folders_from_1_several{ $h2_fold } ) { + if( $sync->{ delete2 } and not exists $h2_folders_from_1_several{ $h2_fold } ) + { # No host1 folders f1a f1b ... going all to same f2 (via --regextrans2) my @h2_expunge; foreach my $m_id (@h2_hash_keys_sorted_by_uid) { #myprint( "$m_id " ) ; - if ( ! exists $h1_hash{$m_id} ) { + if ( ! exists $h1_hash{$m_id} ) + { my $h2_msg = $h2_hash{$m_id}{'m'}; my $h2_flags = $h2_hash{$m_id}{'F'} || q{}; my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0; - myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted on host2 [$m_id] $sync->{dry_message}\n" ) + 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 ) ) { + if ( ! ( $sync->{ dry } or $isdel ) ) + { $sync->{ imap2 }->delete_message( $h2_msg ); $sync->{ acc2 }->{ nb_msg_deleted } += 1; } } } foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) { - myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2 $sync->{dry_message}\n" ) ; + 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} ) { + if ( ! $sync->{ dry } ) + { $sync->{ imap2 }->delete_message( $h2_msg ); $sync->{ acc2 }->{ nb_msg_deleted } += 1; } } my $cnt = scalar @h2_expunge ; - if( @h2_expunge and not $sync->{ expunge2 } ) { - myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; - $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; + if( @h2_expunge and not $sync->{ expunge2 } ) + { + myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{ dry_message }\n" ) ; + $sync->{ imap2 }->uidexpunge( \@h2_expunge ) if ! $sync->{ dry } ; } - if ( $sync->{ expunge2 } ) { - myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; - $sync->{imap2}->expunge( ) if ! $sync->{dry} ; + if ( $sync->{ expunge2 } ) + { + myprint( "Host2: Expunging folder $h2_fold $sync->{ dry_message }\n" ) ; + $sync->{ imap2 }->expunge( ) if ! $sync->{ dry } ; } } - if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } ) { + if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } ) + { myprint( "Host2: folder $h2_fold $h2_folders_from_1_several{ $h2_fold } folders left to sync there\n" ) ; my @h2_expunge; foreach my $m_id ( @h2_hash_keys_sorted_by_uid ) { my $h2_msg = $h2_hash{ $m_id }{ 'm' } ; - if ( ! exists $h1_hash{ $m_id } ) { + if ( ! exists $h1_hash{ $m_id } ) + { my $h2_flags = $h2_hash{ $m_id }{ 'F' } || q{} ; my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0 ; - if ( ! $isdel ) { + if ( ! $isdel ) + { $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [$m_id]\n" ) ; $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ; } @@ -2779,17 +2949,22 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) } - if ( 0 == $h2_folders_from_1_several{ $h2_fold } ) { + if ( 0 == $h2_folders_from_1_several{ $h2_fold } ) + { # last host1 folder going to $h2_fold myprint( "Last host1 folder going to $h2_fold\n" ) ; foreach my $h2_msg ( keys %{ $uid_candidate_for_deletion{ $h2_fold } } ) { $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion\n" ) ; - if ( exists $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg } ) { + if ( exists $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg } ) + { $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg canceled deletion\n" ) ; - }else{ - myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted $sync->{dry_message}\n" ) ; + } + 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} ) { + if ( ! $sync->{ dry} ) + { $sync->{ imap2 }->delete_message( $h2_msg ) ; $sync->{ acc2 }->{ nb_msg_deleted } += 1 ; } @@ -2798,19 +2973,21 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) } my $cnt = scalar @h2_expunge ; - if( @h2_expunge and not $sync->{ expunge2 } ) { - myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; - $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; + if ( @h2_expunge and not $sync->{ expunge2 } ) + { + myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{ dry_message }\n" ) ; + $sync->{ imap2 }->uidexpunge( \@h2_expunge ) if ! $sync->{ dry } ; } - if ( $sync->{ expunge2 } ) { - myprint( "Host2: Expunging host2 folder $h2_fold $sync->{dry_message}\n" ) ; - $sync->{imap2}->expunge( ) if ! $sync->{dry} ; + if ( $sync->{ expunge2 } ) + { + myprint( "Host2: Expunging host2 folder $h2_fold $sync->{ dry_message }\n" ) ; + $sync->{ imap2 }->expunge( ) if ! $sync->{ dry } ; } $h2_folders_from_1_several{ $h2_fold }-- ; } - my $h2_uidnext = $sync->{imap2}->uidnext( $h2_fold ) ; + my $h2_uidnext = $sync->{ imap2 }->uidnext( $h2_fold ) ; $sync->{ debug } and myprint( "Host2: uidnext is $h2_uidnext\n" ) ; $h2_uidguess = $h2_uidnext ; @@ -2827,16 +3004,17 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) my $h1_msg = $h1_hash{$m_id}{'m'}; my $h1_idate = $h1_hash{$m_id}{'D'}; - #my $labels = labels( $sync->{imap1}, $h1_msg ) ; + #my $labels = labels( $sync->{ imap1 }, $h1_msg ) ; #print "LABELS: $labels\n" ; if ( ( not exists $h2_hash{ $m_id } ) and ( not ( exists $sync->{ h2_folders_of_md5 }->{ $m_id } ) - or not $skipcrossduplicates ) ) + or not $sync->{ skipcrossduplicates } ) ) { # copy - my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; - if ( $h2_msg and $sync->{ delete1 } and not $sync->{ expungeaftereach } ) { + my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $cache_dir ) ; + if ( $h2_msg and $sync->{ delete1 } and not $sync->{ expungeaftereach } ) + { # not expunged push @h1_msgs_to_delete, $h1_msg ; } @@ -2849,12 +3027,14 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) } # - if( $sync->{ delete2 } and ( exists $h2_folders_from_1_several{ $h2_fold } ) and $h2_msg ) { + if ( $sync->{ delete2 } and ( exists $h2_folders_from_1_several{ $h2_fold } ) and $h2_msg ) + { myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ; $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; } - if ( total_bytes_max_reached( $sync ) ) { + if ( total_bytes_max_reached( $sync ) ) + { # Still a bug when using --delete1 --noexpungeaftereach # same thing below on all total_bytes_max_reached! last FOLDER ; @@ -2868,9 +3048,9 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) { my $h2_msg = $h2_hash{$m_id}{'m'} ; $sync->{ debug } and myprint( "Host1: found that msg $h1_fold/$h1_msg equals Host2 $h2_fold/$h2_msg\n" ) ; - if ( $usecache ) + if ( $sync->{ usecache } ) { - $debugcache and myprint( "touch $cache_dir/${h1_msg}_$h2_msg\n" ) ; + $sync->{ debugcache } and myprint( "touch $cache_dir/${h1_msg}_$h2_msg\n" ) ; touch( "$cache_dir/${h1_msg}_$h2_msg" ) or croak( "Couldn't touch $cache_dir/${h1_msg}_$h2_msg" ) ; } @@ -2878,7 +3058,7 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) elsif( exists $sync->{ h2_folders_of_md5 }->{ $m_id } ) { my @folders_dup = keys %{ $sync->{ h2_folders_of_md5 }->{ $m_id } } ; - ( $sync->{ debug } or $debugcrossduplicates ) and myprint( "Host1: found that msg $h1_fold/$h1_msg is also in Host2 folders @folders_dup\n" ) ; + ( $sync->{ debug } or $sync->{ debugcrossduplicates } ) and myprint( "Host1: found that msg $h1_fold/$h1_msg is also in Host2 folders @folders_dup\n" ) ; $sync->{ h2_nb_msg_crossdup } +=1 ; } $sync->{ total_bytes_skipped } += $h1_size ; @@ -2886,11 +3066,13 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) $sync->{ h1_nb_msg_processed } +=1 ; } - if ( exists $h2_hash{ $m_id } ) { + if ( exists $h2_hash{ $m_id } ) + { #$debug and myprint( "MESSAGE $m_id\n" ) ; my $h2_msg = $h2_hash{$m_id}{'m'}; - if ( $sync->{resyncflags} ) { - sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; + if ( $sync->{resyncflags} ) + { + sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $h1_fir_ref, $h2_fir_ref ) ; } # Good my $h2_size = $h2_hash{$m_id}{'s'}; @@ -2905,7 +3087,8 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } - if ( $sync->{ delete1 } ) { + if ( $sync->{ delete1 } ) + { push @h1_msgs_to_delete, $h1_msg ; } } @@ -2922,10 +3105,10 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) foreach my $h1_msg ( @h1_msgs_in_cache ) { my $h2_msg = $cache_1_2_ref->{ $h1_msg } ; - $debugcache and myprint( "cache messages update flags $h1_msg->$h2_msg\n" ) ; - if ( $sync->{resyncflags} ) + $sync->{ debugcache } and myprint( "cache messages update flags $h1_msg->$h2_msg\n" ) ; + if ( $sync->{ resyncflags } ) { - sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; + sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $h1_fir_ref, $h2_fir_ref ) ; } my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } || 0 ; $sync->{ total_bytes_skipped } += $h1_size; @@ -2945,8 +3128,9 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) $sync->{ debug } and myprint( "Copy by uid $h1_fold/$h1_msg\n" ) ; if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } - my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; - if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } and $h2_msg ) { + my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $cache_dir ) ; + if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } and $h2_msg ) + { myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ; $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; } @@ -2954,12 +3138,12 @@ FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) } if ( $sync->{ expunge1 } ){ - myprint( "Host1: Expunging folder $h1_fold $sync->{dry_message}\n" ) ; - if ( ! $sync->{dry} ) { $sync->{imap1}->expunge( ) } ; + myprint( "Host1: Expunging folder $h1_fold $sync->{ dry_message }\n" ) ; + if ( ! $sync->{ dry } ) { $sync->{ imap1 }->expunge( ) } ; } if ( $sync->{ expunge2 } ){ - myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; - if ( ! $sync->{dry} ) { $sync->{imap2}->expunge( ) } ; + myprint( "Host2: Expunging folder $h2_fold $sync->{ dry_message }\n" ) ; + if ( ! $sync->{ dry } ) { $sync->{ imap2 }->expunge( ) } ; } $sync->{ debug } and myprint( 'Time: ', timenext( $sync ), " s\n" ) ; } @@ -2968,14 +3152,16 @@ eta_print( $sync ) ; myprint( "++++ End looping on each folder\n" ) ; -if ( $sync->{ delete1 } and $sync->{ delete1emptyfolders } ) { +if ( $sync->{ delete1 } and $sync->{ delete1emptyfolders } ) +{ delete1emptyfolders( $sync ) ; } ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( 'Time: ', timenext( $sync ), " s\n" ) ; -if ( $sync->{ foldersizesatend } ) { +if ( $sync->{ foldersizesatend } ) +{ myprint( << 'END_SIZE' ) ; Folders sizes after the synchronization. @@ -2985,9 +3171,6 @@ 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( ) ; } do_and_print_stats( $sync ) ; @@ -2998,11 +3181,16 @@ if ( $sync->{ nb_errors } ) } -if ( $sync->{ testslive } or $sync->{ testslive6 } ) +if ( $sync->{ testslive } or $sync->{ testslive6 } or $sync->{ testslive2 } ) { tests_live_result( $sync->{ nb_errors } ) ; } +final_emails_reports( $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( ) ; } if ( $sync->{ nb_errors } ) { @@ -3015,7 +3203,7 @@ else } return ; -} +} # END of sub single_sync @@ -3034,6 +3222,7 @@ sub myprintf return ; } +# What did I have in mind with this redundant/equivalent function? sub mysprintf { my( $format, @list ) = @ARG ; @@ -3137,16 +3326,16 @@ sub tests_print_output_if_needed 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 ; } @@ -3154,11 +3343,11 @@ sub tests_print_output_if_needed 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{} ; @@ -3168,10 +3357,50 @@ sub print_output_if_needed myprint( $output ) ; return $output ; } - + } +sub stderr_to_stdout +{ + my $mysync = shift @ARG ; + if ( $mysync->{ tee} ) + { + *STDERR = *${ $mysync->{ tee } }{ IO } ; + } + else + { + *STDERR = *STDOUT ; + } + return ; +} + + + +sub determine_delete2duplicates +{ + my $mysync = shift @ARG ; + + if ( defined $mysync->{ delete2duplicates } ) + { + return $mysync->{ delete2duplicates } ; + } + + if ( $mysync->{ syncduplicates } ) + { + return 0 ; + } + + if ( $sync->{ delete2 } ) + { + return 1 ; + } + + return ; +} + + + sub define_pidfile { @@ -3189,7 +3418,7 @@ sub define_pidfile my $pidfile_basename ; - if ( $ENV{ 'NET_SERVER_SOFTWARE' } and ( $ENV{ 'NET_SERVER_SOFTWARE' } =~ /Net::Server::HTTP/ ) ) + if ( not under_docker_context( $mysync ) and under_Net_Server_HTTP( ) ) { # under local webserver $pidfile_basename = 'imapsync' . '_' . $account1_filtered . '_' . $account2_filtered . '.pid' ; @@ -3221,8 +3450,8 @@ sub abortfile return $abortfile ; } -sub tests_kill_zero -{ +sub tests_kill_zero +{ note( 'Entering tests_kill_zero()' ) ; @@ -3234,7 +3463,7 @@ sub tests_kill_zero is( 1, kill( 'ZERO', $PROCESS_ID ), "kill ZERO : myself $PROCESS_ID => 1" ) ; is( 2, kill( 'ZERO', $PROCESS_ID, $PROCESS_ID ), "kill ZERO : myself $PROCESS_ID $PROCESS_ID => 2" ) ; - if ( (-e '/.dockerenv' ) or ( 0 == $EFFECTIVE_USER_ID) ) + if ( skip_docker( ) or ( 0 == $EFFECTIVE_USER_ID) ) { is( 1, kill( 'ZERO', 1 ), "kill ZERO : pid 1 => 1 (docker context or root)" ) ; is( 2, kill( 'ZERO', $PROCESS_ID, 1 ), "kill ZERO : myself + pid 1, $PROCESS_ID 1 => 2 (docker context or root)" ) ; @@ -3285,7 +3514,7 @@ sub tests_kill_zero note( 'Leaving tests_kill_zero()' ) ; return ; -} +} @@ -3394,26 +3623,31 @@ sub tests_killpid_by_brother sub killpid { - my $pidtokill = shift ; + my $pidtokill = shift @ARG ; - if ( ! $pidtokill ) { + if ( ! $pidtokill ) + { myprint( "No process to kill.\n" ) ; return ; } - if ( $PROCESS_ID == $pidtokill ) { + if ( $PROCESS_ID == $pidtokill ) + { myprint( "I will not kill myself pid $PROCESS_ID via killpid. Sractch it!\n" ) ; return ; } # First ask for suicide - if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) { + if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) + { myprint( "Sending signal QUIT to PID $pidtokill \n" ) ; kill 'QUIT', $pidtokill ; sleep 3 ; waitpid( $pidtokill, WNOHANG) ; - }else{ + } + else + { myprint( "Can not send signal kill ZERO to PID $pidtokill.\n" ) ; return ; } @@ -3421,20 +3655,26 @@ sub killpid #while ( waitpid( $pidtokill, WNOHANG) > 0 ) { } ; # Then murder - if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) { + if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) + { myprint( "Sending signal KILL to PID $pidtokill \n" ) ; kill 'KILL', $pidtokill ; sleep 1 ; waitpid( $pidtokill, WNOHANG) ; - }else{ + } + else + { myprint( "Process PID $pidtokill ended.\n" ) ; return 1; } # Well ... - if ( kill( 'ZERO', $pidtokill ) or ( 'xMSWin32' eq $OSNAME ) ) { + if ( kill( 'ZERO', $pidtokill ) or ( 'xMSWin32' eq $OSNAME ) ) + { myprint( "Process PID $pidtokill seems still there. Can not do much.\n" ) ; return ; - }else{ + } + else + { myprint( "Process PID $pidtokill ended.\n" ) ; return 1; } @@ -3454,31 +3694,33 @@ sub tests_abort -sub abort +sub abort { my $mysync = shift @ARG ; myprint( "In abort\n" ) ; if ( not $mysync ) { return ; } - if ( ! -r $mysync->{pidfile} ) { - myprint( "In abort: Can not read pidfile $mysync->{pidfile}\n" ) ; + if ( ! -r $mysync->{ pidfile } ) + { + myprint( "In abort: Can not read pidfile $mysync->{ pidfile }\n" ) ; return ; } - my $pidtokill = firstline( $mysync->{pidfile} ) ; - if ( ! $pidtokill ) { - myprint( "In abort: No process to abort in $mysync->{pidfile}\n" ) ; + my $pidtokill = firstline( $mysync->{ pidfile } ) ; + if ( ! $pidtokill ) + { + myprint( "In abort: No process to abort in $mysync->{ pidfile }\n" ) ; return ; } if ( ! match_a_pid_number( $pidtokill ) ) { - myprint( "In abort: pid $pidtokill in $mysync->{pidfile} is not a pid number\n" ) ; + myprint( "In abort: pid $pidtokill in $mysync->{ pidfile } is not a pid number\n" ) ; return ; } - if ( $mysync->{abortbyfile} ) + if ( $mysync->{ abortbyfile } ) { abortbyfile( $mysync, $pidtokill ) ; } @@ -3487,7 +3729,7 @@ sub abort killpid( $pidtokill ) ; } return ; -} +} sub abortbyfile { @@ -3531,8 +3773,8 @@ sub tests_under_docker_context sub under_docker_context { - my $mysync = shift ; - + my $mysync = shift @ARG ; + if ( ! defined $mysync ) { return ; } if ( defined $mysync->{ dockercontext } ) @@ -3540,7 +3782,7 @@ sub under_docker_context return( $mysync->{ dockercontext } ) ; } - if ( -e '/.dockerenv' ) + if ( -e '/Dockerfile' ) { return 1 ; } @@ -3554,42 +3796,30 @@ sub under_docker_context sub docker_context -{ - my $mysync = shift ; +{ + my $mysync = shift @ARG ; if ( ! under_docker_context( $mysync ) ) { return ; } - output( $mysync, "Docker context detected with the file /.dockerenv\n" ) ; - # No pidfile by default + output( $mysync, "Docker context detected with the file /Dockerfile, or forced\n" ) ; - $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 ; - } # In case something is written relatively to . - my $tmp_dir = "/var/tmp/uid_$EFFECTIVE_USER_ID" ; - mkpath( $tmp_dir ) ; # silly? No. it is for imapsync --version being ok. - do_valid_directory( $tmp_dir ) ; - output( $mysync, "Changing current directory to $tmp_dir\n" ) ; - chdir $tmp_dir ; - + my $tmpdir = "/var/tmp/uid_$EFFECTIVE_USER_ID" ; + mkpath( $tmpdir ) ; # silly? No. it is for imapsync --version being ok. + make_valid_directory( $mysync, $tmpdir ) ; + output( $mysync, "Changing current directory from " . getcwd() . " to $tmpdir\n" ) ; + chdir $tmpdir ; + return ; } sub cgibegin { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! under_cgi_context( $mysync ) ) { return ; } require CGI ; CGI->import( qw( -no_debug -utf8 ) ) ; @@ -3631,18 +3861,19 @@ sub tests_under_cgi_context sub under_cgi_context { - my $mysync = shift ; + my $mysync = shift @ARG ; # Under cgi context - if ( $ENV{SERVER_SOFTWARE} ) { + if ( $ENV{SERVER_SOFTWARE} ) + { return 1 ; } # Not in cgi context return ; } -sub cgibuildheader +sub cgibuildheader { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! under_cgi_context( $mysync ) ) { return ; } my $imapsync_runs = $mysync->{cgi}->cookie( 'imapsync_runs' ) || 0 ; @@ -3653,23 +3884,35 @@ sub cgibuildheader -path => '/cgi-bin/imapsync', ) ; my $httpheader ; - if ( $mysync->{ abort } ) { + if ( $mysync->{ abort } ) + { $httpheader = $mysync->{cgi}->header( -type => 'text/plain; charset=UTF-8', - -status => '200 OK to abort syncing IMAP boxes' . ". Here is " . hostname(), + -status => '200 OK to abort syncing IMAP boxes. ' . load_message( $mysync ), ) ; - }elsif( $mysync->{ loaddelay } ) { -# https://tools.ietf.org/html/rfc2616#section-10.5.4 -# 503 Service Unavailable -# The server is currently unable to handle the request due to a temporary overloading or maintenance of the server. + } + elsif( ! $mysync->{ diskspace_available } ) + { $httpheader = $mysync->{cgi}->header( -type => 'text/plain; charset=UTF-8', - -status => '503 Service Unavailable' . ". Be back in $mysync->{ loaddelay } min. Load on " . hostname() . " is $mysync->{ loadavg }", + -status => '503 Service Unavailable. ' . "Be back later. " . 'No disk space available', ) ; - }else{ + } + elsif( $mysync->{ heavy_load_reached } ) + { + # https://tools.ietf.org/html/rfc2616#section-10.5.4 + # 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; charset=UTF-8', + -status => '503 Service Unavailable. ' . "Be back later. " . load_message( $mysync ), + ) ; + } + else + { $httpheader = $mysync->{cgi}->header( -type => 'text/plain; charset=UTF-8', - -status => '200 OK to sync IMAP boxes' . ". Load on " . hostname() . " is $mysync->{ loadavg }", + -status => '200 OK to sync IMAP boxes. ' . load_message( $mysync ), -cookie => $cookie, ) ; } @@ -3678,22 +3921,324 @@ sub cgibuildheader return ; } -sub cgiload +sub load_message { - # Exit on heavy load in CGI context - my $mysync = shift ; - if ( ! under_cgi_context( $mysync ) ) { return ; } - if ( $mysync->{ abort } ) { return ; } # keep going to abort since some ressources will be free soon - if ( $mysync->{ loaddelay } ) + my $mysync = shift @ARG ; + + my $message = "Load on " . hostname() . " is $mysync->{ loadavg }" ; + return $message ; +} + + +sub setexitonload +{ + my $mysync = shift @ARG ; + +# No exit on heavy load by default in normal context. +# But exit on heavy load in CGI context + + if ( under_cgi_context( $mysync ) ) { - $mysync->{nb_errors}++ ; + $mysync->{ exitonload } = defined $mysync->{ exitonload } ? $mysync->{ exitonload } : 1 ; + } + else + { + $mysync->{ exitonload } = defined $mysync->{ exitonload } ? $mysync->{ exitonload } : 0 ; + } + + return ; +} + + + +sub cgi_exit_on_heavy_load +{ + # Exit on heavy load in CGI context + my $mysync = shift @ARG ; + #if ( ! under_cgi_context( $mysync ) ) { return ; } + if ( $mysync->{ abort } ) { return ; } # keep going to abort since some ressources will be free soon + if ( $mysync->{ heavy_load_reached } ) + { + $mysync->{ nb_errors }++ ; exit_clean( $mysync, $EX_UNAVAILABLE, - "Server is on heavy load. Be back in $mysync->{ loaddelay } min. Load is $mysync->{ loadavg }\n" + "Server is on heavy load. Be back later. " . load_message( $mysync ) . "\n" ) ; } return ; +} + + +sub cgi_exit_on_no_disk_space +{ + # Exit on no disk space in CGI context + my $mysync = shift @ARG ; + if ( ! under_cgi_context( $mysync ) ) { return ; } + if ( ! $mysync->{ diskspace_available } ) + { + $mysync->{ nb_errors }++ ; + exit_clean( $mysync, $EX_UNAVAILABLE, + "Server is in bad shape. Be back later. " . 'No disk space available' . "\n" + ) ; + } + return ; +} + + + +sub tests_heavy_load_reached +{ + note( 'Entering tests_is_heavy_load_reached()' ) ; + + like( heavy_load_reached( ), qr{^(0|1)$}xms, 'heavy_load_reached: no args => 0 or 1' ) ; + + my $mysync = { } ; + like( heavy_load_reached( $mysync ), qr{^(0|1)$}xms, 'heavy_load_reached: { } => 0 or 1' ) ; + + $mysync->{ exitonload } = 0 ; + is( 0, heavy_load_reached( $mysync ), 'heavy_load_reached: exitonload=0 => 0 ' ) ; + + note( 'Leaving tests_heavy_load_reached()' ) ; + return ; } +sub heavy_load_reached +{ + my $mysync = shift @ARG ; + + my $heavy_load_reached = 0 ; + + if ( defined( $mysync->{ exitonload } ) && ( ! $mysync->{ exitonload } ) ) + { + return 0 ; + } + + my $heavy_load_reached_by_memory = heavy_load_reached_by_memory( $mysync ) ; + my $heavy_load_reached_by_cpu = heavy_load_reached_by_cpu( $mysync ) ; + + if ( $heavy_load_reached_by_memory || $heavy_load_reached_by_cpu ) + { + $heavy_load_reached = 1 ; + } + else + { + $heavy_load_reached = 0 ; + } + + return $heavy_load_reached ; +} + + +sub tests_heavy_load_reached_by_cpu +{ + note( 'Entering tests_heavy_load_reached_by_cpu()' ) ; + + note( join( " ", loadavg( ), 'heavy_load_reached_by_cpu ', heavy_load_reached_by_cpu( ) ) ) ; + like( heavy_load_reached_by_cpu( ), qr{^(0|1)$}xms, 'heavy_load_reached_by_cpu: no args => 0 or 1' ) ; + + my $mysync = { } ; + like( heavy_load_reached_by_cpu( $mysync ), qr{^(0|1)$}xms, 'heavy_load_reached_by_cpu: { } => 0 or 1' ) ; + + note( 'Leaving tests_heavy_load_reached_by_cpu()' ) ; + return ; +} + +sub heavy_load_reached_by_cpu +{ + my $mysync = shift @ARG ; + + my $heavy_load_reached = 0 ; + + my $load_and_delay = load_per_cpu( $mysync ) ; + + if ( $load_and_delay ) + { + $heavy_load_reached = 1 ; + } + else + { + $heavy_load_reached = 0 ; + } + + return $heavy_load_reached ; +} + + +sub tests_load_per_cpu +{ + note( 'Entering tests_load_per_cpu()' ) ; + + note( join( " ", 'loadavg:', loadavg( ), 'cpu_number:', cpu_number( ), 'load_per_cpu ', load_per_cpu( ) ) ) ; + like( load_per_cpu( ), qr{^([0-9.]+)$}xms, 'tests_load_per_cpu: no args => number' ) ; + + my $mysync = { } ; + like( load_per_cpu( $mysync ), qr{^([0-9.]+)$}xms, 'tests_load_per_cpu: { } => number' ) ; + + note( 'Leaving tests_load_per_cpu()' ) ; + return ; +} + + +sub load_per_cpu +{ + my $mysync = shift @ARG ; + + return load_and_delay( 1, cpu_number( ), loadavg( ) ) ; +} + +sub tests_heavy_load_reached_by_memory +{ + note( 'Entering tests_heavy_load_reached_by_memory()' ) ; + + like( heavy_load_reached_by_memory( ), qr{^(0|1)$}xms, 'heavy_load_reached_by_memory: no args => 0 or 1' ) ; + + my $mysync = { } ; + like( heavy_load_reached_by_memory( $mysync ), qr{^(0|1)$}xms, 'heavy_load_reached_by_memory: { } => 0 or 1' ) ; + + note( 'Leaving tests_heavy_load_reached_by_memory()' ) ; + return ; +} + + +sub heavy_load_reached_by_memory +{ + my $mysync = shift @ARG ; + + my $heavy_load_reached = 0 ; + + my $heavy_load_percent_threshold = heavy_load_percent_threshold( $mysync ) ; + my $memory_consumption_all_pids_percent = memory_consumption_all_pids_percent( $mysync ) ; + + if ( $memory_consumption_all_pids_percent > $heavy_load_percent_threshold ) + { + $heavy_load_reached = 1 ; + } + else + { + $heavy_load_reached = 0 ; + } + + return $heavy_load_reached ; +} + +sub tests_heavy_load_percent_threshold +{ + note( 'Entering tests_heavy_load_percent_threshold()' ) ; + note( heavy_load_percent_threshold( ) . " (%)" ) ; + like( heavy_load_percent_threshold( ), qr{^\d+$}xms, 'heavy_load_percent_threshold: no args => integer' ) ; + my $mysync = { } ; + like( heavy_load_percent_threshold( ), qr{^\d+$}xms, 'heavy_load_percent_threshold: { } => integer' ) ; + + note( 'Leaving tests_heavy_load_percent_threshold()' ) ; + return ; +} + + +sub heavy_load_percent_threshold +{ + my $mysync = shift @ARG ; + + my $total_memory_bytes = total_ram_memory_bytes( ) || return 0 ; + my $memory_footprint_average_bytes = 250_000_000 ; + # This threshold leaves 4 memory imapsync memory footprints to the host, ie 1000 MB free for anything else. + # Small systems like 2 GB ones or even less can then present poor imapsync capacity, that's life man. + my $heavy_load_percent_threshold = max( 0, int( 100 * ( $total_memory_bytes - ( 4 * $memory_footprint_average_bytes ) ) / $total_memory_bytes ) ) ; + + return $heavy_load_percent_threshold ; +} + + +sub tests_diskspace_available +{ + note( 'Entering tests_diskspace_available()' ) ; + + is( 1, diskspace_available( ), 'tests_diskspace_available: no args => 1, could touch /var/tmp/imapsync_test_diskspace_available' ) ; + + SKIP: + { + if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests not done under MSWin32', 4 ) ; } + is( undef, -e '/var/tmp/imapsync_test_diskspace_available', 'tests_diskspace_available: removed /var/tmp/imapsync_test_diskspace_available' ) ; + + # with a parameter + is( 1, diskspace_available( '/var/tmp/imapsync_test_diskspace_available2' ), 'tests_diskspace_available: no args => 1, could touch /var/tmp/imapsync_test_diskspace_available2' ) ; + is( undef, -e '/var/tmp/imapsync_test_diskspace_available2', 'tests_diskspace_available: removed /var/tmp/imapsync_test_diskspace_available2' ) ; + + is( 0, diskspace_available( '/no/no/no/no' ), 'tests_diskspace_available: /no/no/no/no => undef' ) ; + } + note( 'Leaving tests_diskspace_available()' ) ; + return ; +} + + +sub diskspace_available +{ + # return 1 if diskspace available or under windows + if ( 'MSWin32' eq $OSNAME ) + { + return 1 ; + } + my $file = shift || '/var/tmp/imapsync_test_diskspace_available' ; + my $touch_test = mkdir( $file ) ; + rmdir( $file ) ; + return( $touch_test ) ; +} + + + +sub tests_tmpdir +{ + note( 'Entering tests_tmpdir()' ) ; + + is( './', tmpdir( ), 'tests_tmpdir: no args => ./' ) ; + my $mysync = { } ; + + # There is a HOME environment variable + { + local $ENV{ 'HOME' } = 'Beurk' ; + is( 'Beurk/tmp', tmpdir( $mysync ), 'tests_tmpdir: {} + $HOME => $HOME/tmp' ) ; + + undef( $ENV{ 'HOME' } ) ; + is( './', tmpdir( $mysync ), 'tests_tmpdir: {} + no $HOME => ./' ) ; + + $mysync->{ tmpdir } = 'MyBeurk/truc' ; + is( 'MyBeurk/truc', tmpdir( $mysync ), 'tests_tmpdir: {}->{tmpdir} + $HOME => {}->{tmpdir}' ) ; + } + + + note( 'Leaving tests_tmpdir()' ) ; + return ; +} + + + +sub tmpdir +{ + my $mysync = shift @ARG ; + + if ( ! defined( $mysync ) ) + { + return( './' ) ; + } + elsif ( defined( $mysync->{ tmpdir } ) ) + { + return( $mysync->{ tmpdir } ) ; + } + elsif ( defined( $ENV{ 'HOME' } ) ) + { + return( $ENV{ 'HOME' } . '/tmp' ) ; + } + else + { + return( './' ) ; + } + + + + return ; +} + + + + sub tests_set_umask { note( 'Entering tests_set_umask()' ) ; @@ -3701,7 +4246,8 @@ sub tests_set_umask my $save_umask = umask ; my $mysync = {} ; - if ( 'MSWin32' eq $OSNAME ) { + if ( 'MSWin32' eq $OSNAME ) + { is( undef, set_umask( $mysync ), "set_umask: set failure to $UMASK_PARANO on MSWin32" ) ; }else{ is( 1, set_umask( $mysync ), "set_umask: set to $UMASK_PARANO" ) ; @@ -3714,11 +4260,12 @@ sub tests_set_umask sub set_umask { - my $mysync = shift ; + my $mysync = shift @ARG ; my $previous_umask = umask_str( ) ; my $new_umask = umask_str( $UMASK_PARANO ) ; output( $mysync, "Umask set with $new_umask (was $previous_umask)\n" ) ; - if ( $new_umask eq $UMASK_PARANO ) { + if ( $new_umask eq $UMASK_PARANO ) + { return 1 ; } return ; @@ -3740,14 +4287,15 @@ sub tests_umask_str is( '0400', umask_str( '0400' ), 'umask_str: 0400 => 0400' ) ; is( '0600', umask_str( '0600' ), 'umask_str: 0600 => 0600' ) ; - SKIP: { - if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests success only for Unix', 6 ) ; } - is( '0100', umask_str( '0100' ), 'umask_str: 0100 => 0100' ) ; - is( '0001', umask_str( '0001' ), 'umask_str: 0001 => 0001' ) ; - is( '0777', umask_str( '0777' ), 'umask_str: 0777 => 0777' ) ; - is( '0777', umask_str( '00777' ), 'umask_str: 00777 => 0777' ) ; - is( '0777', umask_str( ' 777 ' ), 'umask_str: 777 => 0777' ) ; - is( "$UMASK_PARANO", umask_str( $UMASK_PARANO ), "umask_str: UMASK_PARANO $UMASK_PARANO => $UMASK_PARANO" ) ; + SKIP: + { + if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests success only for Unix', 6 ) ; } + is( '0100', umask_str( '0100' ), 'umask_str: 0100 => 0100' ) ; + is( '0001', umask_str( '0001' ), 'umask_str: 0001 => 0001' ) ; + is( '0777', umask_str( '0777' ), 'umask_str: 0777 => 0777' ) ; + is( '0777', umask_str( '00777' ), 'umask_str: 00777 => 0777' ) ; + is( '0777', umask_str( ' 777 ' ), 'umask_str: 777 => 0777' ) ; + is( "$UMASK_PARANO", umask_str( $UMASK_PARANO ), "umask_str: UMASK_PARANO $UMASK_PARANO => $UMASK_PARANO" ) ; } is( $save_umask_str, umask_str( $save_umask_str ), 'umask_str: restore with str' ) ; @@ -3761,9 +4309,10 @@ sub tests_umask_str sub umask_str { - my $value = shift ; + my $value = shift @ARG ; - if ( defined $value ) { + if ( defined $value ) + { umask oct( $value ) ; } my $current = umask ; @@ -3795,45 +4344,138 @@ sub tests_umask return ; } -sub buggyflagsregex + +sub make_var_array_to_a_hash { - # 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 ) ; + my $mysync = shift @ARG ; + %{ $mysync->{ varh } } = split_around_equal( @{ $mysync->{ var } } ) ; + + return ; } +sub under_Net_Server_HTTP +{ + my $under_Net_Server_HTTP = $ENV{ 'NET_SERVER_SOFTWARE' } and ( $ENV{ 'NET_SERVER_SOFTWARE' } =~ /Net::Server::HTTP/ ) ; + return $under_Net_Server_HTTP ; +} + + +sub lamiral_host +{ + my $hostname = hostname() ; + if ( + ( $hostname eq 'petite' ) + or + ( $hostname eq 'ks5' ) + or + ( $hostname eq 'ks7' ) + or + ( $hostname eq 'ks8' ) + or + ( $hostname eq 'macosx' ) + or + ( $hostname eq 'i050' ) + or + ( $hostname eq 'i021' ) + ) + { + return 1 ; + } + else + { + return 0 ; + } +} + + +sub tests_cgidir +{ + note( 'Entering tests_cgidir()' ) ; + + is( undef, cgidir( ), 'tests_cgidir: no args => undef' ) ; + + SKIP: { + if ( skip_docker( ) or not lamiral_host( ) ) + { + skip( 'Tests avoided in Docker context or foreign host', 3 ) ; + } + else + { + my $mysync = { } ; + is( '/var/tmp/imapsync_cgi/385d7a4d8d428d7aa2b57c8982629e2bd67698ed', cgidir( $mysync ), 'tests_cgidir: { } => /var/tmp/imapsync_cgi/385d...' ) ; + + { + local $ENV{ NET_SERVER_SOFTWARE } = 'Net::Server::HTTP' ; + is( '.', cgidir( $mysync ), 'tests_cgidir: Net::Server::HTTP => .' ) ; + + $mysync->{ dockercontext } = 1 ; + is( '/var/tmp/imapsync_cgi/385d7a4d8d428d7aa2b57c8982629e2bd67698ed', cgidir( $mysync ), 'tests_cgidir: Net::Server::HTTP + Docker => /var/tmp/imapsync_cgi/385d...' ) ; + } ; + + } + } + + note( 'Leaving tests_cgidir()' ) ; + return ; +} + +sub cgidir +{ + my $mysync = shift @ARG ; + + if ( ! defined( $mysync ) ) { return ; } ; + + my $cgidir = shift @ARG ; + + if ( ! defined( $cgidir ) ) + { + + $mysync->{ hashfile } = $CGI_HASHFILE ; + my $hashsynclocal = hashsynclocal( $mysync ) || die "Can not get hashsynclocal. Exiting\n" ; + + if ( ! under_docker_context( $mysync ) and under_Net_Server_HTTP( ) ) + { + # under local webserver + $cgidir = q{.} ; + } + else + { + $cgidir = $CGI_TMPDIR_TOP . '/' . $hashsynclocal ; + } + } + + return( $cgidir ) ; +} + + + sub cgisetcontext { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! under_cgi_context( $mysync ) ) { return ; } output( $mysync, "Under cgi context\n" ) ; - - set_umask( $mysync ) ; # Remove all content in unsafe evaled options @{ $mysync->{ regextrans2 } } = ( ) ; @{ $mysync->{ regexflag } } = buggyflagsregex( ) ; - + @regexmess = ( ) ; @skipmess = ( ) ; @pipemess = ( ) ; - $delete2foldersonly = undef ; - $delete2foldersbutnot = undef ; - $maxlinelengthcmd = undef ; + $mysync->{ delete2foldersonly } = undef ; + $mysync->{ delete2foldersbutnot } = undef ; # Set safe default values (I hope...) - - #$mysync->{pidfile} = 'imapsync.pid' ; + #$mysync->{ pidfile } = 'imapsync.pid' ; $mysync->{ pidfilelocking } = 1 ; $mysync->{ errorsmax } = $ERRORS_MAX_CGI ; - $modulesversion = 0 ; + $mysync->{ modulesversion } = 0 ; $mysync->{ releasecheck } = defined $mysync->{ releasecheck } ? $mysync->{ releasecheck } : 1 ; - $usecache = 0 ; + $mysync->{ usecache } = 0 ; $mysync->{ showpasswords } = 0 ; $mysync->{ acc1 }->{ debugimap } = 0 ; $mysync->{ acc2 }->{ debugimap } = 0 ; @@ -3841,26 +4483,16 @@ sub cgisetcontext $mysync->{ acc1 }->{ reconnectretry } = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; $mysync->{ acc2 }->{ reconnectretry } = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; - $pipemesscheck = 0 ; + $mysync->{ 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/ ) ) - { - # under local webserver - $cgidir = q{.} ; - } - else - { - $cgidir = $CGI_TMPDIR_TOP . '/' . $hashsynclocal ; - } + $cgidir = cgidir( $mysync ) ; + -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 ) ; + #output( $mysync, cgienvcontext( $mysync ) ) ; $mysync->{ debug } and output( $mysync, 'Current directory is ' . getcwd( ) . "\n" ) ; $mysync->{ debug } and output( $mysync, 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ; $mysync->{ debug } and output( $mysync, 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ; @@ -3873,36 +4505,96 @@ sub cgisetcontext # tail -f behaviour on by default $mysync->{ tail } = defined $mysync->{ tail } ? $mysync->{ tail } : 1 ; - # not sure it's for good - @useheader = qw( Message-Id Received ) ; + # + @{ $mysync->{ useheader } } = defined( $mysync->{ useheader } ) ? @{ $mysync->{ 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 ; } -sub cgioutputenvcontext + + +sub tests_cgienvcontext +{ + note( 'Entering tests_cgienvcontext()' ) ; + + is( '', cgienvcontext( ), 'cgienvcontext: no args => empty' ) ; + my $mysync = { } ; + is( '', cgienvcontext( $mysync ), 'cgienvcontext: undef => empty' ) ; + + # environment SERVER_SOFTWARE alone + local $ENV{SERVER_SOFTWARE} = 'Chateau Lami' ; + is( "SERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE=Chateau Lami' ) ; + + # environment REMOTE_HOST and SERVER_SOFTWARE + $mysync = { } ; + local $ENV{REMOTE_HOST} = 'Votre serviteur' ; + is( "REMOTE_HOST is Votre serviteur\nSERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE + REMOTE_HOST' ) ; + + # environment REMOTE_HOST and SERVER_SOFTWARE and --var REMOTE_HOST + $mysync->{ varh }->{REMOTE_HOST} = 'Another Servant' ; + is( "REMOTE_HOST is Another Servant and Votre serviteur\nSERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE + REMOTE_HOST + --var REMOTE_HOST' ) ; + + + # environment SERVER_SOFTWARE --var REMOTE_HOST only + local $ENV{REMOTE_HOST} = undef ; + $mysync = { } ; + $mysync->{ varh }->{REMOTE_HOST} = 'Another Servant' ; + is( "REMOTE_HOST is Another Servant\nSERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE + --var REMOTE_HOST' ) ; + + # environment SERVER_SOFTWARE --var REMOTE_HOST only + local $ENV{REMOTE_HOST} = undef ; + local $ENV{SERVER_SOFTWARE} = undef ; + $mysync = { } ; + $mysync->{ varh }->{REMOTE_HOST} = 'Another Servant' ; + is( "REMOTE_HOST is Another Servant\n", cgienvcontext( $mysync ), 'cgienvcontext: --var REMOTE_HOST' ) ; + + note( 'Leaving tests_cgienvcontext()' ) ; + return ; +} + +sub cgienvcontext { my $mysync = shift @ARG ; - - for my $envvar ( qw( REMOTE_ADDR REMOTE_HOST HTTP_REFERER HTTP_USER_AGENT SERVER_SOFTWARE SERVER_PORT HTTP_COOKIE ) ) { - + + if ( ! defined $mysync ) { return '' ; } + + my $output = '' ; + for my $envvar ( qw( REMOTE_ADDR REMOTE_HOST HTTP_REFERER HTTP_USER_AGENT REQUEST_URI SERVER_SOFTWARE SERVER_NAME SERVER_ADDR SERVER_PORT SERVER_ADMIN HTTP_COOKIE ) ) + { + # $envval comes from the web server via an environment variable + # $varval comes from the command line parameter --val or the cgi parameter val my $envval = $ENV{ $envvar } || q{} ; - if ( $envval ) { output( $mysync, "$envvar is $envval\n" ) } ; + my $varval = $mysync->{ varh }->{ $envvar } ; + + if ( $envval and not $varval ) + { + $output .= "$envvar is $envval\n" ; + } + elsif ( not $envval and $varval ) + { + $output .= "$envvar is $varval\n" ; + } + elsif ( $envval and $varval ) + { + $output .= "$envvar is $varval and $envval\n" ; + } } - return ; + return $output ; } -sub announcelogfile +sub announcelogfile { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( $mysync->{ log } ) { @@ -3912,41 +4604,104 @@ sub announcelogfile else { myprint( "No log file because of option --nolog\n" ) ; - } + } return ; } -sub loglogfile + + + + + +sub tests_loglogfile { - my $mysync = shift ; + note( 'Entering tests_loglogfile()' ) ; + + is( undef, loglogfile( ), 'loglogfile: no args => undef' ) ; + my $mysync = { } ; + is( undef, loglogfile( $mysync ), 'loglogfile: undef => undef' ) ; + $mysync->{ loglogfile } = 1 ; + $mysync->{ log } = 1 ; + is( undef, loglogfile( $mysync ), 'loglogfile: no logfile => undef' ) ; + $mysync->{ logfile } = "logfile.txt" ; + $mysync->{ loglogfilename } = "W/tmp/tests/list_all_logs_auto.txt" ; + like( loglogfile( $mysync ), qr{logfile.txt}xms, 'loglogfile: logfile=logfile.txt => ' ) ; + note( 'Leaving tests_loglogfile()' ) ; + return ; +} + + +sub loglogfile +{ + my $mysync = shift @ARG ; if ( ! $mysync->{ loglogfile } ) { return ; } if ( ! $mysync->{ log } ) { return ; } + if ( ! $mysync->{ logfile } ) { return ; } + + my $loglogfilename = $mysync->{ loglogfilename } || return ; + + my $absolutelogfilepath = absolutelogfilepath( $mysync ) ; + + if ( condition_to_loglogfile( $mysync ) ) + { + myprint( "Writing log file name $absolutelogfilepath to $loglogfilename\n" ) ; + append_to_file( $absolutelogfilepath, $loglogfilename ) ; + } + + return $absolutelogfilepath ; +} + +sub condition_to_loglogfile +{ + my $mysync = shift @ARG ; + + if ( defined $mysync->{ cmdcgi } and scalar( @{ $mysync->{ cmdcgi } } ) ) + { + return 1 ; + } + else + { + return 0 ; + } +} + +sub absolutelogfilepath +{ + my $mysync = shift @ARG ; - 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 ) ) + + my $cwd = getcwd( ) ; + my $absolutelogfilepath = "$cwd/$mysync->{ logfile }" ; + + return $absolutelogfilepath ; +} + + +sub append_to_file +{ + my $string = shift @ARG ; + my $filename = shift @ARG ; + + if ( open( my $fh, '>>', $filename ) ) { - print $fh "$absolutelogfilepath\n" ; + print $fh "$string\n" ; close $fh ; } else { - myprint( "Could not open loglogfile $loglogfilename $!\n" ) ; + myprint( "Could not append $string to file $filename $!\n" ) ; } return ; -} +} - -sub checkselectable +sub checkselectable { - my $mysync = shift ; - - if ( $mysync->{ checkselectable } ) { + my $mysync = shift @ARG ; + + 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 } } ) @@ -3962,7 +4717,7 @@ sub checkselectable } } @{ $mysync->{ h1_folders_wanted } } = @h1_folders_wanted_selectable ; - ( $mysync->{ debug } or $mysync->{ debugfolders } ) + ( $mysync->{ debug } or $mysync->{ debugfolders } ) and myprint( 'Host1: checking folders took ', timenext( $mysync ), " s\n" ) ; } else @@ -3972,14 +4727,14 @@ sub checkselectable return ; } -sub setcheckselectable +sub setcheckselectable { - my $mysync = shift ; - + my $mysync = shift @ARG ; + 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 + # 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 ) @@ -3998,32 +4753,21 @@ sub setcheckselectable sub debugsleep { my $mysync = shift @ARG ; - if ( defined $mysync->{debugsleep} ) { + if ( defined $mysync->{debugsleep} ) + { myprint( "Info: sleeping $mysync->{debugsleep}s\n" ) ; sleep $mysync->{debugsleep} ; } return ; } -sub tests_foldersize -{ - note( 'Entering tests_foldersize()' ) ; - - is( undef, foldersize( ), 'foldersize: no args => undef' ) ; - - - #is_deeply( {}, {}, 'foldersize: a hash is a hash' ) ; - #is_deeply( [], [], 'foldersize: an array is an array' ) ; - note( 'Leaving tests_foldersize()' ) ; - return ; -} # Globals: -# $fetch_hash_set +# # -sub foldersize +sub foldersize { # size of one folder my ( $mysync, $side, $imap, $search_cmd, $abletosearch, $folder ) = @ARG ; @@ -4049,7 +4793,7 @@ sub foldersize } my $hash_ref = { } ; - my @msgs = select_msgs( $imap, undef, $search_cmd, $abletosearch, $folder ) ; + my @msgs = select_msgs( $mysync, $imap, undef, $search_cmd, $abletosearch, $folder ) ; my $nb_msgs = scalar @msgs ; my $biggest_in_folder = 0 ; @{ $hash_ref }{ @msgs } = ( undef ) if @msgs ; @@ -4072,7 +4816,7 @@ sub foldersize } else { - my $fetch_hash_uids = $fetch_hash_set || "1:*" ; + my $fetch_hash_uids = $mysync->{ 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 ) ; @@ -4089,15 +4833,14 @@ sub foldersize } } return( $stot, $nb_msgs, $biggest_in_folder ) ; - -} +} # The old subroutine that performed just one side at a time. # Still here for a while, until confident with sub foldersize_diff_compute() sub foldersizes { - my ( $mysync, $side, $imap, $search_cmd, $abletosearch, @folders ) = @_ ; + my ( $mysync, $side, $imap, $search_cmd, $abletosearch, @folders ) = @ARG ; my $total_size = 0 ; my $total_nb = 0 ; my $biggest_in_all = 0 ; @@ -4143,11 +4886,11 @@ sub foldersizes sub foldersize_diff_present { - my $mysync = shift ; - my $folder1 = shift ; - my $folder2 = shift ; - my $counter_str = shift ; - my $force = shift ; + my $mysync = shift @ARG ; + my $folder1 = shift @ARG ; + my $folder2 = shift @ARG ; + my $counter_str = shift @ARG ; + my $force = shift @ARG ; my $values1_str ; my $values2_str ; @@ -4213,10 +4956,10 @@ sub foldersize_diff_present sub foldersize_diff_compute { - my $mysync = shift ; - my $folder1 = shift ; - my $folder2 = shift ; - my $force = shift ; + my $mysync = shift @ARG ; + my $folder1 = shift @ARG ; + my $folder2 = shift @ARG ; + my $force = shift @ARG ; @@ -4304,8 +5047,8 @@ sub foldersize_diff_compute sub diff { - my $x = shift ; - my $y = shift ; + my $x = shift @ARG ; + my $y = shift @ARG ; $x ||= 0 ; $y ||= 0 ; @@ -4313,15 +5056,40 @@ sub diff return $x - $y ; } +sub tests_add +{ + note( 'Entering tests_add()' ) ; + + is( 0, add( ), 'tests_add: no args => 0' ) ; + is( 0, add( undef ), 'tests_add: undef => 0' ) ; + is( 0, add( 0 ), 'tests_add: 0 => 0' ) ; + is( 0, add( 0, 0 ), 'tests_add: 0 0 => 0' ) ; + is( 0, add( 0, 0, 0 ), 'tests_add: 0 0 0 => 0' ) ; + is( 1, add( 1 ), 'tests_add: 1 => 1' ) ; + is( 2, add( 1, 1 ), 'tests_add: 1 1 => 2' ) ; + is( 3, add( 1, 1, 1 ), 'tests_add: 1 1 1 => 3' ) ; + is( 2, add( 1, undef, 1 ), 'tests_add: 1 undef 1 => 2' ) ; + is( 0, add( -1, 1 ), 'tests_add: -1 1 => 0' ) ; + + is( 2.2, add( 1.1, 1.1 ), 'tests_add: 1.1 1.1 => 2.2' ) ; + + is( 100, add( (1) x 100 ), 'tests_add: 1 1 ... 1 100 times => 100 list' ) ; + my @hundred_ones = (1) x 100 ; + is( 100, add( @hundred_ones ), 'tests_add: 1 1 ... 1 100 times => 100 array' ) ; + + note( 'Leaving tests_add()' ) ; + return ; +} + + sub add { - my $x = shift ; - my $y = shift ; - - $x ||= 0 ; - $y ||= 0 ; - - return $x + $y ; + my $sum = 0 ; + foreach my $number ( @ARG ) + { + $sum += $number || 0 ; + } + return $sum ; } sub tests_checknoabletosearch @@ -4387,8 +5155,8 @@ sub checknoabletosearch sub foldersizes_diff_list { - my $mysync = shift ; - my $force = shift ; + my $mysync = shift @ARG ; + my $force = shift @ARG ; my @folders = @{ $mysync->{h1_folders_wanted} } ; my $nb_folders = scalar @folders ; @@ -4407,7 +5175,7 @@ sub foldersizes_diff_list sub foldersizes_total { - my $mysync = shift ; + my $mysync = shift @ARG ; my @folders_1 = @{ $mysync->{h1_folders_wanted} } ; my @folders_2 = @h2_folders_from_1_wanted ; @@ -4453,18 +5221,18 @@ sub foldersizes_total sub foldersizesatend_old { - my $mysync = shift ; + my $mysync = shift @ARG ; timenext( $mysync ) ; - return if ( $mysync->{imap1}->IsUnconnected( ) ) ; - return if ( $mysync->{imap2}->IsUnconnected( ) ) ; + return if ( $mysync->{ imap1 }->IsUnconnected( ) ) ; + return if ( $mysync->{ imap2 }->IsUnconnected( ) ) ; # Get all folders on host2 again since new were created - @h2_folders_all = sort $mysync->{imap2}->folders(); + @h2_folders_all = sort $mysync->{ imap2 }->folders(); for ( @h2_folders_all ) { $h2_folders_all{ $_ } = 1 ; $mysync->{h2_folders_all_UPPER}{ uc $_ } = 1 ; } ; - ( $h1_nb_msg_end, $h1_bytes_end ) = foldersizes( $mysync, 'Host1', $mysync->{imap1}, $mysync->{ search1 }, $mysync->{abletosearch1}, @{ $mysync->{h1_folders_wanted} } ) ; - ( $h2_nb_msg_end, $h2_bytes_end ) = foldersizes( $mysync, 'Host2', $mysync->{imap2}, $mysync->{ search2 }, $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ; + ( $h1_nb_msg_end, $h1_bytes_end ) = foldersizes( $mysync, 'Host1', $mysync->{ imap1 }, $mysync->{ search1 }, $mysync->{abletosearch1}, @{ $mysync->{h1_folders_wanted} } ) ; + ( $h2_nb_msg_end, $h2_bytes_end ) = foldersizes( $mysync, 'Host2', $mysync->{ imap2 }, $mysync->{ search2 }, $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ; if ( not all_defined( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) ) { my $error = "Failure getting foldersizes, final differences will not be calculated\n" ; errors_incr( $mysync, $error ) ; @@ -4474,12 +5242,12 @@ sub foldersizesatend_old sub foldersizesatend { - my $mysync = shift ; + my $mysync = shift @ARG ; timenext( $mysync ) ; - return if ( $mysync->{imap1}->IsUnconnected( ) ) ; - return if ( $mysync->{imap2}->IsUnconnected( ) ) ; + return if ( $mysync->{ imap1 }->IsUnconnected( ) ) ; + return if ( $mysync->{ imap2 }->IsUnconnected( ) ) ; # Get all folders on host2 again since new were created - @h2_folders_all = sort $mysync->{imap2}->folders(); + @h2_folders_all = sort $mysync->{ imap2 }->folders(); for ( @h2_folders_all ) { $h2_folders_all{ $_ } = 1 ; $mysync->{h2_folders_all_UPPER}{ uc $_ } = 1 ; @@ -4502,11 +5270,11 @@ sub foldersizesatend sub foldersizes_at_the_beggining { - my $mysync = shift ; + my $mysync = shift @ARG ; myprint( << 'END_SIZE' ) ; -Folders sizes before the synchronization. +Folders sizes before the synchronization. It can take some time. Be patient. You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend" but then you will also lose the ETA (Estimation Time of Arrival) given after each message copy. END_SIZE @@ -4547,7 +5315,7 @@ END_SIZE sub foldersizes_at_the_beggining_old { - my $mysync = shift ; + my $mysync = shift @ARG ; myprint( << 'END_SIZE' ) ; @@ -4557,10 +5325,10 @@ but then you will also lose the ETA (Estimation Time of Arrival) given after eac END_SIZE ( $mysync->{ h1_nb_msg_start }, $mysync->{ h1_bytes_start } ) = - foldersizes( $mysync, 'Host1', $mysync->{imap1}, $mysync->{ search1 }, + foldersizes( $mysync, 'Host1', $mysync->{ imap1 }, $mysync->{ search1 }, $mysync->{abletosearch1}, @{ $mysync->{h1_folders_wanted} } ) ; ( $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } ) = - foldersizes( $mysync, 'Host2', $mysync->{imap2}, $mysync->{ search2 }, + foldersizes( $mysync, 'Host2', $mysync->{ imap2 }, $mysync->{ search2 }, $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ; if ( not all_defined( $mysync->{ h1_nb_msg_start }, @@ -4611,7 +5379,7 @@ sub tests_total_bytes_max_reached sub total_bytes_max_reached { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! defined $mysync ) { return ; } @@ -4708,7 +5476,7 @@ sub tests_mock_capability sub sig_install_toggle_sleep { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( 'MSWin32' ne $OSNAME ) { #myprint( "sig_install( $mysync, \&toggle_sleep, 'USR1' )\n" ) ; sig_install( $mysync, 'toggle_sleep', 'USR1' ) ; @@ -4720,7 +5488,7 @@ sub sig_install_toggle_sleep sub mock_capability { - my $myimap = shift ; + my $myimap = shift @ARG ; my @has_capability_value = @ARG ; my ( $has_capability_value ) = @has_capability_value ; @@ -4859,7 +5627,7 @@ sub tests_appendlimit_from_capability sub appendlimit_from_capability { - my $myimap = shift ; + my $myimap = shift @ARG ; if ( ! $myimap ) { myprint( "Warn: no imap with call to appendlimit_from_capability\n" ) ; @@ -5100,6 +5868,8 @@ sub tests_hashsynclocal is( undef, hashsynclocal( $mysync ), 'hashsynclocal: permission denied' ) ; } ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'hashsynclocal: mkpath W/tmp/tests/' ) ; + ok( (-d 'W/tmp/tests/' and chmod( 755, 'W/tmp/tests/' ) ), 'hashsynclocal: chmod 755 W/tmp/tests/' ) ; + $mysync->{ hashfile } = 'W/tmp/tests/imapsync_hash' ; ok( ! -e 'W/tmp/tests/imapsync_hash' || unlink 'W/tmp/tests/imapsync_hash', 'hashsynclocal: unlink W/tmp/tests/imapsync_hash' ) ; @@ -5114,15 +5884,17 @@ sub tests_hashsynclocal sub hashsynclocal { - my $mysync = shift ; - my $hashkey = shift ; # Optional, only there for tests + my $mysync = shift @ARG ; + my $hashkey = shift @ARG ; # Optional, only there for tests my $hashfile = $mysync->{ hashfile } ; $hashfile = createhashfileifneeded( $hashfile, $hashkey ) ; - if ( ! $hashfile ) { + if ( ! $hashfile ) + { return ; } $hashkey = firstline( $hashfile ) ; - if ( ! $hashkey ) { + if ( ! $hashkey ) + { myprint( "No hashkey!\n" ) ; return ; } @@ -5151,7 +5923,7 @@ sub tests_hashsync $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) + # 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 @@ -5164,29 +5936,29 @@ sub tests_hashsync # 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', $eval = eval { hashsync( $mysync, q{} ) } , 'hashsync: password1: Ö with eval' ) ; - $mysync->{ password1 } = 'Ö' ; - is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hashsync( $mysync, q{} ), 'hashsync: password1: Ö without 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{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} ) ; + 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{收} ; + 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' ) ; @@ -5201,8 +5973,8 @@ sub tests_hashsync sub hashsync { - my $mysync = shift ; - my $hashkey = shift ; + my $mysync = shift @ARG ; + my $hashkey = shift @ARG ; my $mystring = join( q{}, $mysync->{ host1 } || q{}, @@ -5229,10 +6001,10 @@ sub tests_hmac_sha1_hex 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( 'Ö' ), '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( '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 @@ -5249,10 +6021,10 @@ sub tests_hmac_sha1_hex # http://unicode.scarfboy.com/?s=U%2B6536 # Good - is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex( '收' ), 'hmac_sha1_hex: 收 => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + 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' ) ; + 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 @@ -5273,10 +6045,10 @@ sub tests_hmac_sha1_hex_robust 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( 'Ö' ), '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( '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 @@ -5293,10 +6065,10 @@ sub tests_hmac_sha1_hex_robust # 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( '收' ), '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' ) ; + 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 @@ -5309,7 +6081,7 @@ sub tests_hmac_sha1_hex_robust sub hmac_sha1_hex_robust { - my $string = shift ; + my $string = shift @ARG ; my $val ; if ( defined( $val = eval{ hmac_sha1_hex( $string, @ARG ) } ) ) { @@ -5337,19 +6109,22 @@ sub tests_createhashfileifneeded sub createhashfileifneeded { - my $hashfile = shift ; - my $hashkey = shift || rand32( ) ; + my $hashfile = shift @ARG ; + my $hashkey = shift || generate_a_random_string( 32 ) ; # no name - if ( ! $hashfile ) { + if ( ! $hashfile ) + { return ; } # already there - if ( -e -r $hashfile ) { + if ( -e -r $hashfile ) + { return $hashfile ; } # not creatable - if ( ! -w dirname( $hashfile ) ) { + if ( ! -w dirname( $hashfile ) ) + { return ; } # creatable @@ -5362,43 +6137,55 @@ sub createhashfileifneeded print $FILE_HANDLE $hashkey ; close $FILE_HANDLE ; # Should be there now - if ( -e -r $hashfile ) { + if ( -e -r $hashfile ) + { return $hashfile ; } # unknown failure return ; } -sub tests_rand32 +sub tests_generate_a_random_string { - note( 'Entering tests_rand32()' ) ; + note( 'Entering tests_generate_a_random_string()' ) ; - my $string = rand32( ) ; - myprint( "$string\n" ) ; - is( 32, length( $string ), 'rand32: 32 characters long' ) ; - is( 32, length( rand32( ) ), 'rand32: 32 characters long, another one' ) ; - - note( 'Leaving tests_rand32()' ) ; - return ; + my $str_a ; + my $str_b ; + ok( $str_a = generate_a_random_string( ), 'tests_generate_a_random_string: give me a random string' ) ; + is( 64, length( $str_a ), 'tests_generate_a_random_string: 64 characters long' ) ; + ok( $str_b = generate_a_random_string( ), 'tests_generate_a_random_string: give another one' ) ; + is( 64, length( $str_b ), 'tests_generate_a_random_string: 64 characters long' ) ; + note( "$str_a $str_b" ) ; + isnt( $str_a, $str_b, 'tests_generate_a_random_string: hope they are different' ) ; + + my $str_c ; + ok( $str_c = generate_a_random_string( 11 ), 'tests_generate_a_random_string: give me a 11 characters random string' ) ; + is( 11, length( $str_c ), 'tests_generate_a_random_string: 11 characters long' ) ; + note( "$str_c" ) ; + note( 'Leaving tests_generate_a_random_string()' ) ; + return ; } -sub rand32 + +sub generate_a_random_string { + my $num = shift || 64 ; my @chars = ( "a".."z" ) ; my $string; - $string .= $chars[rand @chars] for 1..32 ; + $string .= $chars[rand @chars] for 1..$num ; return $string ; } + sub imap_id_stuff { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( not $mysync->{id} ) { return ; } ; - $mysync->{h1_imap_id} = imap_id( $mysync, $mysync->{imap1}, 'Host1' ) ; + $mysync->{h1_imap_id} = imap_id( $mysync, $mysync->{ imap1 }, 'Host1' ) ; #myprint( 'Host1: ' . $mysync->{h1_imap_id} ) ; - $mysync->{h2_imap_id} = imap_id( $mysync, $mysync->{imap2}, 'Host2' ) ; + $mysync->{h2_imap_id} = imap_id( $mysync, $mysync->{ imap2 }, 'Host2' ) ; #myprint( 'Host2: ' . $mysync->{h2_imap_id} ) ; return ; @@ -5406,7 +6193,7 @@ sub imap_id_stuff sub imap_id { - my ( $mysync, $imap, $Side ) = @_ ; + my ( $mysync, $imap, $Side ) = @ARG ; if ( not $mysync->{id} ) { return q{} ; } ; @@ -5418,13 +6205,13 @@ sub imap_id myprint( "$Side: No ID capability\n" ) ; }else{ my $id_inp = imapsync_id( $mysync, { side => lc $Side } ) ; - myprint( "\n$Side: found ID capability. Sending/receiving ID, presented in raw IMAP for now.\n" + myprint( "$Side: found ID capability. Sending/receiving ID, presented in raw IMAP for now.\n" . "In order to avoid sending/receiving ID, use option --noid\n" ) ; my $debug_before = $imap->Debug( ) ; $imap->Debug( 1 ) ; my $id_out = $imap->tag_and_run( 'ID ' . $id_inp ) ; #my $id_out = $imap->tag_and_run( 'ID NIL' ) ; - myprint( "\n" ) ; + #myprint( "\n" ) ; $imap->Debug( $debug_before ) ; #$imap_id_response = Data::Dumper->Dump( [ $id_out ], [ 'IMAP_ID' ] ) ; } @@ -5433,8 +6220,8 @@ sub imap_id sub imapsync_id { - my $mysync = shift ; - my $overhashref = shift ; + my $mysync = shift @ARG ; + my $overhashref = shift @ARG ; # See http://tools.ietf.org/html/rfc2971.html my $imapsync_id = { } ; @@ -5446,7 +6233,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: 2022/01/12 21:28:37 $ } ), + date => date_from_rcs( q{$Date: 2025/09/23 16:55:17 $ } ), } ; my $imapsync_id_github = { @@ -5455,7 +6242,7 @@ sub imapsync_id os => $OSNAME, vendor => 'github', 'support-url' => 'https://github.com/imapsync/imapsync', - date => date_from_rcs( q{$Date: 2022/01/12 21:28:37 $ } ), + date => date_from_rcs( q{$Date: 2025/09/23 16:55:17 $ } ), } ; $imapsync_id = $imapsync_id_lamiral ; @@ -5489,7 +6276,7 @@ sub tests_imapsync_id sub format_for_imap_arg { - my $ref = shift ; + my $ref = shift @ARG ; my $string = q{} ; my %terms = %{ $ref } ; @@ -5521,9 +6308,9 @@ sub tests_format_for_imap_arg return ; } -sub quota +sub quota { - my ( $mysync, $imap, $side ) = @_ ; + my ( $mysync, $imap, $side ) = @ARG ; my %side = ( h1 => 'Host1', @@ -5574,19 +6361,25 @@ sub tests_quota_extract_storage_limit_in_bytes '* QUOTA "Messages quota" (MESSAGE 2 100000)', '5 OK Getquotaroot completed.' ] ; - ok( $NUMBER_104_857_600 * $KIBI == quota_extract_storage_limit_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_limit_in_bytes ') ; - + is( $NUMBER_104_857_600 * $KIBI, quota_extract_storage_limit_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_limit_in_bytes (STORAGE 1 104857600) => 104857600 * 1024') ; + $imap_output = [ + '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"', + 'QUOTA "user-defined quota (konsoleH)" (STORAGE 988 48829 MESSAGE 20 20)', + '5 OK Getquotaroot completed.' + ] ; + is( 48829 * 1024, quota_extract_storage_limit_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_limit_in_bytes (STORAGE 988 48829 MESSAGE 20 20) => 48829 * 1024') ; + note( 'Leaving tests_quota_extract_storage_limit_in_bytes()' ) ; return ; } sub quota_extract_storage_limit_in_bytes { - my $mysync = shift ; - my $imap_output = shift ; + my $mysync = shift @ARG ; + my $imap_output = shift @ARG ; my $limit_kb ; - $limit_kb = ( map { /.*\(\s*STORAGE\s+\d+\s+(\d+)\s*\)/x ? $1 : () } @{ $imap_output } )[0] ; + $limit_kb = ( map { /STORAGE\s+\d+\s+(\d+)/x ? $1 : () } @{ $imap_output } )[0] ; $limit_kb ||= 0 ; $mysync->{ debug } and myprint( "storage_limit_kb = $limit_kb\n" ) ; return( $KIBI * $limit_kb ) ; @@ -5604,19 +6397,27 @@ sub tests_quota_extract_storage_current_in_bytes '* QUOTA "Messages quota" (MESSAGE 2 100000)', '5 OK Getquotaroot completed.' ] ; - ok( 1*$KIBI == quota_extract_storage_current_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_current_in_bytes: 1 => 1024 ') ; + is( 1*$KIBI, quota_extract_storage_current_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_current_in_bytes: 1 => 1024 ') ; - note( 'Leaving tests_quota_extract_storage_current_in_bytes()' ) ; + $imap_output = [ + '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"', + 'QUOTA "user-defined quota (konsoleH)" (STORAGE 988 48829 MESSAGE 20 20)', + '5 OK Getquotaroot completed.' + ] ; + is( 988 * 1024, quota_extract_storage_current_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_current_in_bytes (STORAGE 988 48829 MESSAGE 20 20) => 988 * 1024') ; + + + note( 'Leaving tests_quota_extract_storage_current_in_bytes()' ) ; return ; } sub quota_extract_storage_current_in_bytes { - my $mysync = shift ; - my $imap_output = shift ; + my $mysync = shift @ARG ; + my $imap_output = shift @ARG ; my $current_kb ; - $current_kb = ( map { /.*\(\s*STORAGE\s+(\d+)\s+\d+\s*\)/x ? $1 : () } @{ $imap_output } )[0] ; + $current_kb = ( map { /STORAGE\s+(\d+)\s+\d+/x ? $1 : () } @{ $imap_output } )[0] ; $current_kb ||= 0 ; $mysync->{ debug } and myprint( "storage_current_kb = $current_kb\n" ) ; return( $KIBI * $current_kb ) ; @@ -5624,9 +6425,20 @@ sub quota_extract_storage_current_in_bytes } + +sub make_f1f2_array_to_a_hash +{ + my $mysync = shift @ARG ; + %{ $mysync->{ f1f2h } } = split_around_equal( @{ $mysync->{ f1f2 } } ) ; + + return ; +} + + + sub automap { - my ( $mysync ) = @_ ; + my ( $mysync ) = @ARG ; if ( $mysync->{automap} ) { myprint( "Turned on automapping folders ( use --noautomap to turn off automapping )\n" ) ; @@ -5635,8 +6447,8 @@ sub automap return ; } - $mysync->{h1_special} = special_from_folders_hash( $mysync, $mysync->{imap1}, 'Host1' ) ; - $mysync->{h2_special} = special_from_folders_hash( $mysync, $mysync->{imap2}, 'Host2' ) ; + $mysync->{h1_special} = special_from_folders_hash( $mysync, $mysync->{ imap1 }, 'Host1' ) ; + $mysync->{h2_special} = special_from_folders_hash( $mysync, $mysync->{ imap2 }, 'Host2' ) ; build_possible_special( $mysync ) ; build_guess_special( $mysync ) ; @@ -5650,7 +6462,7 @@ sub automap sub build_guess_special { - my ( $mysync ) = shift ; + my ( $mysync ) = shift @ARG ; foreach my $h1_fold ( sort keys %{ $mysync->{h1_folders_all} } ) { my $special = guess_special( $h1_fold, $mysync->{possible_special}, $mysync->{h1_prefix} ) ; @@ -5681,7 +6493,7 @@ sub build_guess_special sub guess_special { - my( $folder, $possible_special_ref, $prefix ) = @_ ; + my( $folder, $possible_special_ref, $prefix ) = @ARG ; my $folder_no_prefix = $folder ; $folder_no_prefix =~ s/\Q${prefix}\E//xms ; @@ -5710,7 +6522,7 @@ sub tests_guess_special sub build_automap { - my $mysync = shift ; + my $mysync = shift @ARG ; $mysync->{ debug } and myprint( "Entering build_automap\n" ) ; foreach my $h1_fold ( @{ $mysync->{h1_folders_wanted} } ) { my $h2_fold ; @@ -5762,27 +6574,28 @@ sub build_automap # because it works well without sub build_possible_special { - my $mysync = shift ; + my $mysync = shift @ARG ; my $possible_special = { } ; # All|Archive|Drafts|Flagged|Junk|Sent|Trash $possible_special->{'\All'} = [ 'All', 'All Messages', '&BBIEQQQ1-' ] ; $possible_special->{'\Archive'} = [ 'Archive', 'Archives', '&BBAEQARFBDgEMg-' ] ; - $possible_special->{'\Drafts'} = [ 'Drafts', 'DRAFTS', '&BCcENQRABD0EPgQyBDgEOgQ4-', 'Szkice', 'Wersje robocze' ] ; + $possible_special->{'\Drafts'} = [ 'Drafts', 'DRAFTS', '&BCcENQRABD0EPgQyBDgEOgQ4-', 'Szkice', 'Wersje robocze', 'Entw&APw-rfe' ] ; $possible_special->{'\Flagged'} = [ 'Flagged', 'Starred', '&BB8EPgQ8BDUERwQ1BD0EPQRLBDU-' ] ; $possible_special->{'\Junk'} = [ 'Junk', 'junk', 'Spam', 'SPAM', '&BCEEPwQwBDw-', 'Potwierdzony spam', 'Wiadomo&AVs-ci-&AVs-mieci', 'Junk E-Mail', 'Junk Email'] ; $possible_special->{'\Sent'} = [ 'Sent', 'Sent Messages', 'Sent Items', - 'Gesendete Elemente', 'Gesendete Objekte', + 'Gesendete Elemente', 'Gesendete Objekte', 'Gesendet', '&AMk-l&AOk-ments envoy&AOk-s', 'E&AwE-le&AwE-ments envoye&AwE-s', 'Envoy&AOk-', 'Objets envoy&AOk-s', - 'Elementos enviados', + 'Elementos enviados', 'Posta inviata', '&kAFP4W4IMH8wojCkMMYw4A-', '&BB4EQgQ,BEAEMAQyBDsENQQ9BD0ESwQ1-', 'Elementy wys&AUI-ane'] ; $possible_special->{'\Trash'} = [ 'Trash', 'TRASH', '&BCMENAQwBDsENQQ9BD0ESwQ1-', '&BBoEPgRABDcEOAQ9BDA-', 'Kosz', + 'Papierkorb', 'Deleted Items', 'Deleted Messages' ] ; @@ -5819,7 +6632,7 @@ sub tests_special_from_folders_hash sub special_from_folders_hash { - my ( $mysync, $imap, $side ) = @_ ; + my ( $mysync, $imap, $side ) = @ARG ; my %special = ( ) ; if ( ! defined $imap ) { return ; } @@ -5892,18 +6705,18 @@ sub tests_comment_of_error_type note( 'Entering tests_comment_of_error_type()' ) ; is( undef, comment_of_error_type( ), 'comment_of_error_type: no args => undef' ) ; - + my $mysync = { } ; is( undef, comment_of_error_type( $mysync ), 'comment_of_error_type: undef => undef' ) ; - + is( "", comment_of_error_type( $mysync, '' ), 'comment_of_error_type: "" => ""' ) ; is( "", comment_of_error_type( $mysync, 'blabla' ), 'comment_of_error_type: blabla => ""' ) ; - + is( "", comment_of_error_type( $mysync, 'ERR_UNCLASSIFIED' ), 'comment_of_error_type: ERR_UNCLASSIFIED => ""' ) ; - + like( comment_of_error_type( $mysync, 'ERR_OVERQUOTA' ), qr{100% full}, 'comment_of_error_type: ERR_OVERQUOTA => matches 100% full' ) ; - + note( 'Leaving tests_comment_of_error_type()' ) ; return ; @@ -5913,12 +6726,12 @@ sub comment_of_error_type { my $mysync = shift @ARG ; my $error_type = shift @ARG ; - + if ( ! defined $mysync ) { return ; } if ( ! defined $error_type ) { return ; } - + my $comment ; - + if ( exists( $COMMENT_OF_ERR_TYPE{ $error_type } ) ) { $comment = $COMMENT_OF_ERR_TYPE{ $error_type }->( $mysync ) ; @@ -5992,13 +6805,18 @@ sub tests_error_type 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' ) ; - - + + is( 'ERR_FLAGS', error_type( 'Host2: flags msg INBOX/957910 could not add flags [PasGlop \PasGlopRe]: 33 NO Error in IMAP command received by server.' ), 'error_type: could not add flags => ERR_FLAGS' ) ; - + + is( 'ERR_SEARCH', + error_type( 'BAD Error in IMAP command UID SEARCH: Unknown argument KAKA' ), + 'error_type: SEARCH: Unknown argument => ERR_SEARCH' + ) ; + note( 'Leaving tests_error_type()' ) ; return ; @@ -6010,8 +6828,8 @@ sub tests_error_type # with just a hash of error regexes as keys and types as values. sub error_type -{ - my $error = shift ; +{ + my $error = shift @ARG ; if ( ! defined $error ) { return 'ERR_NOTHING_REPORTED' ; } if ( ! $error ) { return 'ERR_NOTHING_REPORTED' ; } @@ -6054,6 +6872,9 @@ sub error_type # could not add flags if ( $error =~ m{could not add flags} ) { return 'ERR_FLAGS' ; } ; + # could not search + if ( $error =~ m{BAD .* SEARCH: Unknown argument} ) { return 'ERR_SEARCH' ; } ; + # Could not create folder .*Invalid mailbox name if ( $error =~ m{Could not create folder} ) { return 'ERR_CREATE' ; } ; @@ -6071,10 +6892,12 @@ sub error_type 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 { @@ -6139,7 +6962,7 @@ sub tests_most_common_error sub most_common_error { - my $errors_counted_ref = shift ; + my $errors_counted_ref = shift @ARG ; if ( ! defined $errors_counted_ref ) { return 'ERR_NOTHING_REPORTED' ; } @@ -6237,25 +7060,25 @@ sub errorsdump sub errors_listing { - my $mysync = shift ; + my $mysync = shift @ARG ; $mysync->{ most_common_error } = errorsanalyse( errors_log( $mysync ) ) ; my $errors_listing = '' ; - + if ( $mysync->{ errorsdump } ) { $errors_listing = join( '', - "++++ Listing $mysync->{nb_errors} errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n", + "++++ Listing $mysync->{ nb_errors } errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n", errorsdump( errors_log( $mysync ) ), ) ; } - + $errors_listing .= join( '', "The most frequent error is $mysync->{ most_common_error }. ", comment_of_error_type( $mysync, $mysync->{ most_common_error } ), "\n", ) ; - + return $errors_listing ; } @@ -6270,21 +7093,16 @@ sub errors_incr myprint( @error ) ; } + # Why is it here? Looks like a safety "in case" $mysync->{ errorsmax } ||= $ERRORS_MAX ; - - + if ( $mysync->{ nb_errors } >= $mysync->{ errorsmax } ) { myprint( errorsmax_msg( $mysync ) ) ; - myprint( errors_listing( $mysync ) ) ; - - if ( $mysync->{ errorsdump } ) - { - # again since errorsdump( ) can be very verbose and masquerade previous warning - myprint( errorsmax_msg( $mysync ) ) ; - } - my $exit_value = exit_value( $mysync, $mysync->{ most_common_error } ) ; - exit_clean( $mysync, $exit_value ) ; + do_and_print_stats( $mysync ) ; + # again since do_and_print_stats() is verbose + myprint( errorsmax_msg( $mysync ) ) ; + exit_most_errors( $mysync ) ; } return ; } @@ -6307,7 +7125,7 @@ sub tests_live_result { note( 'Entering tests_live_result()' ) ; - my $nb_errors = shift ; + my $nb_errors = shift @ARG ; if ( $nb_errors ) { myprint( "Live tests failed with $nb_errors errors\n" ) ; } else { @@ -6320,21 +7138,21 @@ sub tests_live_result sub size_filtered_flag { - my $mysync = shift ; - my $h1_size = shift ; + my $mysync = shift @ARG ; + my $h1_size = shift @ARG ; if ( defined $mysync->{ maxsize } and $h1_size >= $mysync->{ maxsize } ) { return( 1 ) ; } - if ( defined $minsize and $h1_size <= $minsize ) { + if ( defined $mysync->{ minsize } and $h1_size <= $mysync->{ minsize } ) { return( 1 ) ; } return( 0 ) ; } -sub sync_flags_fir +sub sync_flags_fir { - my ( $mysync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ; + my ( $mysync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $h1_fir_ref, $h2_fir_ref ) = @ARG ; if ( not defined $h1_msg ) { return } ; if ( not defined $h2_msg ) { return } ; @@ -6346,44 +7164,42 @@ sub sync_flags_fir my $h1_flags = $h1_fir_ref->{ $h1_msg }->{ 'FLAGS' } || q{} ; my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ 'FLAGS' } || q{} ; - sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ; + sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags ) ; return ; -} +} -sub sync_flags_after_copy +sub syncflagsaftercopy { # Activated with option --syncflagsaftercopy - my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $permanentflags2 ) = @_ ; + my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg ) = @ARG ; - if ( my @h2_flags = $mysync->{imap2}->flags( $h2_msg ) ) { + if ( my @h2_flags = $mysync->{ imap2 }->flags( $h2_msg ) ) + { my $h2_flags = "@h2_flags" ; - ( $mysync->{ debug } or $debugflags ) and myprint( "Host2: msg $h2_fold/$h2_msg flags before sync flags after copy ( $h2_flags )\n" ) ; - sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ; - }else{ - myprint( "Host2: msg $h2_fold/$h2_msg could not get its flags for sync flags after copy\n" ) ; + ( $mysync->{ debug } or $mysync->{ debugflags } ) and myprint( "Host2: msg $h2_fold/$h2_msg flags before sync flags after copy ( $h2_flags )\n" ) ; + sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags ) ; + } + else + { + myprint( "Host2: msg $h2_fold/$h2_msg : could not get its flags to sync them after the copy\n" ) ; } return ; } -# Globals -# $debug -# $debugflags -# $permanentflags2 - -sub sync_flags +sub sync_flags { - my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) = @_ ; + my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags ) = @ARG ; - ( $mysync->{ debug } or $debugflags ) and + ( $mysync->{ debug } or $mysync->{ 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( $mysync, $h1_flags, $permanentflags2 ) ; + $h1_flags = flags_for_host2( $mysync, $h1_flags, $mysync->{ permanentflags2 } ) ; $h2_flags = flagscase( $h2_flags ) ; - ( $mysync->{ debug } or $debugflags ) and + ( $mysync->{ debug } or $mysync->{ debugflags } ) and myprint( "Host1: flags filt msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ; @@ -6392,7 +7208,7 @@ sub sync_flags my @h2_flags = sort split(q{ }, $h2_flags ); my $diff = compare_lists( \@h1_flags, \@h2_flags ); - $diff and ( $mysync->{ debug } or $debugflags ) + $diff and ( $mysync->{ debug } or $mysync->{ debugflags } ) and myprint( "Host2: flags msg $h2_fold/$h2_msg replacing h2 flags( $h2_flags ) with h1 flags( $h1_flags )\n" ) ; # This sets flags exactly. So flags can be removed with this. @@ -6400,20 +7216,20 @@ sub sync_flags # to be removed on host2. Just add flags is not what # we need most of the time, so no + like in "+FLAGS.SILENT". - if ( not $mysync->{dry} and $diff and not $mysync->{imap2}->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) { + if ( not $mysync->{ dry } and $diff and not $mysync->{ imap2 }->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) { my $error_msg = join q{}, "Host2: flags msg $h2_fold/$h2_msg could not add flags [@h1_flags]: ", - $mysync->{imap2}->LastError || q{}, "\n" ; + $mysync->{ imap2 }->LastError || q{}, "\n" ; errors_incr( $mysync, $error_msg ) ; } return ; -} +} sub _filter { - my $mysync = shift ; + my $mysync = shift @ARG ; my $str = shift or return q{} ; my $sz = $SIZE_MAX_STR ; my $len = length $str ; @@ -6428,11 +7244,11 @@ sub _filter -sub lost_connection +sub lost_connection { - my( $mysync, $imap, $error_message ) = @_; + my( $mysync, $imap, $error_message ) = @ARG; if ( $imap->IsUnconnected( ) ) { - $mysync->{nb_errors}++ ; + $mysync->{ nb_errors }++ ; my $lcomm = $imap->LastIMAPCommand || q{} ; my $einfo = imap_last_error( $imap ) ; @@ -6447,11 +7263,11 @@ sub lost_connection else{ return( 0 ) ; } -} +} sub imap_last_error { - my $imap = shift ; + my $imap = shift @ARG ; my $einfo = $imap->LastError || @{$imap->History}[$LAST] || q{} ; chomp( $einfo ) ; return( $einfo ) ; @@ -6491,7 +7307,7 @@ sub tests_max sub max { - my @list = @_ ; + my @list = @ARG ; return( undef ) if ( 0 == scalar @list ) ; my( @numbers, @notnumbers ) ; @@ -6550,7 +7366,7 @@ sub tests_is_number sub is_number { - my $item = shift ; + my $item = shift @ARG ; if ( ! defined $item ) { return ; } @@ -6593,7 +7409,7 @@ sub tests_min sub min { - my @list = @_ ; + my @list = @ARG ; return( undef ) if ( 0 == scalar @list ) ; my( @numbers, @notnumbers ) ; @@ -6620,7 +7436,7 @@ sub min sub check_lib_version { - my $mysync = shift ; + my $mysync = shift @ARG ; $mysync->{ debug } and myprint( "IMAPClient $Mail::IMAPClient::VERSION\n" ) ; if ( '2.2.9' eq $Mail::IMAPClient::VERSION ) { myprint( "imapsync no longer supports Mail::IMAPClient 2.2.9, upgrade it\n" ) ; @@ -6636,7 +7452,7 @@ sub check_lib_version sub module_version_str { - my( $module_name, $module_version ) = @_ ; + my( $module_name, $module_version ) = @ARG ; my $str = mysprintf( "%-20s %s\n", $module_name, $module_version ) ; return( $str ) ; } @@ -6651,10 +7467,10 @@ sub modulesversion 'CGI' => sub { $CGI::VERSION }, 'Compress::Zlib' => sub { $Compress::Zlib::VERSION }, 'Crypt::OpenSSL::RSA' => sub { $Crypt::OpenSSL::RSA::VERSION }, - 'Data::Uniqid' => sub { $Data::Uniqid::VERSION }, 'Digest::HMAC_MD5' => sub { $Digest::HMAC_MD5::VERSION }, 'Digest::HMAC_SHA1' => sub { $Digest::HMAC_SHA1::VERSION }, - 'Digest::MD5' => sub { $Digest::MD5::VERSION }, + 'Digest::MD5' => sub { $Digest::MD5::VERSION }, + 'Digest::SHA' => sub { $Digest::SHA::VERSION }, 'Encode' => sub { $Encode::VERSION }, 'Encode::IMAPUTF7' => sub { $Encode::IMAPUTF7::VERSION }, 'File::Copy::Recursive' => sub { $File::Copy::Recursive::VERSION }, @@ -6678,7 +7494,6 @@ sub modulesversion 'Test::MockObject' => sub { $Test::MockObject::VERSION }, 'Time::HiRes' => sub { $Time::HiRes::VERSION }, 'Unicode::String' => sub { $Unicode::String::VERSION }, - 'URI::Escape' => sub { $URI::Escape::VERSION }, #'Lalala' => sub { $Lalala::VERSION }, ) ; @@ -6790,7 +7605,7 @@ sub get_stdin_masked sub ask_for_password_new { - my $prompt = shift ; + my $prompt = shift @ARG ; my $password = get_stdin_masked( $prompt ) ; return $password ; } @@ -6799,7 +7614,7 @@ sub ask_for_password_new sub ask_for_password { - my $prompt = shift ; + my $prompt = shift @ARG ; myprint( $prompt ) ; Term::ReadKey::ReadMode( 2 ) ; ## no critic (InputOutput::ProhibitExplicitStdin) @@ -6812,16 +7627,20 @@ sub ask_for_password # Have to refactor get_password1() get_password2() # to have only get_password() and two calls -sub get_password1 +sub get_password1 { - my $mysync = shift ; + my $mysync = shift @ARG ; - $mysync->{ password1 } + ! $mysync->{ host1 } + || ! $mysync->{ user1 } + || $mysync->{ password1 } || $mysync->{ passfile1 } || 'PREAUTH' eq $mysync->{ acc1 }->{ authmech } || 'EXTERNAL' eq $mysync->{ acc1 }->{ authmech } - || $ENV{IMAPSYNC_PASSWORD1} + || $mysync->{ acc1 }->{ oauthaccesstoken } + || $mysync->{ acc1 }->{ oauthdirect } + || $ENV{ IMAPSYNC_PASSWORD1 } || do { myprint( << 'FIN_PASSFILE' ) ; @@ -6834,36 +7653,43 @@ FIN_PASSFILE 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 ) ; + $mysync->{ password1 } = ask_for_password( $prompt ) ; } ; - if ( defined $mysync->{ passfile1 } ) { - if ( ! -e -r $mysync->{ passfile1 } ) { + if ( defined $mysync->{ passfile1 } ) + { + if ( ! -e -r $mysync->{ passfile1 } ) + { myprint( "Failure: file from parameter --passfile1 $mysync->{ passfile1 } does not exist or is not readable\n" ) ; - $mysync->{nb_errors}++ ; + $mysync->{ nb_errors }++ ; exit_clean( $mysync, $EX_NOINPUT ) ; } # passfile1 readable - $mysync->{password1} = firstline ( $mysync->{ passfile1 } ) ; + $mysync->{ password1 } = firstline ( $mysync->{ passfile1 } ) ; return ; } - if ( $ENV{IMAPSYNC_PASSWORD1} ) { - $mysync->{password1} = $ENV{IMAPSYNC_PASSWORD1} ; + if ( $ENV{ IMAPSYNC_PASSWORD1 } ) + { + $mysync->{ password1 } = $ENV{ IMAPSYNC_PASSWORD1 } ; return ; } return ; -} +} -sub get_password2 +sub get_password2 { - my $mysync = shift ; + my $mysync = shift @ARG ; - $mysync->{password2} + ! $mysync->{ host2 } + || ! $mysync->{ user2 } + || $mysync->{ password2 } || $mysync->{ passfile2 } || 'PREAUTH' eq $mysync->{ acc2 }->{ authmech } || 'EXTERNAL' eq $mysync->{ acc2 }->{ authmech } - || $ENV{IMAPSYNC_PASSWORD2} + || $mysync->{ acc2 }->{ oauthaccesstoken } + || $mysync->{ acc2 }->{ oauthdirect } + || $ENV{ IMAPSYNC_PASSWORD2 } || do { myprint( << 'FIN_PASSFILE' ) ; @@ -6876,26 +7702,29 @@ FIN_PASSFILE 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 ) ; + $mysync->{ password2 } = ask_for_password( $prompt ) ; } ; - if ( defined $mysync->{ passfile2 } ) { - if ( ! -e -r $mysync->{ passfile2 } ) { + if ( defined $mysync->{ passfile2 } ) + { + if ( ! -e -r $mysync->{ passfile2 } ) + { myprint( "Failure: file from parameter --passfile2 $mysync->{ passfile2 } does not exist or is not readable\n" ) ; - $mysync->{nb_errors}++ ; + $mysync->{ nb_errors }++ ; exit_clean( $mysync, $EX_NOINPUT ) ; } # passfile2 readable - $mysync->{password2} = firstline ( $mysync->{ passfile2 } ) ; + $mysync->{ password2 } = firstline ( $mysync->{ passfile2 } ) ; return ; } - if ( $ENV{IMAPSYNC_PASSWORD2} ) { - $mysync->{password2} = $ENV{IMAPSYNC_PASSWORD2} ; + if ( $ENV{ IMAPSYNC_PASSWORD2 } ) + { + $mysync->{ password2 } = $ENV{ IMAPSYNC_PASSWORD2 } ; return ; } return ; -} +} @@ -6903,38 +7732,64 @@ FIN_PASSFILE sub remove_tmp_files { my $mysync = shift or return ; - $mysync->{pidfile} 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} ; - } + remove_pidfile( $mysync ) ; + remove_abortfile( $mysync ) ; + return ; } -sub cleanup_before_exit + +sub remove_pidfile { - my $mysync = shift ; + my $mysync = shift or return ; + + $mysync->{ pidfile } or return ; + if ( -e $mysync->{ pidfile } ) + { + myprint( "Removing pidfile $mysync->{ pidfile }\n" ) ; + unlink $mysync->{ pidfile } ; + } + + return ; +} + +sub remove_abortfile +{ + my $mysync = shift or return ; + + $mysync->{ abortfile } or return ; + + if ( -e $mysync->{ abortfile } ) + { + myprint( "Removing pidfile $mysync->{ abortfile }\n" ) ; + unlink $mysync->{ abortfile } ; + } + return ; +} + + +sub cleanup_before_exit +{ + my $mysync = shift @ARG ; + remove_tmp_files( $mysync ) ; - - if ( $mysync->{imap1} and $mysync->{imap1}->IsConnected() ) + + if ( $mysync->{ imap1 } and $mysync->{ imap1 }->IsConnected() ) { myprint( "Disconnecting from host1 $mysync->{ host1 } user1 $mysync->{ user1 }\n" ) ; - $mysync->{imap1}->logout( ) ; + $mysync->{ imap1 }->logout( ) ; } - - if ( $mysync->{imap2} and $mysync->{imap2}->IsConnected() ) + + if ( $mysync->{ imap2 } and $mysync->{ imap2 }->IsConnected() ) { myprint( "Disconnecting from host2 $mysync->{ host2 } user2 $mysync->{ user2 }\n" ) ; - $mysync->{imap2}->logout( ) ; + $mysync->{ imap2 }->logout( ) ; } - - if ( $mysync->{log} ) { + + if ( $mysync->{ log } ) { myprint( "Log file is $mysync->{logfile} ( to change it, use --logfile filepath ; or use --nolog to turn off logging )\n" ) ; } else @@ -6942,13 +7797,13 @@ sub cleanup_before_exit myprint( "No log file because of option --nolog\n" ) ; } - if ( $mysync->{log} and $mysync->{logfile_handle} ) { + if ( $mysync->{ log } ) { #print( "Closing $mysync->{ logfile }\n" ) ; - teefinish( $mysync ) ; + teefinish( $mysync->{ tee } ) ; } - + $IO::Socket::SSL::DEBUG = 1 ; return ; -} +} sub tests_exit_value @@ -6956,17 +7811,18 @@ sub tests_exit_value note( 'Entering tests_exit_value()' ) ; is( $EXIT_CATCH_ALL, exit_value( ), 'exit_value: no args => EXIT_CATCH_ALL' ) ; - + my $mysync = { } ; is( $EXIT_CATCH_ALL, exit_value( $mysync ), 'exit_value: undef => EXIT_CATCH_ALL' ) ; - + is( $EXIT_CATCH_ALL, exit_value( $mysync, 'Blabla_unknown' ), 'exit_value: Blabla => EXIT_CATCH_ALL' ) ; is( $EXIT_CATCH_ALL, exit_value( $mysync, '' ), 'exit_value: empty => EXIT_CATCH_ALL' ) ; - - + is( $EXIT_CATCH_ALL, exit_value( $mysync, '' ), 'exit_value: undef => EXIT_CATCH_ALL' ) ; + + is( $EXIT_OVERQUOTA, exit_value( $mysync, 'ERR_OVERQUOTA' ), 'exit_value: ERR_OVERQUOTA => EXIT_OVERQUOTA' ) ; is( $EXIT_TRANSFER_EXCEEDED, exit_value( $mysync, 'ERR_TRANSFER_EXCEEDED' ), 'exit_value: ERR_TRANSFER_EXCEEDED => EXIT_TRANSFER_EXCEEDED' ) ; - + note( 'Leaving tests_exit_value()' ) ; return ; } @@ -6975,10 +7831,12 @@ sub exit_value { my $mysync = shift @ARG ; my $most_common_error = shift @ARG ; - + + if ( ! defined $mysync ) { return $EXIT_CATCH_ALL ; } if ( ! defined $most_common_error ) { return $EXIT_CATCH_ALL ; } + if ( ! $most_common_error ) { return $EXIT_CATCH_ALL ; } my $exit_value = $EXIT_VALUE_OF_ERR_TYPE{ $most_common_error } || $EXIT_CATCH_ALL ; - + return $exit_value ; } @@ -6988,13 +7846,20 @@ sub exit_most_errors { my $mysync = shift @ARG ; - myprint( errors_listing( $mysync ) ) ; - my $exit_value = exit_value( $mysync, $mysync->{ most_common_error } ) ; - exit_clean( $mysync, $exit_value ) ; + if ( $mysync->{ nb_errors } ) + { + myprint( errors_listing( $mysync ) ) ; + my $exit_value = exit_value( $mysync, $mysync->{ most_common_error } ) ; + exit_clean( $mysync, $exit_value ) ; + } + else + { + exit_clean( $mysync, $EX_OK ) ; + } return ; } -sub exit_clean +sub exit_clean { my $mysync = shift @ARG ; my $status = shift @ARG ; @@ -7006,26 +7871,27 @@ sub exit_clean 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 ; + #sleep( 3 ) ; + exit( $status ) ; } -sub missing_option +sub missing_option { - my $mysync = shift ; - my $option = shift ; - $mysync->{nb_errors}++ ; + my $mysync = shift @ARG ; + my $option = shift @ARG ; + $mysync->{ nb_errors }++ ; exit_clean( $mysync, $EX_USAGE, "$option option is mandatory, for help run $PROGRAM_NAME --help\n" ) ; return ; -} +} sub catch_ignore { - my $mysync = shift ; - my $signame = shift ; + my $mysync = shift @ARG ; + my $signame = shift @ARG ; my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ; - myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), + myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ), "). Received $sigcounter $signame signals so far. Thanks!\n" ) ; do_and_print_stats( $mysync ) ; return ; @@ -7033,17 +7899,17 @@ sub catch_ignore -sub catch_exit +sub catch_exit { - my $mysync = shift ; + my $mysync = shift @ARG ; my $signame = shift || q{} ; if ( $signame ) { - myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), + myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ), "). Asked to terminate\n" ) ; - if ( $mysync->{can_do_stats} ) { + 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" ) ; + mygetppid( ), "). 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" @@ -7060,34 +7926,34 @@ sub catch_exit #kill( 'TERM', $PROCESS_ID ) ; #sleep 1 ; #while ( 1 ) { } ; - $mysync->{nb_errors}++ ; + $mysync->{ nb_errors }++ ; exit_clean( $mysync, $EXIT_BY_SIGNAL, "Still there after killing myself with signal $signame...\n" ) ; } else { - $mysync->{nb_errors}++ ; + $mysync->{ nb_errors }++ ; exit_clean( $mysync, $EXIT_BY_SIGNAL, "Exiting in catch_exit with no signal...\n" ) ; } return ; -} +} sub catch_print { - my $mysync = shift ; - my $signame = shift ; + my $mysync = shift @ARG ; + my $signame = shift @ARG ; my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ; - myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), + myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ), "). Received $sigcounter $signame signals so far. Thanks!\n" ) ; return ; } sub here_twice { - my $mysync = shift ; + my $mysync = shift @ARG ; my $now = time ; my $previous = $mysync->{lastcatch} || 0 ; $mysync->{lastcatch} = $now ; @@ -7100,55 +7966,58 @@ sub here_twice } -sub catch_reconnect +sub catch_reconnect { - my $mysync = shift ; - my $signame = shift ; - if ( here_twice( $mysync ) ) { + my $mysync = shift @ARG ; + my $signame = shift @ARG ; + if ( here_twice( $mysync ) ) + { myprint( "Got two signals $signame within $INTERVAL_TO_EXIT seconds. Exiting...\n" ) ; catch_exit( $mysync, $signame ) ; - }else{ - myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), ")\n", + } + else + { + myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ), ")\n", "Hit 2 ctr-c within 2 seconds to exit the program\n", "Hit only 1 ctr-c to reconnect to both imap servers\n", ) ; myprint( "For now only one signal $signame within $INTERVAL_TO_EXIT seconds.\n" ) ; - if ( ! defined $mysync->{imap1} ) { return ; } - if ( ! defined $mysync->{imap2} ) { return ; } + if ( ! defined $mysync->{ imap1 } ) { return ; } + if ( ! defined $mysync->{ imap2 } ) { return ; } myprint( "Info: reconnecting to host1 imap server $mysync->{host1}\n" ) ; - $mysync->{imap1}->State( Mail::IMAPClient::Unconnected ) ; - $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT} += 1 ; - if ( $mysync->{imap1}->reconnect( ) ) + $mysync->{ imap1 }->State( Mail::IMAPClient::Unconnected ) ; + $mysync->{ imap1 }->{IMAPSYNC_RECONNECT_COUNT} += 1 ; + if ( $mysync->{ imap1 }->reconnect( ) ) { myprint( "Info: reconnected to host1 imap server $mysync->{host1}\n" ) ; } else { - $mysync->{nb_errors}++ ; + $mysync->{ nb_errors }++ ; exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ; } myprint( "Info: reconnecting to host2 imap server\n" ) ; - $mysync->{imap2}->State( Mail::IMAPClient::Unconnected ) ; - $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT} += 1 ; - if ( $mysync->{imap2}->reconnect( ) ) + $mysync->{ imap2 }->State( Mail::IMAPClient::Unconnected ) ; + $mysync->{ imap2 }->{IMAPSYNC_RECONNECT_COUNT} += 1 ; + if ( $mysync->{ imap2 }->reconnect( ) ) { myprint( "Info: reconnected to host2 imap server $mysync->{host2}\n" ) ; } else { - $mysync->{nb_errors}++ ; + $mysync->{ nb_errors }++ ; exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ; } myprint( "Info: reconnected to both imap servers\n" ) ; } return ; -} +} sub install_signals { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( under_docker_context( $mysync ) ) { @@ -7187,13 +8056,13 @@ sub tests_reconnect_12_if_needed my $mysync ; - $mysync->{imap1} = Mail::IMAPClient->new( ) ; - $mysync->{imap2} = Mail::IMAPClient->new( ) ; - $mysync->{imap1}->Server( 'test1.lamiral.info' ) ; - $mysync->{imap2}->Server( 'test2.lamiral.info' ) ; + $mysync->{ imap1 } = Mail::IMAPClient->new( ) ; + $mysync->{ imap2 } = Mail::IMAPClient->new( ) ; + $mysync->{ imap1 }->Server( 'test1.lamiral.info' ) ; + $mysync->{ imap2 }->Server( 'test2.lamiral.info' ) ; is( 2, reconnect_12_if_needed( $mysync ), 'reconnect_12_if_needed: test1&test2 .lamiral.info => 1' ) ; - is( 1, $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test1.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; - is( 1, $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test2.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; + is( 1, $mysync->{ imap1 }->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test1.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; + is( 1, $mysync->{ imap2 }->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test2.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; note( 'Leaving tests_reconnect_12_if_needed()' ) ; return ; @@ -7201,12 +8070,14 @@ sub tests_reconnect_12_if_needed sub reconnect_12_if_needed { - my $mysync = shift ; + my $mysync = shift @ARG ; #return 2 ; - if ( ! reconnect_if_needed( $mysync->{imap1} ) ) { + if ( ! reconnect_if_needed( $mysync->{ imap1 } ) ) + { return ; } - if ( ! reconnect_if_needed( $mysync->{imap2} ) ) { + if ( ! reconnect_if_needed( $mysync->{ imap2 } ) ) + { return ; } # both were good @@ -7240,14 +8111,16 @@ sub reconnect_if_needed # return undef upon failure. # return 1 upon connection success, with or without reconnection. - my $imap = shift ; + my $imap = shift @ARG ; if ( ! defined $imap ) { return ; } if ( ! $imap->Server( ) ) { return ; } - if ( $imap->IsUnconnected( ) ) { + if ( $imap->IsUnconnected( ) ) + { $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ; - if ( $imap->reconnect( ) ) { + if ( $imap->reconnect( ) ) + { return 1 ; } }else{ @@ -7258,7 +8131,8 @@ sub reconnect_if_needed $imap->State( Mail::IMAPClient::Unconnected ) ; $imap->reconnect( ) ; $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ; - if ( $imap->noop ) { + if ( $imap->noop ) + { # NOOP is ok return 1 ; } @@ -7269,7 +8143,7 @@ sub reconnect_if_needed sub justconnect { - my $mysync = shift ; + my $mysync = shift @ARG ; my $justconnect1 = justconnect1( $sync ) ; my $justconnect2 = justconnect2( $sync ) ; return "$justconnect1 $justconnect2"; @@ -7277,18 +8151,20 @@ sub justconnect sub justconnect1 { - my $mysync = shift ; - if ( $mysync->{host1} ) + my $mysync = shift @ARG ; + if ( $mysync->{ host1 } ) { - myprint( "Host1: Will just connect to $mysync->{host1} without login\n" ) ; - $mysync->{imap1} = connect_imap( - $mysync->{host1}, $mysync->{port1}, - $mysync->{ssl1}, $mysync->{tls1}, - $mysync->{ acc1 } ) ; + myprint( "Host1: Will just connect to $mysync->{ host1 } without login\n" ) ; + $mysync->{ imap1 } = connect_imap( + $mysync->{ host1 }, $mysync->{ port1 }, + $mysync->{ ssl1 }, $mysync->{ tls1 }, + $mysync->{ acc1 } + ) ; - imap_id( $mysync, $mysync->{imap1}, $mysync->{ acc1 }->{ Side } ) ; - $mysync->{imap1}->logout( ) ; - return $mysync->{host1} ; + imap_id( $mysync, $mysync->{ imap1 }, $mysync->{ acc1 }->{ Side } ) ; + $mysync->{ imap1 }->logout( ) ; + $mysync->{ acc1 }->{ justconnectdone } = 1 ; + return $mysync->{ host1 } ; } return q{} ; @@ -7296,28 +8172,126 @@ sub justconnect1 sub justconnect2 { - my $mysync = shift ; - if ( $mysync->{host2} ) + my $mysync = shift @ARG ; + if ( $mysync->{ host2 } ) { - myprint( "Host2: Will just connect to $mysync->{host2} without login\n" ) ; - $mysync->{imap2} = connect_imap( - $mysync->{host2}, $mysync->{port2}, - $mysync->{ssl2}, $mysync->{tls2}, - $mysync->{ acc2 } ) ; + myprint( "Host2: Will just connect to $mysync->{ host2 } without login\n" ) ; + $mysync->{ imap2 } = connect_imap( + $mysync->{ host2 }, $mysync->{ port2 }, + $mysync->{ ssl2 }, $mysync->{ tls2 }, + $mysync->{ acc2 } + ) ; - imap_id( $mysync, $mysync->{imap2}, $mysync->{ acc2 }->{ Side } ) ; - $mysync->{imap2}->logout( ) ; - return $mysync->{host2} ; + imap_id( $mysync, $mysync->{ imap2 }, $mysync->{ acc2 }->{ Side } ) ; + $mysync->{ imap2 }->logout( ) ; + $mysync->{ acc2 }->{ justconnectdone } = 1 ; + return $mysync->{ host2 } ; } return q{} ; } + +sub tests_trigger_justconnect1 +{ + note( 'Entering tests_trigger_justconnect1()' ) ; + + is( undef, trigger_justconnect1( ), 'tests_trigger_justconnect1: no args => undef' ) ; + my $mysync = { } ; + + is( undef, trigger_justconnect1( $mysync ), 'tests_trigger_justconnect1: { } => undef' ) ; + + $mysync->{ justconnect } = 1 ; + is( 1, trigger_justconnect1( $mysync ), 'tests_trigger_justconnect1: --justconnect => 1' ) ; + + delete $mysync->{ justconnect } ; + is( undef, trigger_justconnect1( $mysync ), 'tests_trigger_justconnect1: no more --justconnect => undef' ) ; + + $mysync->{ host1 } = 'hhh' ; + is( 1, trigger_justconnect1( $mysync ), 'tests_trigger_justconnect1: just --host1 => 1' ) ; + + $mysync->{ user1 } = 'uuu' ; + is( undef, trigger_justconnect1( $mysync ), 'tests_trigger_justconnect1: --host1 --user1 => 1' ) ; + + note( 'Leaving tests_trigger_justconnect1()' ) ; + return ; +} + + +sub trigger_justconnect1 +{ + my $mysync = shift @ARG ; + + if ( ! $mysync ) { return ; } + + if ( ! scalar( %{ $mysync } ) ) { return ; } + + if ( $mysync->{ justconnect } ) { return 1 ; } + + if ( + not $mysync->{ user1 } and not $mysync->{ acc1 }->{ oauthdirect } + ) + { + return 1 ; + } + + return ; +} + + +sub tests_trigger_justconnect2 +{ + note( 'Entering tests_trigger_justconnect2()' ) ; + + is( undef, trigger_justconnect2( ), 'tests_trigger_justconnect2: no args => undef' ) ; + my $mysync = { } ; + + is( undef, trigger_justconnect2( $mysync ), 'tests_trigger_justconnect2: { } => undef' ) ; + + $mysync->{ justconnect } = 1 ; + is( 1, trigger_justconnect2( $mysync ), 'tests_trigger_justconnect2: --justconnect => 1' ) ; + + delete $mysync->{ justconnect } ; + is( undef, trigger_justconnect2( $mysync ), 'tests_trigger_justconnect2: no more --justconnect => undef' ) ; + + $mysync->{ host2 } = 'aaa' ; + is( 1, trigger_justconnect2( $mysync ), 'tests_trigger_justconnect2: just --host2 => 1' ) ; + + $mysync->{ user2 } = 'uuu' ; + is( undef, trigger_justconnect2( $mysync ), 'tests_trigger_justconnect1: --host2 --user2 => 1' ) ; + + note( 'Leaving tests_trigger_justconnect2()' ) ; + return ; +} + + +sub trigger_justconnect2 +{ + my $mysync = shift @ARG ; + + if ( ! $mysync ) { return ; } + + if ( ! scalar( %{ $mysync } ) ) { return ; } + + if ( $mysync->{ justconnect } ) { return 1 ; } + + if ( + not $mysync->{ user2 } and not $mysync->{ acc2 }->{ oauthdirect } + ) + { + return 1 ; + } + + return ; +} + + + sub skip_macosx { #return ; # hostname is sometimes "macosx.polarhome.com" sometimes "macosx" - return( ( ( 'macosx.polarhome.com' eq hostname( ) ) || ( 'macosx' eq hostname( ) ) ) + return( ( ( 'macosx.polarhome.com' eq hostname( ) ) || ( 'macosx' eq hostname( ) ) ) && ( 'darwin' eq $OSNAME ) ) ; } @@ -7327,132 +8301,137 @@ sub skip_macosx_binary return( skip_macosx( ) && ( $PROGRAM_NAME =~ m{imapsync_bin_Darwin} ) ) ; } - - -sub tests_mailimapclient_connect +sub skip_ks5 { + return( 'ks5' eq hostname( ) ); +} + +sub skip_docker +{ + return( -e '/Dockerfile' ) ; +} + + +sub tests_mailimapclient_connect +{ note( 'Entering tests_mailimapclient_connect()' ) ; my $imap ; # ipv4 - ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4: new' ) ; - is( 'Mail::IMAPClient', ref( $imap ), 'mailimapclient_connect ipv4: ref is Mail::IMAPClient' ) ; + ok( $imap = Mail::IMAPClient->new( ), 'tests_mailimapclient_connect: ipv4 new' ) ; + is( 'Mail::IMAPClient', ref( $imap ), 'tests_mailimapclient_connect: ipv4 ref is Mail::IMAPClient' ) ; # Mail::IMAPClient 3.40 die on this... So we skip it, thanks to "mature" IO::Socket::IP # Mail::IMAPClient 3.42 is ok so this test is back. - is( undef, $imap->connect( ), 'mailimapclient_connect ipv4: connect with no server => failure' ) ; + is( undef, $imap->connect( ), 'tests_mailimapclient_connect: ipv4 connect with no server => failure' ) ; - 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( 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' ) ; + is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'tests_mailimapclient_connect: ipv4 setting Server(test.lamiral.info)' ) ; + is( 1, $imap->Debug( 1 ), 'tests_mailimapclient_connect: ipv4 setting Debug( 1 )' ) ; + is( 143, $imap->Port( 143 ), 'tests_mailimapclient_connect: ipv4 setting Port( 143 )' ) ; + is( 10, $imap->Timeout( 10 ), 'tests_mailimapclient_connect: ipv4 setting Timeout( 10 )' ) ; + like( ref( $imap->connect( ) ), qr/IO::Socket::INET|IO::Socket::IP/, 'tests_mailimapclient_connect: ipv4 connect to test.lamiral.info' ) ; + like( $imap->logout( ), qr/Mail::IMAPClient/, 'tests_mailimapclient_connect: ipv4 logout' ) ; + is( undef, undef $imap, 'tests_mailimapclient_connect: ipv4 free variable' ) ; # ipv4 + ssl - ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4 + ssl: new' ) ; - is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4 + ssl: setting Server(test.lamiral.info)' ) ; - is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4 + ssl: setting Debug( 1 )' ) ; - ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'mailimapclient_connect ipv4 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ; - is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv4 + ssl: setting Port( 993 )' ) ; - like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv4 + ssl: connect to test.lamiral.info' ) ; - like( $imap->logout( ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv4 + ssl: logout in ssl does not cause failure' ) ; - is( undef, undef $imap, 'mailimapclient_connect ipv4 + ssl: free variable' ) ; + ok( $imap = Mail::IMAPClient->new( ), 'tests_mailimapclient_connect: ipv4 + ssl: new' ) ; + is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'tests_mailimapclient_connect: ipv4 + ssl: setting Server(test.lamiral.info)' ) ; + is( 1, $imap->Debug( 1 ), 'tests_mailimapclient_connect: ipv4 + ssl: setting Debug( 1 )' ) ; + ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'tests_mailimapclient_connect: ipv4 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ; + is( 993, $imap->Port( 993 ), 'tests_mailimapclient_connect: ipv4 + ssl: setting Port( 993 )' ) ; + like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'tests_mailimapclient_connect: ipv4 + ssl: connect to test.lamiral.info' ) ; + like( $imap->logout( ), qr/Mail::IMAPClient/, 'tests_mailimapclient_connect: ipv4 + ssl: logout in ssl does not cause failure' ) ; + is( undef, undef $imap, 'tests_mailimapclient_connect: ipv4 + ssl: free variable' ) ; # ipv6 + ssl - 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( 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 )' ) ; + ok( $imap = Mail::IMAPClient->new( ), 'tests_mailimapclient_connect: ipv6 + ssl: new' ) ; + is( 'test1ipv6.lamiral.info', $imap->Server( 'test1ipv6.lamiral.info' ), 'tests_mailimapclient_connect: ipv6 + ssl: setting Server test1ipv6.lamiral.info' ) ; + is( 10, $imap->Timeout( 10 ), 'tests_mailimapclient_connect: ipv6 setting Timeout( 10 )' ) ; + ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'tests_mailimapclient_connect: ipv6 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ; + is( 993, $imap->Port( 993 ), 'tests_mailimapclient_connect: ipv6 + ssl: setting Port( 993 )' ) ; SKIP: { - if ( - 'CUILLERE' eq hostname() - or - skip_macosx() - or - -e '/.dockerenv' - or - 'pcHPDV7-HP' eq hostname() + if ( + 'CUILLERE' eq hostname( ) + or + skip_macosx( ) + or + skip_docker( ) + or + 'pcHPDV7-HP' eq hostname( ) + or '5521.local' eq hostname( ) ) - { - skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 4 ) ; + { + skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/polarhome/macstadium/docker cannot do ipv6', 4 ) ; + } + + is( 1, $imap->Debug( 1 ), 'tests_mailimapclient_connect: ipv4 + ssl: setting Debug( 1 )' ) ; + + # It sounds stupid but sometimes it avoids failures on the next test about $imap->connect + is( '2001:41d0:2:84e0::1', resolv( 'test1ipv6.lamiral.info' ), 'resolv: test1ipv6.lamiral.info => 2a01:e0a:c59:f090:f5eb:1776:332:41d5' ) ; + like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'tests_mailimapclient_connect: ipv6 + ssl: connect to test1ipv6.lamiral.info' ) ; + # This one is ok on petite, not on ks2, do not know why, so commented. + like( ref( $imap->logout( ) ), qr/Mail::IMAPClient/, 'tests_mailimapclient_connect: ipv6 + ssl: logout in ssl is ok on test1ipv6.lamiral.info' ) ; } - 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 => 2a01:e34:ecde:70d0:223:54ff:fec2:36d7' ) ; - - like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv6 + ssl: connect to petiteipv6.lamiral.info' ) ; - # This one is ok on petite, not on ks2, do not know why, so commented. - like( ref( $imap->logout( ) ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv6 + ssl: logout in ssl is ok on petiteipv6.lamiral.info' ) ; - } - - is( undef, undef $imap, 'mailimapclient_connect ipv6 + ssl: free variable' ) ; - - + is( undef, undef $imap, 'tests_mailimapclient_connect: ipv6 + ssl: free variable' ) ; note( 'Leaving tests_mailimapclient_connect()' ) ; return ; -} +} -sub tests_mailimapclient_connect_bug -{ +sub tests_mailimapclient_connect_bug +{ note( 'Entering tests_mailimapclient_connect_bug()' ) ; my $imap ; # ipv6 - ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect_bug ipv6: new' ) ; - 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 )' ) ; + ok( $imap = Mail::IMAPClient->new( ), 'tests_mailimapclient_connect_bug: ipv6: new' ) ; + is( 'ks6ipv6.lamiral.info', $imap->Server( 'ks6ipv6.lamiral.info' ), 'tests_mailimapclient_connect_bug: ipv6: setting Server(ks6ipv6.lamiral.info)' ) ; + is( 143, $imap->Port( 143 ), 'tests_mailimapclient_connect_bug: ipv6: setting Port( 993 )' ) ; SKIP: { if ( - 'CUILLERE' eq hostname() + 'CUILLERE' eq hostname( ) or - skip_macosx() + skip_macosx( ) or - -e '/.dockerenv' - or - 'pcHPDV7-HP' eq hostname() + 'pcHPDV7-HP' eq hostname( ) ) { 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 ks6ipv6.lamiral.info' ) - or diag( 'mailimapclient_connect_bug ipv6: ', $imap->LastError( ), $!, ) ; + like( ref( $imap->connect( ) ), qr/IO::Socket::INET/, 'tests_mailimapclient_connect_bug: ipv6: connect to ks6ipv6.lamiral.info' ) + or diag( 'tests_mailimapclient_connect_bug: ipv6: ', $imap->LastError( ), $!, ) ; } - #is( $imap->logout( ), undef, 'mailimapclient_connect_bug ipv6: logout in ssl causes failure' ) ; - is( undef, undef $imap, 'mailimapclient_connect_bug ipv6: free variable' ) ; + #is( $imap->logout( ), undef, 'tests_mailimapclient_connect_bug: ipv6: logout in ssl causes failure' ) ; + is( undef, undef $imap, 'tests_mailimapclient_connect_bug: ipv6: free variable' ) ; note( 'Leaving tests_mailimapclient_connect_bug()' ) ; return ; -} +} -sub tests_connect_socket -{ +sub tests_connect_socket +{ note( 'Entering tests_connect_socket()' ) ; - is( undef, connect_socket( ), 'connect_socket: no args' ) ; + is( undef, connect_socket( ), 'tests_connect_socket: no args' ) ; my $socket ; my $imap ; SKIP: { if ( - 'CUILLERE' eq hostname() + 'CUILLERE' eq hostname( ) or - skip_macosx() + skip_macosx( ) or - -e '/.dockerenv' + skip_docker( ) or - 'pcHPDV7-HP' eq hostname() + 'pcHPDV7-HP' eq hostname( ) ) { skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 2 ) ; @@ -7464,14 +8443,14 @@ sub tests_connect_socket ) ; - ok( $imap = connect_socket( $socket ), 'connect_socket: ks6ipv6.lamiral.info port 143 IO::Socket::INET6' ) ; + ok( $imap = connect_socket( $socket ), 'tests_connect_socket: ks6ipv6.lamiral.info port 143 IO::Socket::INET6' ) ; #$imap->Debug( 1 ) ; # myprint( $imap->capability( ) ) ; if ( $imap ) { $imap->logout( ) ; } - $IO::Socket::SSL::DEBUG = 4 ; + #$IO::Socket::SSL::DEBUG = 4 ; $socket = IO::Socket::SSL->new( PeerHost => 'ks6ipv6.lamiral.info', PeerPort => 993, @@ -7479,7 +8458,7 @@ sub tests_connect_socket SSL_cipher_list => 'DEFAULT:!DH', ) ; # myprint( $socket ) ; - ok( $imap = connect_socket( $socket ), 'connect_socket: ks6ipv6.lamiral.info port 993 IO::Socket::SSL' ) ; + ok( $imap = connect_socket( $socket ), 'tests_connect_socket: ks6ipv6.lamiral.info port 993 IO::Socket::SSL' ) ; #$imap->Debug( 1 ) ; # myprint( $imap->capability( ) ) ; # $socket->close( ) ; @@ -7493,7 +8472,7 @@ sub tests_connect_socket } note( 'Leaving tests_connect_socket()' ) ; return ; -} +} sub connect_socket { @@ -7513,70 +8492,64 @@ sub connect_socket } + + sub tests_probe_imapssl -{ +{ note( 'Entering tests_probe_imapssl()' ) ; - is( undef, probe_imapssl( ), 'probe_imapssl: no args => undef' ) ; - is( undef, probe_imapssl( 'unknown' ), 'probe_imapssl: unknown => undef' ) ; - - note( "hostname is: ", hostname() ) ; - SKIP: { - if ( - 'CUILLERE' eq hostname() - or - skip_macosx() - or - -e '/.dockerenv' - or - 'pcHPDV7-HP' eq hostname() - ) - { - skip( 'Tests avoided on CUILLERE or pcHPDV7-HP or Mac or docker: cannot do ipv6', 0 ) ; - } - # fed up with this one - #like( probe_imapssl( 'ks6ipv6.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: ks6ipv6.lamiral.info matches "* OK"' ) ; - } ; + is( undef, probe_imapssl( ), 'tests_probe_imapssl: no args => undef' ) ; + is( undef, probe_imapssl( 'unknown' ), 'tests_probe_imapssl: unknown => undef' ) ; + note( "hostname is: ", hostname( ) ) ; # 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"' ) ; - - like( probe_imapssl( 'test1.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: test1.lamiral.info matches "* OK"' ) ; + ok( resolv( 'imap.gmail.com' ), 'tests_probe_imapssl: resolv imap.gmail.com => something' ) ; + like( probe_imapssl( 'imap.gmail.com' ), qr/^\* OK/, 'tests_probe_imapssl: imap.gmail.com => matches "* OK"' ) ; + like( probe_imapssl( 'test1.lamiral.info' ), qr/^\* OK/, 'tests_probe_imapssl: test1.lamiral.info => matches "* OK"' ) ; + like( probe_imapssl( 'imap.gmail.com', 993 ), qr/^\* OK/, 'tests_probe_imapssl: imap.gmail.com port 993 => matches "* OK"' ) ; + like( probe_imapssl( 'test1.lamiral.info', 993 ), qr/^\* OK/, 'tests_probe_imapssl: test1.lamiral.info port 993 => matches "* OK"' ) ; + is( undef, probe_imapssl( 'test1.lamiral.info', 143 ), 'tests_probe_imapssl: test1.lamiral.info port 143 => failure' ) ; note( 'Leaving tests_probe_imapssl()' ) ; return ; } -sub probe_imapssl + +sub probe_imapssl { - my $host = shift ; + my $host = shift @ARG ; + my $port = shift @ARG || $IMAP_SSL_PORT ; if ( ! $host ) { return ; } - $sync->{ debug } and $IO::Socket::SSL::DEBUG = 4 ; + #$sync->{ debug } and $IO::Socket::SSL::DEBUG = 4 ; my $socket = IO::Socket::SSL->new( PeerHost => $host, - PeerPort => $IMAP_SSL_PORT, + PeerPort => $port, SSL_verifycn_scheme => 'imap', SSL_verify_mode => $SSL_VERIFY_POLICY, SSL_cipher_list => 'DEFAULT:!DH', ) ; - if ( ! $socket ) { return ; } - $sync->{ debug } and print "socket: $socket\n" ; + if ( ! $socket ) + { + myprint( "Probing imap ssl on host $host port $port, got failure.\n" ) ; + return ; + } + $sync->{ debug } and myprint( "socket: $socket\n" ) ; my $banner ; $socket->sysread( $banner, 65_536 ) ; - $sync->{ debug } and print "banner: $banner" ; + myprint( "Probing imap ssl on host $host port $port, got banner: $banner" ) ; $socket->close( ) ; return $banner ; -} +} -sub connect_imap + +sub connect_imap { - my( $host, $port, $ssl, $tls, $acc ) = @_ ; + my( $host, $port, $ssl, $tls, $acc ) = @ARG ; my $imap = Mail::IMAPClient->new( ) ; if ( $ssl ) { set_ssl( $imap, $acc ) } @@ -7584,9 +8557,9 @@ sub connect_imap $imap->Port( $port ) ; $imap->Debug( $acc->{ debugimap } ) ; $imap->Timeout( $acc->{ timeout } ) ; - + #$imap->Keepalive( $acc->{ keepalive } ) ; - + my $side = lc $acc->{ Side } ; @@ -7594,25 +8567,30 @@ sub connect_imap if ( ! $imap->connect( ) ) { - $sync->{nb_errors}++ ; + $sync->{ nb_errors }++ ; exit_clean( $sync, $EXIT_CONNECTION_FAILURE, - "$acc->{ Side }: Can not open imap connection on [$host]: ", + "$acc->{ Side }: Can not open imap connection on [$host] port [$port] : ", $imap->LastError, " $OS_ERROR\n" ) ; } - myprint( "$acc->{ Side } IP address: ", $imap->Socket->peerhost(), "\n" ) ; - + myprint( "$acc->{ Side } IP address: ", $imap->Socket->peerhost(), " Local IP address: ", $imap->Socket->sockhost(), "\n" ) ; my $banner = $imap->Results()->[0] ; myprint( "$acc->{ Side } banner: $banner" ) ; myprint( "$acc->{ Side } capability: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ; + if ( ( ! $ssl ) and ( ! defined $tls ) and $imap->has_capability( 'STARTTLS' ) ) + { + myprint( "$acc->{ Side }: going to ssl because STARTTLS is in CAPABILITY. Use --notls1 or --notls2 to avoid that behavior\n" ) ; + $tls = 1 ; + } + if ( $tls ) { set_tls( $imap, $acc ) ; if ( ! $imap->starttls( ) ) { - $sync->{nb_errors}++ ; + $sync->{ nb_errors }++ ; exit_clean( $sync, $EXIT_TLS_FAILURE, "$acc->{ Side }: Can not go to tls encryption on $side [$host]:", $imap->LastError, "\n" @@ -7621,62 +8599,110 @@ sub connect_imap myprint( "$acc->{ Side }: Socket successfully converted to SSL\n" ) ; } return( $imap ) ; -} +} + + + + + + + +sub tests_compress_starttls +{ + note( 'Entering tests_compress_starttls()' ) ; + + SKIP: + { + if ( skip_macosx( ) ) + { + skip( 'Tests avoided on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 8 ) ; + } + else + { + my $myimap ; + my $acc = {} ; + $acc->{ Side } = 'HostK' ; + $acc->{ authmech } = 'LOGIN' ; + $acc->{ debugimap } = 1 ; + $acc->{ compress } = 1 ; + $acc->{ N } = 'K' ; + $acc->{ sslargs } = { + SSL_verify_mode => 0, + } ; + + #$IO::Socket::SSL::DEBUG = 4 ; + ok( + $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, 1, + 1, 100, $acc, {}, + ), 'tests_compress_starttls: test1.lamiral.info test1 tls' + ) ; + ok( $myimap && $myimap->IsAuthenticated( ), 'tests_compress_starttls: test1.lamiral.info test1 tls IsAuthenticated' ) ; + + is( $acc->{ imap }, acc_compress_imap( $acc ), "tests_compress_starttls: test1.lamiral.info tls compression ok" ) ; + is( undef, acc_compress_imap( $acc ), "tests_compress_starttls: test1.lamiral.info tls compression 2nd time call nok" ) ; + + # Third, no compression + $acc->{ compress } = 0 ; + ok( + $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, 1, + 1, 100, $acc, {}, + ), 'tests_compress_starttls: test1.lamiral.info test1 tls no compression' + ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_compress_starttls: test1.lamiral.info test1 tls no compression IsAuthenticated' ) ; + + is( undef, acc_compress_imap( $acc ), "tests_compress_starttls: test1.lamiral.info no compression ok" ) ; + is( undef, acc_compress_imap( $acc ), "tests_compress_starttls: test1.lamiral.info 2nd no compression ok" ) ; + } + } + note( 'Leaving tests_compress_starttls()' ) ; + return ; +} + sub tests_compress_ssl { note( 'Entering tests_compress_ssl()' ) ; SKIP: { - if ( skip_macosx( ) ) - { - skip( 'Tests avoided on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 12 ) ; - } - else - { - my $myimap ; - my $acc = {} ; - $acc->{ Side } = 'HostK' ; - $acc->{ authmech } = 'LOGIN' ; - $acc->{ debugimap } = 1 ; - $acc->{ compress } = 1 ; - $acc->{ N } = 'K' ; + if ( skip_macosx( ) ) + { + skip( 'Tests avoided on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 8 ) ; + } + else + { + my $myimap ; + my $acc = {} ; + $acc->{ Side } = 'HostK' ; + $acc->{ authmech } = 'LOGIN' ; + $acc->{ debugimap } = 1 ; + $acc->{ compress } = 1 ; + $acc->{ N } = 'K' ; + + ok( + $myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1', + 1, undef, + 1, 100, $acc, {}, + ), 'tests_compress_ssl: test1.lamiral.info test1 ssl' + ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_compress_ssl: test1.lamiral.info test1 ssl IsAuthenticated' ) ; - ok( - $myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1', - 1, undef, - 1, 100, $acc, {}, - ), 'acc_compress_imap: test1.lamiral.info test1 ssl' ) ; - ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ; - - - is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info ok" ) ; - is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd nok" ) ; - - ok( - $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', - 0, undef, - 1, 100, $acc, {}, - ), 'acc_compress_imap: test1.lamiral.info test1 tls' ) ; - ok( $myimap && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 tls IsAuthenticated' ) ; - - is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls ok" ) ; - is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls 2nd nok" ) ; - - # Third, no compression - $acc->{ compress } = 0 ; - ok( - $myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1', - 1, undef, - 1, 100, $acc, {}, - ), 'acc_compress_imap: test1.lamiral.info test1 ssl' ) ; - ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ; - - - is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info off ok" ) ; - is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd off ok" ) ; - - } + is( $acc->{ imap }, acc_compress_imap( $acc ), "tests_compress_ssl: test1.lamiral.info compression ok" ) ; + is( undef, acc_compress_imap( $acc ), "tests_compress_ssl: test1.lamiral.info compression 2nd time call nok" ) ; + + # Third, no compression + $acc->{ compress } = 0 ; + ok( + $myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1', + 1, undef, + 1, 100, $acc, {}, + ), 'tests_compress_ssl: test1.lamiral.info test1 ssl' + ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_compress_ssl: test1.lamiral.info test1 ssl no compression IsAuthenticated' ) ; + is( undef, acc_compress_imap( $acc ), "tests_compress_ssl: test1.lamiral.info no compression ok" ) ; + is( undef, acc_compress_imap( $acc ), "tests_compress_ssl: test1.lamiral.info 2nd no compression ok" ) ; + } } note( 'Leaving tests_compress_ssl()' ) ; return ; @@ -7688,46 +8714,47 @@ sub tests_compress my $myimap ; my $acc = {} ; - $acc->{ Side } = 'HostK' ; + $acc->{ Side } = 'HostK' ; $acc->{ authmech } = 'LOGIN' ; $acc->{ debugimap } = 1 ; $acc->{ compress } = 1 ; $acc->{ N } = 'K' ; + + ok( + $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, 0, + 1, 100, $acc, {}, + ), 'tests_compress: test1.lamiral.info test1' + ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_compress: test1.lamiral.info test1 IsAuthenticated' ) ; + + + is( $acc->{ imap }, acc_compress_imap( $acc ), "tests_compress: test1.lamiral.info ok" ) ; + is( undef, acc_compress_imap( $acc ), "tests_compress: test1.lamiral.info 2nd nok" ) ; ok( $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', 0, 0, 1, 100, $acc, {}, - ), 'acc_compress_imap: test1.lamiral.info test1' ) ; - ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 IsAuthenticated' ) ; - - - is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info ok" ) ; - is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd nok" ) ; - - ok( - $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', - 0, 0, - 1, 100, $acc, {}, - ), 'acc_compress_imap: test1.lamiral.info test1 tls' ) ; - ok( $myimap && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 tls IsAuthenticated' ) ; - - is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls ok" ) ; - is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls 2nd nok" ) ; + ), 'tests_compress: test1.lamiral.info test1 tls' ) ; + ok( $myimap && $myimap->IsAuthenticated( ), 'tests_compress: test1.lamiral.info test1 tls IsAuthenticated' ) ; + is( $acc->{ imap }, acc_compress_imap( $acc ), "tests_compress: test1.lamiral.info tls ok" ) ; + is( undef, acc_compress_imap( $acc ), "tests_compress: test1.lamiral.info tls 2nd nok" ) ; + # Third, no compression $acc->{ compress } = 0 ; ok( $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', 0, 0, 1, 100, $acc, {}, - ), 'acc_compress_imap: test1.lamiral.info test1 ssl' ) ; - ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ; + ), 'tests_compress: test1.lamiral.info test1 ssl' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_compress: test1.lamiral.info test1 ssl IsAuthenticated' ) ; - is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info off ok" ) ; - is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd off ok" ) ; - + is( undef, acc_compress_imap( $acc ), "tests_compress: test1.lamiral.info off ok" ) ; + is( undef, acc_compress_imap( $acc ), "tests_compress: test1.lamiral.info 2nd off ok" ) ; + note( 'Leaving tests_compress()' ) ; return ; } @@ -7735,14 +8762,14 @@ sub tests_compress sub acc_compress_imap { - my $acc = shift ; - + my $acc = shift @ARG ; + if ( ! defined( $acc ) ) { return ; } - + my $ret ; my $imap = $acc->{ imap } ; if ( ! defined $imap ) { return ; } - + if ( $imap && $acc->{ compress } ) { myprint( "$acc->{ Side }: Trying to turn imap compression on. Use --nocompress" . $acc->{ N } . " to avoid compression on " . lc( $acc->{ Side } ) . "\n" ) ; @@ -7763,119 +8790,225 @@ sub acc_compress_imap return $ret ; } -sub tests_login_imap + +# 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' +# +# or this one: +# echo | openssl s_client -crlf -connect test1.lamiral.info:993 +# ... +# Verify return code: 9 (certificate is not yet valid) +# Fix: /etc/init.d/openntpd restart +# 2021_09_04 done + + +sub tests_login_imap_notls_nossl { - note( 'Entering tests_login_imap()' ) ; + note( 'Entering tests_login_imap_notls_nossl()' ) ; - is( undef, login_imap( ), 'login_imap: no args => undef' ) ; + is( undef, login_imap( ), 'tests_login_imap_notls_nossl: no args => undef' ) ; - SKIP: { - if ( skip_macosx( ) ) + SKIP: { - skip( 'Tests avoided only on binary on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 15 ) ; + if ( skip_macosx( ) ) + { + skip( 'Tests avoided only on binary on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 10 ) ; + } + else + { + my $myimap ; + my $acc = {} ; + $acc->{ Side } = 'HostK' ; + $acc->{ authmech } = 'LOGIN' ; + + + #login_imap( $host, $port, $user, $password, + # $ssl, $tls, + # $uid, $split, $acc, $mysync + + #$IO::Socket::SSL::DEBUG = 4 ; + ok( + $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, 0, + 1, 100, $acc, {}, + ), 'tests_login_imap_notls_nossl: test1.lamiral.info test1 tls' + ) ; + ok( $myimap && $myimap->IsAuthenticated( ), 'tests_login_imap_notls_nossl: test1.lamiral.info test1 tls IsAuthenticated' ) ; + is( $myimap, $acc->{ imap }, "tests_login_imap_notls_nossl: acc->{ imap } ok test1 tls") ; + + + # No name resolution + my $mysync = {} ; + $acc = {} ; + $acc->{ Side } = 'Host2' ; + $acc->{ authmech } = 'LOGIN' ; + is( + undef, login_imap( 'noresol.lamiral.info', 143, 'test1', 'secret1', + 0, 0, + 1, 100, $acc, $mysync, + ), 'tests_login_imap_notls_nossl: noresol.lamiral.info undef' + ) ; + + is( 'ERR_CONNECTION_FAILURE_HOST2', errorsanalyse( errors_log( $mysync ) ), 'tests_login_imap_notls_nossl: Host2 noresol.lamiral.info => ERR_CONNECTION_FAILURE_HOST2' ) ; + is( undef, $acc->{ imap }, "tests_login_imap_notls_nossl: acc->{ imap } noresol error => undef") ; + + # authentication failure for user2 + $mysync = {} ; + is( + undef, login_imap( 'test1.lamiral.info', 143, 'test1', 'Ce crétin', + 0, 0, + 1, 100, $acc, $mysync, + ), 'tests_login_imap_notls_nossl: user2 bad passord => undef' + ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER2', errorsanalyse( errors_log( $mysync ) ), 'tests_login_imap_notls_nossl: 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, 0, + 1, 100, $acc, $mysync, + ), 'tests_login_imap_notls_nossl: user1 bad passord => undef' + ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'tests_login_imap_notls_nossl: Host1 bad password => ERR_AUTHENTICATION_FAILURE_USER1' ) ; + } } - 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' - # - # or - # echo | openssl s_client -crlf -connect test1.lamiral.info:993 - # ... - # Verify return code: 9 (certificate is not yet valid) - # Fix: /etc/init.d/openntpd restart - # 2021_09_04 done - 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' ) ; - - is( $myimap, $acc->{ imap }, "login_imap: acc->{ imap } ok test1 ssl") ; - - 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' ) ; - is( $myimap, $acc->{ imap }, "login_imap: acc->{ imap } ok test1 tls") ; - - #$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' - is( undef, $acc->{ imap }, "login_imap: acc->{ imap } test1 tls error => undef") ; - - - # 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' ) ; - is( undef, $acc->{ imap }, "login_imap: acc->{ imap } noresol error => undef") ; - - # 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()' ) ; + + note( 'Leaving tests_login_imap_notls_nossl()' ) ; return ; } + +sub tests_login_imap_starttls +{ + note( 'Entering tests_login_imap_starttls()' ) ; + + SKIP: + { + if ( skip_macosx( ) ) + { + skip( 'Tests avoided only on binary on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 8 ) ; + } + else + { + my $myimap ; + my $acc = {} ; + $acc->{ Side } = 'HostK' ; + $acc->{ authmech } = 'LOGIN' ; + + $acc->{ sslargs } = { + SSL_verify_mode => 0, + } ; + + #login_imap( $host, $port, $user, $password, + # $ssl, $tls, + # $uid, $split, $acc, $mysync + + #$IO::Socket::SSL::DEBUG = 4 ; + ok( + $myimap = login_imap( + 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, 1, + 1, 100, $acc, {}, + ), 'tests_login_imap_starttls: test1.lamiral.info test1 tls' + ) ; + ok( $myimap && $myimap->IsAuthenticated( ), 'tests_login_imap_starttls: test1.lamiral.info test1 tls IsAuthenticated' ) ; + is( $myimap, $acc->{ imap }, "tests_login_imap_starttls: acc->{ imap } ok test1 tls") ; + + # STARTTLS port 143 + # SSLv2 not supported + #$IO::Socket::SSL::DEBUG = 4 ; + $acc->{ sslargs } = { + SSL_version => 'SSLv2', + } ; + + is( + undef, $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, 1, + 1, 100, $acc, {}, + ), 'tests_login_imap_starttls: test1.lamiral.info test1 tls SSLv2 not supported' + ) ; + #SSL_verify_mode => 1 + #SSL_version => 'TLSv1_1' + is( undef, $acc->{ imap }, "tests_login_imap_starttls: acc->{ imap } test1 tls error => undef") ; + + + # No name resolution + my $mysync = {} ; + $acc = {} ; + $acc->{ Side } = 'Host2' ; + $acc->{ authmech } = 'LOGIN' ; + is( + undef, login_imap( 'noresol.lamiral.info', 143, 'test1', 'secret1', + 0, 1, + 1, 100, $acc, $mysync, + ), 'tests_login_imap_starttls: noresol.lamiral.info undef' + ) ; + + is( 'ERR_CONNECTION_FAILURE_HOST2', errorsanalyse( errors_log( $mysync ) ), 'tests_login_imap_starttls: Host2 noresol.lamiral.info => ERR_CONNECTION_FAILURE_HOST2' ) ; + is( undef, $acc->{ imap }, "tests_login_imap_starttls: acc->{ imap } noresol error => undef") ; + } + } + + note( 'Leaving tests_login_imap_starttls()' ) ; + return ; +} + + + + + +sub tests_login_imap_ssl_993 +{ + note( 'Entering tests_login_imap_ssl_993()' ) ; + + SKIP: + { + if ( skip_macosx( ) ) + { + skip( 'Tests avoided only on binary on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 3 ) ; + } + else + { + + my $myimap ; + my $acc = {} ; + $acc->{ Side } = 'HostK' ; + $acc->{ authmech } = 'LOGIN' ; + $acc->{ debugimap } = 1 ; + + + # SSL mode port 993 + ok( + $myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1', + 1, undef, + 1, 100, $acc, {}, + ), 'tests_login_imap_ssl_993: test1.lamiral.info test1 ssl' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_login_imap_ssl_993: test1.lamiral.info test1 ssl IsAuthenticated' ) ; + is( $myimap, $acc->{ imap }, "tests_login_imap_ssl_993: acc->{ imap } ok test1 ssl") ; + } + + note( 'Leaving tests_login_imap_ssl_993()' ) ; + } + return ; +} + + + sub oauthgenerateaccess { if ( "petite" eq hostname() ) { myprint( "oauthgenerateaccess\n" ) ; - my @output = backtick( 'cd oauth2 && pwd && ./generate_gmail_token imapsync.gl0@gmail.com' ) ; + my @output = backtick( 'cd oauth2/oauth2_gmail/ && pwd && ./generate_gmail_token imapsync.gl0@gmail.com' ) ; myprint( @output ) ; } return ; @@ -7884,8 +9017,8 @@ sub oauthgenerateaccess sub tests_login_imap_oauth { note( 'Entering tests_login_imap_oauth()' ) ; - - oauthgenerateaccess() ; + + oauthgenerateaccess( ) ; SKIP: { if ( skip_macosx_binary( ) ) @@ -7901,129 +9034,212 @@ sub tests_login_imap_oauth $mysync = {} ; $acc = {} ; $acc->{ oauthdirect } = 'caca2' ; - $acc->{ debugimap } = 1 ; + #$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' ) ; + undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin', + 1, undef, + 1, 100, $acc, $mysync, + ), 'tests_login_imap_oauth: user2 bad oauthdirect => undef' + ) ; - is( 'ERR_AUTHENTICATION_FAILURE_USER2', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host2 bad oauthdirect => ERR_AUTHENTICATION_FAILURE_USER2' ) ; + is( 'ERR_AUTHENTICATION_FAILURE_USER2', errorsanalyse( errors_log( $mysync ) ), 'tests_login_imap_oauth: Host2 bad oauthdirect => ERR_AUTHENTICATION_FAILURE_USER2' ) ; # oauthdirect authentication failure for user1 $mysync = {} ; $acc = {} ; $acc->{ Side } = 'Host1' ; $acc->{ oauthdirect } = 'caca1' ; - $acc->{ debugimap } = 1 ; + #$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' ) ; + undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin', + 1, undef, + 1, 100, $acc, $mysync, + ), 'tests_login_imap_oauth: user1 bad oauthdirect => undef' ) ; - is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host1 bad oauthdirect => ERR_AUTHENTICATION_FAILURE_USER1' ) ; + is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'tests_login_imap_oauth: Host1 bad oauthdirect => ERR_AUTHENTICATION_FAILURE_USER1' ) ; # oauthdirect authentication failure for user1 $mysync = {} ; $acc = {} ; $acc->{ Side } = 'Host1' ; $acc->{ oauthdirect } = '' ; - $acc->{ debugimap } = 1 ; + #$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', 6 ) ; - } - 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', + undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin', 1, undef, 1, 100, $acc, $mysync, - ), 'Mail::IMAPClient', 'login_imap: user1 good oauthdirect => Mail::IMAPClient' ) ; + ), 'tests_login_imap_oauth: user1 bad oauthdirect => undef' ) ; - ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthdirect IsAuthenticated' ) ; + is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'tests_login_imap_oauth: Host1 no oauthdirect value => ERR_AUTHENTICATION_FAILURE_USER1' ) ; - ok( defined( $myimap ) && $myimap->logout( ), 'login_imap: gmail oauth2 oauthdirect logout' ) ; - ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthdirect not IsAuthenticated after logout' ) ; - ok( defined( $myimap ) && $myimap->reconnect( ), 'login_imap: gmail oauth2 oauthdirect reconnect ok' ) ; - ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthdirect IsAuthenticated after reconnect' ) ; + } } - - - # oauthaccesstoken authentication success for user1 + # oauthdirect authentication success for user1 SKIP: { - if ( ! -r 'oauth2/D_oauth2_access_token_imapsync.gl0@gmail.com.txt' ) + if ( ! -r 'oauth2/oauth2_gmail/D_oauth2_oauthdirect_imapsync.gl0@gmail.com.txt' ) { - skip( 'oauthaccesstoken: no access_token file', 6 ) ; + skip( 'oauthdirect: no oauthdirect file', 21 ) ; } my $myimap ; my $mysync = {} ; my $acc = {} ; $acc->{ Side } = 'Host1' ; - $acc->{ oauthaccesstoken } = 'oauth2/D_oauth2_access_token_imapsync.gl0@gmail.com.txt' ; - $acc->{ debugimap } = 1 ; + $acc->{ oauthdirect } = 'oauth2/oauth2_gmail/D_oauth2_oauthdirect_imapsync.gl0@gmail.com.txt' ; + #$acc->{ debugimap } = 1 ; + $mysync->{ showpasswords } = 1 ; + $acc->{ authmech } = 'QQQ' ; + note( 'login_imap' ) ; + isa_ok( + $myimap = login_imap( 'imap.gmail.com', 993, 'user_useless', 'password_useless', + 1, undef, + 1, 100, $acc, $mysync, + ), 'Mail::IMAPClient', 'tests_login_imap_oauth: user1 good oauthdirect => Mail::IMAPClient' + ) ; + + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect IsAuthenticated' ) ; + note( 'logout' ) ; + ok( defined( $myimap ) && $myimap->logout( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect logout 1' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect not IsAuthenticated after logout 1' ) ; + note( 'reconnect' ) ; + ok( defined( $myimap ) && $myimap->reconnect( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect reconnect 1 ok' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect IsAuthenticated after reconnect 1' ) ; + note( 'logout' ) ; + ok( defined( $myimap ) && $myimap->logout( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect logout 2' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect not IsAuthenticated after logout 2' ) ; + + # failure + $acc->{ oauthdirect } = 'caca3' ; + note( 'reconnect' ) ; + ok( defined( $myimap ) && ! $myimap->reconnect( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect reconnect 2 nok' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect not IsAuthenticated after reconnect 2' ) ; + + # success + $acc->{ oauthdirect } = 'oauth2/oauth2_gmail/D_oauth2_oauthdirect_imapsync.gl0@gmail.com.txt' ; + note( 'reconnect' ) ; + ok( defined( $myimap ) && $myimap->reconnect( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect reconnect 3 ok' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect IsAuthenticated after reconnect 3' ) ; + note( 'logout' ) ; + ok( defined( $myimap ) && $myimap->logout( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect logout 3' ) ; + + # No fake user, no fake password + note( 'login_imap' ) ; + isa_ok( + $myimap = login_imap( 'imap.gmail.com', 993, undef, undef, + 1, undef, + 1, 100, $acc, $mysync, + ), 'Mail::IMAPClient', 'tests_login_imap_oauth: user1 good oauthdirect no password => Mail::IMAPClient' + ) ; + + #$myimap->Debug( 1 ) ; + + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect no password IsAuthenticated' ) ; + note( 'logout' ) ; + ok( defined( $myimap ) && $myimap->logout( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect no password logout 1' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect no password not IsAuthenticated after logout 1' ) ; + note( 'reconnect' ) ; + ok( defined( $myimap ) && $myimap->reconnect( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect reconnect 1 ok' ) ; + note( 'IsAuthenticated' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect no password IsAuthenticated after reconnect 1' ) ; + + note( 'logout' ) ; + ok( defined( $myimap ) && $myimap->logout( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect logout 2' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthdirect no password not IsAuthenticated after logout 2' ) ; + } + + # oauthaccesstoken authentication success for user1 + SKIP: { + if ( ! -r 'oauth2/oauth2_gmail/D_oauth2_access_token_imapsync.gl0@gmail.com.txt' ) + { + skip( 'oauthaccesstoken: no access_token file', 20 ) ; + } + my $myimap ; + my $mysync = {} ; + my $acc = {} ; + $acc->{ Side } = 'Host1' ; + $acc->{ oauthaccesstoken } = 'oauth2/oauth2_gmail/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' ) ; + 1, undef, + 1, 100, $acc, $mysync, + ), 'Mail::IMAPClient', 'tests_login_imap_oauth: user1 good oauthaccesstoken => Mail::IMAPClient' + ) ; - ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthaccesstoken IsAuthenticated' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken IsAuthenticated' ) ; + + ok( defined( $myimap ) && $myimap->logout( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken logout 1' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken not IsAuthenticated after logout 1' ) ; + + ok( defined( $myimap ) && $myimap->reconnect( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken reconnect 1 ok' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken IsAuthenticated after reconnect 1' ) ; - ok( defined( $myimap ) && $myimap->logout( ), 'login_imap: gmail oauth2 oauthaccesstoken logout' ) ; - ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthaccesstoken not IsAuthenticated after logout' ) ; - ok( defined( $myimap ) && $myimap->reconnect( ), 'login_imap: gmail oauth2 oauthaccesstoken reconnect ok' ) ; - ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthaccesstoken IsAuthenticated after reconnect' ) ; + ok( defined( $myimap ) && $myimap->logout( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken logout 2' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken not IsAuthenticated after logout 2' ) ; + + # failure + $acc->{ oauthaccesstoken } = 'caca4' ; + ok( defined( $myimap ) && ! $myimap->reconnect( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken reconnect 2 nok' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken not IsAuthenticated after reconnect 2' ) ; + + # success + $acc->{ oauthaccesstoken } = 'oauth2/oauth2_gmail/D_oauth2_access_token_imapsync.gl0@gmail.com.txt' ; + ok( defined( $myimap ) && $myimap->reconnect( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken reconnect 3 ok' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken IsAuthenticated after reconnect 3' ) ; + + # No fake password + isa_ok( + $myimap = login_imap( 'imap.gmail.com', 993, 'imapsync.gl0@gmail.com', undef, + 1, undef, + 1, 100, $acc, $mysync, + ), 'Mail::IMAPClient', 'tests_login_imap_oauth: user1 good oauthaccesstoken no password => Mail::IMAPClient' + ) ; + + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken no password IsAuthenticated' ) ; + + ok( defined( $myimap ) && $myimap->logout( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken logout 1' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken no password not IsAuthenticated after logout 1' ) ; + + ok( defined( $myimap ) && $myimap->reconnect( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken no password reconnect 1 ok' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken no password IsAuthenticated after reconnect 1' ) ; + + ok( defined( $myimap ) && $myimap->logout( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken logout 2' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'tests_login_imap_oauth: gmail oauth2 oauthaccesstoken no password not IsAuthenticated after logout 2' ) ; + } - - + + note( 'Leaving tests_login_imap_oauth()' ) ; return ; } - sub login_imap { - my @allargs = @_ ; + my @allargs = @ARG ; my( $host, $port, $user, $password, $ssl, $tls, - $uid, $split, $acc, $mysync ) = @allargs ; + $uid, $split, $acc, $mysync + ) = @allargs ; $acc->{ imap } = undef ; - - if ( ! all_defined( $host, $port, $user, $acc->{ Side } ) ) + + if ( ! all_defined( $host, $port, $acc->{ Side } ) ) + { + return ; + } + + if ( $acc->{ justconnectdone } ) { return ; } @@ -8035,25 +9251,29 @@ sub login_imap if ( ! $imap->connect() ) { - my $error = "$acc->{ Side } failure: can not open imap connection on $side [$host] with user [$user]: " + my $error = "$acc->{ Side } failure: can not open imap connection on $side [$host] port [$port] with user [$user]: " . $imap->LastError . " $OS_ERROR\n" ; errors_incr( $mysync, $error ) ; return ; } - myprint( "$acc->{ Side } IP address: ", $imap->Socket->peerhost(), "\n" ) ; + + # Add also $imap->Socket->sockhost() to help configuring firewalls, allowed rule. + myprint( "$acc->{ Side } IP address: ", $imap->Socket->peerhost(), " Local IP address: ", $imap->Socket->sockhost(), "\n" ) ; my $banner = $imap->Results()->[0] ; 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' ) ) { + if ( ( ! $ssl ) and ( ! defined $tls ) and $imap->has_capability( 'STARTTLS' ) ) + { myprint( "$acc->{ Side }: going to ssl because STARTTLS is in CAPABILITY. Use --notls1 or --notls2 to avoid that behavior\n" ) ; $tls = 1 ; } #myprint( Data::Dumper->Dump( [ @allargs ] ) ) ; - if ( $tls ) { + if ( $tls ) + { set_tls( $imap, $acc ) ; if ( ! $imap->starttls( ) ) @@ -8067,12 +9287,16 @@ sub login_imap myprint( "$acc->{ Side }: Socket successfully converted to SSL\n" ) ; } - if ( $acc->{ authmech } eq 'PREAUTH' ) { - if ( $imap->IsAuthenticated( ) ) { + if ( $acc->{ authmech } eq 'PREAUTH' ) + { + if ( $imap->IsAuthenticated( ) ) + { $imap->Socket ; myprintf("%s: Assuming PREAUTH for %s\n", $acc->{ Side }, $imap->Server ) ; - }else{ - $mysync->{nb_errors}++ ; + } + else + { + $mysync->{ nb_errors }++ ; exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE, "$acc->{ Side } failure: error login on $side [$host] with user [$user] auth [PREAUTH]\n" @@ -8103,18 +9327,15 @@ sub init_imap my( $host, $port, $user, $password, $ssl, $tls, - $uid, $split, $acc, $mysync ) = @_ ; + $uid, $split, $acc, $mysync ) = @ARG ; 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 } ) ; - } + # Well, it does not change anything, does it? + # It does when suppressing the hack with *STDERR + $imap->Debug_fh( $mysync->{ tee } || *STDOUT ) ; if ( $ssl ) { set_ssl( $imap, $acc ) } if ( $tls ) { } # can not do set_tls() here because connect() will directly do a STARTTLS @@ -8145,7 +9366,7 @@ sub init_imap { $imap->Reconnectretry( $acc->{ reconnectretry } ) ; } - + $imap->{IMAPSYNC_RECONNECT_COUNT} = 0 ; $imap->Ignoresizeerrors( $allowsizemismatch ) ; $split and $imap->Maxcommandlength( $SPLIT_FACTOR * $split ) ; @@ -8160,7 +9381,7 @@ sub authenticate_imap my( $imap, $host, $port, $user, $password, $ssl, $tls, - $uid, $split, $acc, $mysync ) = @_ ; + $uid, $split, $acc, $mysync ) = @ARG ; check_capability( $imap, $acc->{ authmech }, $acc->{ Side } ) ; $imap->User( $user ) ; @@ -8186,15 +9407,15 @@ sub authenticate_imap $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 } ) { @@ -8281,25 +9502,36 @@ sub failure_proxyauth +sub token +{ + my $oauthtoken = shift @ARG ; + my $oauthrefreshcmd = shift @ARG ; + + if ( defined $oauthrefreshcmd ) + { + myprint( "Executing script: $oauthrefreshcmd\n" ) ; + my $output = backtick( "$oauthrefreshcmd" ) ; + if ( $output ) + { + print "Output of $oauthrefreshcmd\n$output" ; + } + } + + my $token = firstline_or_string( $oauthtoken ) ; + + return( $token ) ; + +} 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' ; - } + my( $mysync, $acc, $imap, $host, $user ) = @ARG ; $imap->Authmechanism( 'XOAUTH2' ) ; - $imap->Authcallback( sub { return $oauthdirect_str } ) ; - - #if ( $imap->authenticate('XOAUTH2', sub { return $oauthdirect_str } ) ) + defined( $imap->User ) || $imap->User ( 'FakeUser ' ) ; + defined( $imap->Password ) || $imap->Password( 'FakePassword' ) ; + $imap->Authcallback( sub { return( token( $mysync, $acc->{ oauthdirect }, $acc->{ oauthrefreshcmd } ) ) } ) ; + if ( $imap->login( ) ) { return 1 ; @@ -8313,34 +9545,58 @@ sub oauthdirect } +sub tests_oauth2_bearer_string +{ + note( 'Entering tests_oauth2_bearer_string()' ) ; + + is( undef, oauth2_bearer_string( ), 'tests_oauth2_bearer_string: no args => undef' ) ; + + is( undef, oauth2_bearer_string( '' ), 'tests_oauth2_bearer_string: empty string, no user => undef' ) ; + + my $mysync = { } ; + + is( 'dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ==', oauth2_bearer_string( $mysync, '', '' ), 'tests_oauth2_bearer_string: empty string, empty user => dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ' ) ; + + is( 'dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ==', oauth2_bearer_string( $mysync, '', '', 'noexists' ), 'tests_oauth2_bearer_string: empty string, empty user, noexists command => dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ' ) ; + is( 'dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ==', oauth2_bearer_string( $mysync, '', '', 'true' ), 'tests_oauth2_bearer_string: empty string, empty user, true command => dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ' ) ; + is( 'dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ==', oauth2_bearer_string( $mysync, '', '', 'false' ), 'tests_oauth2_bearer_string: empty string, empty user, false command => dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ' ) ; + is( 'dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ==', oauth2_bearer_string( $mysync, '', '', 'ls /kkkk' ), 'tests_oauth2_bearer_string: empty string, empty user, ls /kkkk command => dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ' ) ; + + is( 'dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ==', oauth2_bearer_string( $mysync, '', '', 'echo Hi!' ), 'tests_oauth2_bearer_string: empty string, empty user, empty command => dXNlcj0BYXV0aD1CZWFyZXIgcGxlYXNlLCBnaXZlIGEgdmFsdWUBAQ' ) ; + + note( 'Leaving tests_oauth2_bearer_string()' ) ; + return ; +} + +sub oauth2_bearer_string +{ + + my $mysync = shift @ARG ; + my $oauthaccesstoken = shift @ARG ; + my $user = shift @ARG ; + my $oauthrefreshcmd = shift @ARG ; + + if ( ! defined $mysync ) { return ; } + if ( ! defined $oauthaccesstoken ) { return ; } + if ( ! defined $user ) { return ; } + + my $oauthaccesstoken_str = token( $oauthaccesstoken, $oauthrefreshcmd ) ; + my $oauth_string = "user=" . $user . "\x01auth=Bearer ". $oauthaccesstoken_str . "\x01\x01" ; + + my $oauthdirect_str = encode_base64( $oauth_string , '' ) ; + + return $oauthdirect_str ; +} 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 ; + my( $mysync, $acc, $imap, $host, $user ) = @ARG ; $imap->Authmechanism( 'XOAUTH2' ) ; - $imap->Authcallback( sub { return $oauthdirect_str } ) ; - - #if ( $imap->authenticate('XOAUTH2', sub { return $oauthdirect_str } ) ) + defined( $imap->Password ) || $imap->Password( 'FakePassword' ) ; + $imap->Authcallback( sub { return oauth2_bearer_string( $mysync, $acc->{ oauthaccesstoken }, $user, $acc->{ oauthrefreshcmd } ) } ) ; + if ( $imap->login( ) ) { return 1 ; @@ -8359,7 +9615,7 @@ sub oauthaccesstoken sub check_capability { - my( $imap, $authmech, $Side ) = @_ ; + my( $imap, $authmech, $Side ) = @ARG ; if ( $imap->has_capability( "AUTH=$authmech" ) @@ -8391,7 +9647,7 @@ sub check_capability sub set_ssl { - my ( $imap, $acc ) = @_ ; + my ( $imap, $acc ) = @ARG ; # SSL_version can be # SSLv3 SSLv2 SSLv23 SSLv23:!SSLv2 (last one is the default in IO-Socket-SSL-1.953) # @@ -8421,7 +9677,7 @@ sub set_ssl sub set_tls { - my ( $imap, $acc ) = @_ ; + my ( $imap, $acc ) = @ARG ; my $sslargs_hash = $acc->{sslargs} ; @@ -8492,15 +9748,15 @@ sub xoauth2 require HTML::Entities ; require JSON ; require JSON::WebToken::Crypt::RSA ; - require Crypt::OpenSSL::PKCS12; require Crypt::OpenSSL::RSA ; + require Crypt::OpenSSL::PKCS12 ; require Encode::Byte ; require IO::Socket::SSL ; my $code = shift; my $imap = shift; - my ($iss,$key); + my ( $iss, $key ) ; if( $imap->Password =~ /^(.*\.json)$/x ) { @@ -8510,7 +9766,7 @@ sub xoauth2 my $FILE ; if ( ! open( $FILE, '<', $filename ) ) { - $sync->{nb_errors}++ ; + $sync->{ nb_errors }++ ; exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "error [$filename]: $OS_ERROR\n" ) ; @@ -8518,10 +9774,10 @@ sub xoauth2 my $jsonfile = $json->decode( join q{}, <$FILE> ) ; close $FILE ; - $iss = $jsonfile->{client_id}; - $key = $jsonfile->{private_key}; - $sync->{ debug } and myprint( "Service account: $iss\n"); - $sync->{ debug } and myprint( "Private key:\n$key\n"); + $iss = $jsonfile->{ client_id } ; + $key = $jsonfile->{ private_key } ; + $sync->{ debug } and myprint( "Service account: $iss\n" ) ; + $sync->{ debug } and myprint( "Private key:\n$key\n" ) ; } else { @@ -8529,20 +9785,25 @@ sub xoauth2 ( $iss, my $keyfile, my $keypass ) = $imap->Password =~ /([\-\d\w\@\.]+);([a-zA-Z0-9 \_\-\.\/]+);?(.*)?/x ; # Assume key password is google default if not provided - $keypass = 'notasecret' if not $keypass; + $keypass = 'notasecret' if not $keypass ; - $sync->{ debug } and myprint( "Service account: $iss\nKey file: $keyfile\nKey password: $keypass\n"); + $sync->{ debug } and myprint( "Service account: $iss\nKey file: $keyfile\nKey password: $keypass\n") ; - # Get private key from p12 file - my $pkcs12 = Crypt::OpenSSL::PKCS12->new_from_file($keyfile); - $key = $pkcs12->private_key($keypass); + # Get private key from p12 file (would be better in perl...) + # $key = `openssl pkcs12 -in "$keyfile" -nodes -nocerts -passin pass:$keypass -nomacver` ; + + # https://github.com/imapsync/imapsync/pull/381/files + # Get private key from p12 file + my $pkcs12 = Crypt::OpenSSL::PKCS12->new_from_file( $keyfile ) ; + $key = $pkcs12->private_key( $keypass ) ; - $sync->{ debug } and myprint( "Private key:\n$key\n"); + $sync->{ debug } and myprint( "Private key:\n$key\n") ; } # Create jwt of oauth2 request my $time = time ; - my $jwt = JSON::WebToken->encode( { + my $jwt = JSON::WebToken->encode( + { 'iss' => $iss, # service account 'scope' => 'https://mail.google.com/', 'aud' => 'https://www.googleapis.com/oauth2/v3/token', @@ -8560,12 +9821,15 @@ sub xoauth2 { grant_type => HTML::Entities::encode_entities('urn:ietf:params:oauth:grant-type:jwt-bearer'), assertion => $jwt } ) ; - unless( $response->is_success( ) ) { + unless( $response->is_success( ) ) + { $sync->{nb_errors}++ ; exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, $response->code, "\n", $response->content, "\n" ) ; - }else{ + } + else + { $sync->{ debug } and myprint( $response->content ) ; } @@ -8575,20 +9839,20 @@ sub xoauth2 # format as oauth2 auth data my $xoauth2_string = encode_base64( 'user=' . $imap->User . "\1auth=Bearer " . $data->{access_token} . "\1\1", q{} ) ; - $sync->{ debug } and myprint( "XOAUTH2 String: $xoauth2_string\n"); - return($xoauth2_string); -} + $sync->{ debug } and myprint( "XOAUTH2 String: $xoauth2_string\n" ) ; + return( $xoauth2_string ) ; +} -sub xmasterauth +sub xmasterauth { # This is Kerio auth admin # This code comes from # https://github.com/imapsync/imapsync/pull/53/files - my $imap = shift ; + my $imap = shift @ARG ; my $user = $imap->User( ) ; my $password = $imap->Password( ) ; @@ -8597,7 +9861,7 @@ sub xmasterauth my @challenge = $imap->tag_and_run( $authmech, "+" ) ; if ( not defined $challenge[0] ) { - $sync->{nb_errors}++ ; + $sync->{ nb_errors }++ ; exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Failure authenticate with $authmech: ", $imap->LastError, "\n" @@ -8609,7 +9873,7 @@ sub xmasterauth $challenge[1] =~ s/^\+ |^\s+|\s+$//g ; if ( ! $imap->_imap_command( { addcrlf => 1, addtag => 0, tag => $imap->Count }, md5_hex( $challenge[1] . $password ) ) ) { - $sync->{nb_errors}++ ; + $sync->{ nb_errors }++ ; exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Failure authenticate with $authmech: ", $imap->LastError, "\n" @@ -8618,7 +9882,7 @@ sub xmasterauth if ( ! $imap->tag_and_run( 'X-SETUSER ' . $user ) ) { - $sync->{nb_errors}++ ; + $sync->{ nb_errors }++ ; exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Failure authenticate with $authmech: ", "X-SETUSER ", $imap->LastError, "\n" @@ -8630,14 +9894,14 @@ sub xmasterauth # $imap->State( Mail::IMAPClient::Selected ) ; return ; -} +} sub keepalive1 { - my $mysync = shift ; - + my $mysync = shift @ARG ; + $mysync->{ acc1 }->{ keepalive } = defined $mysync->{ acc1 }->{ keepalive } ? $mysync->{ acc1 }->{ keepalive } : 1 ; - + if ( $mysync->{ acc1 }->{ keepalive } ) { myprint( "Host1: imap connection keepalive is on on host1. Use --nokeepalive1 to disable it.\n" ) ; @@ -8646,14 +9910,16 @@ sub keepalive1 { myprint( "Host1: imap connection keepalive is off on host1. Use --keepalive1 to enable it.\n" ) ; } + + return ; } sub keepalive2 { - my $mysync = shift ; - + my $mysync = shift @ARG ; + $mysync->{ acc2 }->{ keepalive } = defined $mysync->{ acc2 }->{ keepalive } ? $mysync->{ acc2 }->{ keepalive } : 1 ; - + if ( $mysync->{ acc2 }->{ keepalive } ) { myprint( "Host2: imap connection keepalive is on on host2. Use --nokeepalive2 to disable it.\n" ) ; @@ -8662,6 +9928,8 @@ sub keepalive2 { myprint( "Host2: imap connection keepalive is off on host2. Use --keepalive2 to enable it.\n" ) ; } + + return ; } @@ -8673,8 +9941,8 @@ sub banner_imapsync my $banner_imapsync = join q{}, q{$RCSfile: imapsync,v $ }, - q{$Revision: 2.178 $ }, - q{$Date: 2022/01/12 21:28:37 $ }, + q{$Revision: 2.314 $ }, + q{$Date: 2025/09/23 16:55:17 $ }, "\n", "Command line used, run by $EXECUTABLE_NAME:\n", "$PROGRAM_NAME ", command_line_nopassword( $mysync, @argv ), "\n" ; @@ -8682,57 +9950,139 @@ sub banner_imapsync return( $banner_imapsync ) ; } -sub tests_do_valid_directory -{ - note( 'Entering tests_do_valid_directory()' ) ; +sub tests_make_valid_directory +{ + note( 'Entering tests_make_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' ) ; + is( undef, make_valid_directory( ), 'tests_make_valid_directory: no args => undef' ) ; + + is( undef, make_valid_directory( '' ), 'tests_make_valid_directory: empty string => undef' ) ; + + my $mysync = { } ; + is( undef, make_valid_directory( $mysync ), 'tests_make_valid_directory: no dir => undef' ) ; + + + # Cite a common file on any system: myself. Dangerous? + is( 0, make_valid_directory( $mysync, $0 ), 'tests_make_valid_directory: a file is not a valid directory' ) ; + # + is( 1, make_valid_directory( $mysync, '.' ), 'tests_make_valid_directory: . good' ) ; + is( 1, make_valid_directory( $mysync, './W/tmp/tests/valid/sub' ), 'tests_make_valid_directory: ./W/tmp/tests/valid/sub ok' ) ; + is( 1, make_valid_directory( $mysync, './W/tmp/tests/valid' ), 'tests_make_valid_directory: ./W/tmp/tests/valid ok' ) ; + is( 1, make_valid_directory( $mysync, './W/tmp/tests/valid/sub' ), 'tests_make_valid_directory: ./W/tmp/tests/valid/sub ok 2' ) ; + is( 1, make_valid_directory( $mysync, './W/tmp/tests/valid/qqq' ), 'tests_make_valid_directory: ./W/tmp/tests/valid/qqq ok' ) ; - 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' ) ; + SKIP: + { + if ( '0' eq $EFFECTIVE_USER_ID ) + { + skip( 'Tests only for non root user', 2 ) + } + diag( 'The "Error / has not good enough permissions" is on purpose' ) ; + ok( 0 == make_valid_directory( $mysync, '/'), 'tests_make_valid_directory: / is not valid for me' ) ; diag( 'The "Error permission denied" on /noway is on purpose' ) ; - ok( 0 == do_valid_directory( '/noway'), 'do_valid_directory: /noway bad' ) ; + ok( 0 == make_valid_directory( $mysync, '/noway'), 'tests_make_valid_directory: /noway is not valid for me' ) ; } + SKIP: + { + if ( 'MSWin32' ne $OSNAME ) + { + skip( 'Tests only for MSWin32', 1 ) + } + diag( 'The error mkdir K:\Beurk is on purpose' ) ; + ok( 0 == make_valid_directory( $mysync, 'K:\Beurk' ), 'tests_make_valid_directory: K:\Beurk failure but that is what we want' ) ; + } - note( 'Leaving tests_do_valid_directory()' ) ; + note( 'Dump of the buffered output' ) ; + myprint( output( $mysync ) ) ; + + note( 'Leaving tests_make_valid_directory()' ) ; return ; -} +} -sub do_valid_directory + + +sub make_valid_directory { - my $dir = shift @ARG ; - # all good => return ok. - return( 1 ) if ( -d $dir and -r _ and -w _ ) ; + my $mysync = shift @ARG ; + my $dir = shift @ARG ; + + if ( ! defined( $mysync ) ) { return ; } + if ( ! defined( $dir ) ) { return ; } + if ( ! $dir ) { return ; } # exist but bad - if ( -e $dir and not -d _ ) { - myprint( "Error: $dir exists but is not a directory\n" ) ; + if ( -e $dir and not -d _ ) + { + output( $mysync, "Error: $dir exists but it is not a directory\n" ) ; return( 0 ) ; } - if ( -e $dir and not -w _ ) { - my $sb = stat $dir ; - myprintf( "Error: directory %s is not writable for user %s, permissions are %04o and owner is %s ( uid %s )\n", - $dir, getpwuid_any_os( $EFFECTIVE_USER_ID ), ($sb->mode & oct($PERMISSION_FILTER) ), getpwuid_any_os( $sb->uid ), $sb->uid( ) ) ; - return( 0 ) ; + + if ( not -e $dir ) + { + # Trying to create it + output( $mysync, "Creating directory $dir (current directory is " . getcwd( ) . ")\n" ) ; + if ( ! eval { mkpath( $dir ) } ) + { + if ( $EVAL_ERROR ) + { + output( $mysync, "$EVAL_ERROR" ) ; + } + return( 0 ) ; + } } - # Trying to create it - myprint( "Creating directory $dir (current directory is " . getcwd( ) . ")\n" ) ; - if ( ! eval { mkpath( $dir ) } ) { - myprint( "$EVAL_ERROR" ) if ( $EVAL_ERROR ) ; - } - return( 1 ) if ( -d $dir and -r _ and -w _ ) ; - return( 0 ) ; + + return( is_dir_writable_or_make_it_writable( $mysync, $dir ) ) ; } +sub is_dir_writable_or_make_it_writable +{ + my $mysync = shift @ARG ; + my $dir = shift @ARG ; + + if ( -e $dir and not -d _ ) + { + # exist but bad + output( $mysync, "Error: $dir exists but it is not a directory\n" ) ; + return( 0 ) ; + } + elsif ( -d $dir and -r _ and -w _ and -x _ ) + { + # all good => return ok. + output( $mysync, "Directory $dir is writable and readable and gointoable. Good.\n" ) ; + return( 1 ) ; + } + elsif ( -e $dir ) + { + # not writable or not readable or not gointoable + output( $mysync, "Directory $dir has not good enough permissions. Trying a chmod 755.\n" ) ; + if ( chmod( 0755, $dir ) and ( -d $dir and -r _ and -w _ ) ) + { + output( $mysync, "Directory $dir is now writable and readable. Good.\n" ) ; + return( 1 ) ; + } + else + { + my $sb = stat $dir ; + output( $mysync, + sprintf( "Bad: directory %s for user %s, permissions are %04o and owner is %s ( uid %s )\n", + $dir, getpwuid_any_os( $EFFECTIVE_USER_ID ), ($sb->mode & oct($PERMISSION_FILTER) ), + getpwuid_any_os( $sb->uid ), $sb->uid( ) ) ) ; + return( 0 ) ; + } + } + else + { + # sounds dark here. + output( $mysync, "Directory $dir does not exist\n" ) ; + return( 0 ) ; + } +} + sub tests_match_a_pid_number { note( 'Entering tests_match_a_pid_number()' ) ; @@ -8783,6 +10133,7 @@ sub tests_remove_pidfile_not_running note( 'Entering tests_remove_pidfile_not_running()' ) ; ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'remove_pidfile_not_running: mkpath W/tmp/tests/' ) ; + is( undef, remove_pidfile_not_running( ), 'remove_pidfile_not_running: no args => undef' ) ; is( undef, remove_pidfile_not_running( './W' ), 'remove_pidfile_not_running: a dir => undef' ) ; is( undef, remove_pidfile_not_running( 'noexists' ), 'remove_pidfile_not_running: noexists => undef' ) ; @@ -8803,16 +10154,16 @@ 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 ; } #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 ) ; @@ -8836,8 +10187,8 @@ sub remove_pidfile_not_running } -sub tests_tail -{ +sub tests_tail +{ note( 'Entering tests_tail()' ) ; ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'tail: mkpath W/tmp/tests/' ) ; @@ -8848,15 +10199,15 @@ sub tests_tail my $mysync ; is( undef, tail( $mysync ), 'tail: no pidfile => undef' ) ; - $mysync->{pidfile} = 'W/tmp/tests/tail.pid' ; + $mysync->{ pidfile } = 'W/tmp/tests/tail.pid' ; is( undef, tail( $mysync ), 'tail: no pidfilelocking => undef' ) ; - $mysync->{pidfilelocking} = 1 ; + $mysync->{ pidfilelocking } = 1 ; is( undef, tail( $mysync ), 'tail: pidfile no exists => undef' ) ; my $pidandlog = "33333\nW/tmp/tests/tail.txt\n" ; - is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put pid 33333 and tail.txt in pidfile' ) ; + is( $pidandlog, string_to_file( $pidandlog, $mysync->{ pidfile } ), 'tail: put pid 33333 and tail.txt in pidfile' ) ; is( undef, tail( $mysync ), 'tail: logfile to tail no exists => undef' ) ; my $tailcontent = "L1\nL2\nL3\nL4\nL5\n" ; @@ -8870,46 +10221,59 @@ sub tests_tail # put my own pid, won't do tail $pidandlog = "$PROCESS_ID\nW/tmp/tests/tail.txt\n" ; - is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put my own PID in pidfile' ) ; + is( $pidandlog, string_to_file( $pidandlog, $mysync->{ pidfile } ), 'tail: put my own PID in pidfile' ) ; is( undef, tail( $mysync ), 'tail: my own pid in pidfile => undef' ) ; note( 'Leaving tests_tail()' ) ; return ; -} +} -sub tail +sub tail { # return undef on failures # return 1 on success - my $mysync = shift ; + my $mysync = shift @ARG ; # no tail when aborting! if ( $mysync->{ abort } ) { return ; } - my $pidfile = $mysync->{pidfile} ; - my $lock = $mysync->{pidfilelocking} ; - my $tail = $mysync->{tail} ; + my $pidfile = $mysync->{ pidfile } ; + my $lock = $mysync->{ pidfilelocking } ; + my $tail = $mysync->{ tail } ; if ( ! $pidfile ) { return ; } if ( ! $lock ) { return ; } if ( ! $tail ) { return ; } if ( ! -e $pidfile ) { return ; } - + + my $pidtotail = firstline( $pidfile ) ; - if ( ! $pidtotail ) { return ; } + if ( ! $pidtotail ) + { + myprint( "Can not do a tail -f : no pid in 1st line of pidfile $pidfile\n" ) ; + return ; + } # It should not happen but who knows... - if ( $pidtotail eq $PROCESS_ID ) { return ; } + if ( $pidtotail eq $PROCESS_ID ) + { + myprint( "Will not do a tail -f for processus pid $pidtotail : it is myself.\n" ) ; + return ; + } my $filetotail = secondline( $pidfile ) ; - if ( ! $filetotail ) { return ; } + if ( ! $filetotail ) + { + myprint( "Can not do a tail -f for processus pid $pidtotail : no log file in 2nd line of the pidfile $pidfile\n" ) ; + return ; + } if ( ! -r $filetotail ) { @@ -8937,12 +10301,12 @@ sub tail } return 1 ; -} +} sub isrunning { - my $pidtocheck = shift ; - my $moretimes_ref = shift ; + my $pidtocheck = shift @ARG ; + my $moretimes_ref = shift @ARG ; if ( kill 'ZERO', $pidtocheck ) { @@ -8962,39 +10326,43 @@ sub isrunning } } -sub tests_write_pidfile +sub tests_write_pidfile { note( 'Entering tests_write_pidfile()' ) ; my $mysync ; + # return status: + # 1 is okay + # undef is fatal + is( 1, write_pidfile( ), 'write_pidfile: no args => 1' ) ; # no pidfile => ok - $mysync->{pidfile} = q{} ; - is( 1, write_pidfile( $mysync ), 'write_pidfile: no pidfile => undef' ) ; + $mysync->{ pidfile } = q{} ; + is( 1, write_pidfile( $mysync ), 'write_pidfile: no pidfile => 1' ) ; # The pidfile path is bad => failure - $mysync->{pidfile} = '/no/no/no.pid' ; + $mysync->{ pidfile } = '/no/no/no.pid' ; is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid, no lock => undef' ) ; - $mysync->{pidfilelocking} = 1 ; + $mysync->{ pidfilelocking } = 1 ; is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid + lock => undef' ) ; - $mysync->{pidfile} = 'W/tmp/tests/test.pid' ; + $mysync->{ pidfile } = 'W/tmp/tests/test.pid' ; ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'write_pidfile: mkpath W/tmp/tests/' ) ; - is( 1, touch( $mysync->{pidfile} ), 'write_pidfile: lock prepa' ) ; + is( 1, touch( $mysync->{ pidfile } ), 'write_pidfile: lock prepa' ) ; - $mysync->{pidfilelocking} = 0 ; + $mysync->{ pidfilelocking } = 0 ; is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock => 1' ) ; is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains $PROCESS_ID" ) ; is( q{}, secondline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains no second line" ) ; - $mysync->{pidfilelocking} = 1 ; + $mysync->{ pidfilelocking } = 1 ; is( undef, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + lock => undef' ) ; - $mysync->{pidfilelocking} = 0 ; + $mysync->{ pidfilelocking } = 0 ; $mysync->{ logfile } = 'rrrr.txt' ; is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock + logfile => 1' ) ; is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: + no lock + logfile W/tmp/tests/test.pid contains $PROCESS_ID" ) ; @@ -9003,16 +10371,15 @@ sub tests_write_pidfile note( 'Leaving tests_write_pidfile()' ) ; return ; -} +} -sub write_pidfile +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 ; @@ -9020,7 +10387,6 @@ sub write_pidfile # 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 } ; my $lock = $mysync->{ pidfilelocking } ; @@ -9031,13 +10397,15 @@ sub write_pidfile } myprint( "PID file is $pid_filename ( to change it, use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ; - if ( -e $pid_filename and $lock ) { + if ( -e $pid_filename and $lock ) + { myprint( "$pid_filename already exists, another imapsync may be curently running. Aborting imapsync.\n" ) ; return ; } - if ( -e $pid_filename ) { + if ( -e $pid_filename ) + { myprint( "$pid_filename already exists, overwriting it ( use --pidfilelocking to avoid concurrent runs )\n" ) ; } @@ -9050,7 +10418,8 @@ sub write_pidfile $pid_message .= "Writing also my logfile name in $pid_filename : $mysync->{ logfile }\n" ; } - if ( open my $FILE_HANDLE, '>', $pid_filename ) { + if ( open my $FILE_HANDLE, '>', $pid_filename ) + { myprint( $pid_message ) ; print $FILE_HANDLE $pid_string ; close $FILE_HANDLE ; @@ -9061,62 +10430,79 @@ sub write_pidfile myprint( "Could not open $pid_filename for writing. Check permissions or disk space: $OS_ERROR\n" ) ; return ; } -} +} -sub fix_Inbox_INBOX_mapping -{ - my( $h1_all, $h2_all ) = @_ ; - - my $regex = q{} ; - SWITCH: { - if ( exists $h1_all->{INBOX} and exists $h2_all->{INBOX} ) { $regex = q{} ; last SWITCH ; } ; - if ( exists $h1_all->{Inbox} and exists $h2_all->{Inbox} ) { $regex = q{} ; last SWITCH ; } ; - if ( exists $h1_all->{INBOX} and exists $h2_all->{Inbox} ) { $regex = q{s/^INBOX$/Inbox/x} ; last SWITCH ; } ; - if ( exists $h1_all->{Inbox} and exists $h2_all->{INBOX} ) { $regex = q{s/^Inbox$/INBOX/x} ; last SWITCH ; } ; - } ; - return( $regex ) ; -} - sub tests_fix_Inbox_INBOX_mapping { note( 'Entering tests_fix_Inbox_INBOX_mapping()' ) ; - my( $h1_all, $h2_all ) ; + my( $mysync, $h1_all, $h2_all ) ; $h1_all = { 'INBOX' => q{} } ; $h2_all = { 'INBOX' => q{} } ; - ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX INBOX' ) ; + ok( q{} eq fix_Inbox_INBOX_mapping( $mysync, $h1_all, $h2_all ), 'tests_fix_Inbox_INBOX_mapping: INBOX INBOX' ) ; $h1_all = { 'Inbox' => q{} } ; $h2_all = { 'Inbox' => q{} } ; - ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox Inbox' ) ; + ok( q{} eq fix_Inbox_INBOX_mapping( $mysync, $h1_all, $h2_all ), 'tests_fix_Inbox_INBOX_mapping: Inbox Inbox' ) ; $h1_all = { 'INBOX' => q{} } ; $h2_all = { 'Inbox' => q{} } ; - ok( q{s/^INBOX$/Inbox/x} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX Inbox' ) ; + ok( q{s/^INBOX$/Inbox/x} eq fix_Inbox_INBOX_mapping( $mysync, $h1_all, $h2_all ), 'tests_fix_Inbox_INBOX_mapping: INBOX Inbox' ) ; $h1_all = { 'Inbox' => q{} } ; $h2_all = { 'INBOX' => q{} } ; - ok( q{s/^Inbox$/INBOX/x} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox INBOX' ) ; + ok( q{s/^Inbox$/INBOX/x} eq fix_Inbox_INBOX_mapping( $mysync, $h1_all, $h2_all ), 'tests_fix_Inbox_INBOX_mapping: Inbox INBOX' ) ; $h1_all = { 'INBOX' => q{} } ; $h2_all = { 'rrrrr' => q{} } ; - ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX rrrrrr' ) ; + ok( q{} eq fix_Inbox_INBOX_mapping( $mysync, $h1_all, $h2_all ), 'tests_fix_Inbox_INBOX_mapping: INBOX rrrrrr' ) ; $h1_all = { 'rrrrr' => q{} } ; $h2_all = { 'Inbox' => q{} } ; - ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: rrrrr Inbox' ) ; + ok( q{} eq fix_Inbox_INBOX_mapping( $mysync, $h1_all, $h2_all ), 'tests_fix_Inbox_INBOX_mapping: rrrrr Inbox' ) ; note( 'Leaving tests_fix_Inbox_INBOX_mapping()' ) ; return ; } +sub fix_Inbox_INBOX_mapping +{ + my( $mysync, $h1_all, $h2_all ) = @ARG ; + + myprint( "Looking at INBOX or Inbox on both sides and deciding of the mapping to apply. Use --nofixInboxINBOX to avoid this behavior.\n" ) ; + my $regex = q{} ; + SWITCH: { + if ( exists $h1_all->{INBOX} and exists $h2_all->{INBOX} ) + { + myprint( "INBOX INBOX on both sides so no mapping applied.\n" ) ; + $regex = q{} ; last SWITCH ; + } ; + if ( exists $h1_all->{Inbox} and exists $h2_all->{Inbox} ) + { + myprint( "Inbox Inbox on both sides so no mapping applied.\n" ) ; + $regex = q{} ; last SWITCH ; + } ; + if ( exists $h1_all->{INBOX} and exists $h2_all->{Inbox} ) + { + myprint( "INBOX Inbox so INBOX -> Inbox mapping applied.\n" ) ; + $regex = q{s/^INBOX$/Inbox/x} ; last SWITCH ; + } ; + if ( exists $h1_all->{Inbox} and exists $h2_all->{INBOX} ) + { + myprint( "Inbox INBOX so Inbox -> INBOX mapping applied.\n" ) ; + $regex = q{s/^Inbox$/INBOX/x} ; last SWITCH ; + } ; + } ; + return( $regex ) ; +} + sub jux_utf8_list { - my @s_inp = @_ ; + my @s_inp = @ARG ; my $s_out = q{} ; foreach my $s ( @s_inp ) { $s_out .= jux_utf8( $s ) . "\n" ; @@ -9132,7 +10518,7 @@ sub tests_jux_utf8_list is( q{}, jux_utf8_list( ), 'jux_utf8_list: void' ) ; is( "[]\n", jux_utf8_list( q{} ), 'jux_utf8_list: empty string' ) ; is( "[INBOX]\n", jux_utf8_list( 'INBOX' ), 'jux_utf8_list: INBOX' ) ; - is( "[&ANY-] = [Ö]\n", jux_utf8_list( '&ANY-' ), 'jux_utf8_list: [&ANY-] = [Ö]' ) ; + is( "[&ANY-] = [Ö]\n", jux_utf8_list( '&ANY-' ), 'jux_utf8_list: [&ANY-] = [Ö]' ) ; note( 'Leaving tests_jux_utf8_list()' ) ; return( 0 ) ; @@ -9147,11 +10533,11 @@ sub tests_jux_utf8_old is( '[]', jux_utf8_old( q{} ), 'jux_utf8_old: void => []' ) ; is( '[INBOX]', jux_utf8_old( 'INBOX'), 'jux_utf8_old: INBOX => [INBOX]' ) ; - is( '[&ZTZO9nux-] = [收件箱]', jux_utf8_old( '&ZTZO9nux-'), 'jux_utf8_old: => [&ZTZO9nux-] = [收件箱]' ) ; - is( '[&ANY-] = [Ö]', jux_utf8_old( '&ANY-'), 'jux_utf8_old: &ANY- => [&ANY-] = [Ö]' ) ; + is( '[&ZTZO9nux-] = [收件箱]', jux_utf8_old( '&ZTZO9nux-'), 'jux_utf8_old: => [&ZTZO9nux-] = [收件箱]' ) ; + is( '[&ANY-] = [Ö]', jux_utf8_old( '&ANY-'), 'jux_utf8_old: &ANY- => [&ANY-] = [Ö]' ) ; # +BD8EQAQ1BDQEOwQ+BDM- SHOULD stay as is! - is( '[+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]', jux_utf8_old( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8_old: => [+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' ) ; - is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8_old( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8_old: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ; + is( '[+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]', jux_utf8_old( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8_old: => [+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' ) ; + is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8_old( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8_old: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ; note( 'Leaving tests_jux_utf8_old()' ) ; return ; @@ -9160,7 +10546,7 @@ sub tests_jux_utf8_old sub jux_utf8_old { # juxtapose utf8 at the right if different - my ( $s_utf7 ) = shift ; + my ( $s_utf7 ) = shift @ARG ; my ( $s_utf8 ) = imap_utf7_decode_old( $s_utf7 ) ; if ( $s_utf7 eq $s_utf8 ) { @@ -9177,7 +10563,7 @@ sub jux_utf8_old # https://rt.cpan.org/Public/Bug/Display.html?id=11172 sub imap_utf7_decode_old { - my ( $s ) = shift ; + my ( $s ) = shift @ARG ; # Algorithm # On remplace , par / dans les BASE 64 (, entre & et -) @@ -9205,23 +10591,23 @@ sub tests_jux_utf8 # This test is because the binary can fail on it, a PAR.pm issue. # The failure was with the underlying Encode::IMAPUTF7 module line 66 release 1.05 # Was solved by including Encode in imapsync and using "pp -x". - ok( find_encoding( "UTF-16BE"), 'jux_utf8: Encode::find_encoding: UTF-16BE' ) ; + ok( Encode::find_encoding( "UTF-16BE"), 'jux_utf8: Encode::find_encoding: UTF-16BE' ) ; # is( '[]', jux_utf8( q{} ), 'jux_utf8: void => []' ) ; is( '[INBOX]', jux_utf8( 'INBOX'), 'jux_utf8: INBOX => [INBOX]' ) ; - is( '[&ANY-] = [Ö]', jux_utf8( '&ANY-'), 'jux_utf8: &ANY- => [&ANY-] = [Ö]' ) ; + is( '[&ANY-] = [Ö]', jux_utf8( '&ANY-'), 'jux_utf8: &ANY- => [&ANY-] = [Ö]' ) ; # +BD8EQAQ1BDQEOwQ+BDM- must stay as is is( '[+BD8EQAQ1BDQEOwQ+BDM-]', jux_utf8( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8: => [+BD8EQAQ1BDQEOwQ+BDM-] = [+BD8EQAQ1BDQEOwQ+BDM-]' ) ; - is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ; + is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ; - is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( q{R&AOk-ponses 1200+1201+1202} ), 'jux_utf8: [R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]' ) ; - my $str = Encode::IMAPUTF7::encode("IMAP-UTF-7", 'Réponses 1200+1201+1202' ) ; - is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( $str ), "jux_utf8: [$str] = [Réponses 1200+1201+1202]" ) ; + is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( q{R&AOk-ponses 1200+1201+1202} ), 'jux_utf8: [R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]' ) ; + my $str = Encode::IMAPUTF7::encode("IMAP-UTF-7", 'Réponses 1200+1201+1202' ) ; + is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( $str ), "jux_utf8: [$str] = [Réponses 1200+1201+1202]" ) ; - is( '[INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éà çù&*]', jux_utf8( 'INBOX.&AOkA4ADnAPk-&-*' ), "jux_utf8: [INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éà çù&*]" ) ; + is( '[INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éàçù&*]', jux_utf8( 'INBOX.&AOkA4ADnAPk-&-*' ), "jux_utf8: [INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éàçù&*]" ) ; - is( '[&ZTZO9nux-] = [收件箱]', jux_utf8( '&ZTZO9nux-'), 'jux_utf8: => [&ZTZO9nux-] = [收件箱]' ) ; + is( '[&ZTZO9nux-] = [收件箱]', jux_utf8( '&ZTZO9nux-'), 'jux_utf8: => [&ZTZO9nux-] = [收件箱]' ) ; # # is( '[!Old Emails]', jux_utf8( '!Old Emails'), 'jux_utf8: !Old Emails => [!Old Emails]' ) ; @@ -9234,7 +10620,7 @@ sub jux_utf8 { #use utf8 ; # juxtapose utf8 at the right if different - my ( $s_utf7 ) = shift ; + my ( $s_utf7 ) = shift @ARG ; my ( $s_utf8 ) = imap_utf7_decode( $s_utf7 ) ; if ( $s_utf7 eq $s_utf8 ) { @@ -9249,14 +10635,14 @@ sub jux_utf8 sub imap_utf7_decode { #use utf8 ; - my ( $s ) = shift ; + my ( $s ) = shift @ARG ; return( Encode::IMAPUTF7::decode("IMAP-UTF-7", $s ) ) ; } sub imap_utf7_encode { #use utf8 ; - my ( $s ) = shift ; + my ( $s ) = shift @ARG ; return( Encode::IMAPUTF7::encode("IMAP-UTF-7", $s ) ) ; } @@ -9264,7 +10650,7 @@ sub imap_utf7_encode sub imap_utf7_encode_old { - my ( $s ) = @_ ; + my ( $s ) = @ARG ; $s = Unicode::String::utf8( $s )->utf7 ; @@ -9279,7 +10665,7 @@ sub imap_utf7_encode_old sub select_folder { - my ( $mysync, $imap, $folder, $hostside ) = @_ ; + my ( $mysync, $imap, $folder, $hostside ) = @ARG ; if ( ! $imap->select( $folder ) ) { my $error = join q{}, "$hostside folder $folder: Could not select: ", @@ -9294,7 +10680,7 @@ sub select_folder sub examine_folder { - my ( $mysync, $imap, $folder, $hostside ) = @_ ; + my ( $mysync, $imap, $folder, $hostside ) = @ARG ; if ( ! $imap->examine( $folder ) ) { my $error = join q{}, "$hostside folder $folder: Could not examine: ", @@ -9335,7 +10721,7 @@ sub create_folder_old myprint( "Folder [$h2_fold] already exists\n" ) ; return( 1 ) ; } - if ( ! $mysync->{dry} ){ + if ( ! $mysync->{ dry } ){ if ( ! $imap->create( $h2_fold ) ) { my $error = join q{}, "Could not create folder [$h2_fold] from [$h1_fold]: ", @@ -9352,13 +10738,13 @@ sub create_folder_old } }else{ # dry mode, no folder so many imap will fail, assuming failure - myprint( "Created ( the old way ) folder [$h2_fold] on host2 $mysync->{dry_message}\n" ) ; + myprint( "Created ( the old way ) folder [$h2_fold] on host2 $mysync->{ dry_message }\n" ) ; return( 0 ) ; } } -sub create_folder +sub create_folder { my $mysync = shift @ARG ; my( $myimap2 , $h2_fold , $h1_fold ) = @ARG ; @@ -9369,7 +10755,8 @@ sub create_folder return( 0 ) ; } - if ( $create_folder_old ) { + if ( $mysync->{ create_folder_old } ) + { return( create_folder_old( $mysync, $myimap2 , $h2_fold , $h1_fold ) ) ; } @@ -9400,7 +10787,7 @@ sub create_folder create_folder( $mysync, $myimap2 , $parent , $h1_fold ) ; } - if ( ! $mysync->{dry} ) { + if ( ! $mysync->{ dry } ) { if ( ! $myimap2->create( $h2_fold ) ) { my $error = join q{}, "Could not create folder [$h2_fold] from [$h1_fold]: " , @@ -9420,7 +10807,7 @@ sub create_folder } }else{ # dry mode, no folder so many imap will fail, assuming failure - myprint( "Created folder [$h2_fold] on host2 $mysync->{dry_message}\n" ) ; + myprint( "Created folder [$h2_fold] on host2 $mysync->{ dry_message }\n" ) ; 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" ) ; @@ -9504,7 +10891,7 @@ sub sort_requested_folders sub is_requested_folder { - my ( $folder ) = @_; + my ( $folder ) = @ARG; return( defined $requested_folder{ $folder } ) ; } @@ -9512,7 +10899,7 @@ sub is_requested_folder sub add_to_requested_folders { - my @wanted_folders = @_ ; + my @wanted_folders = @ARG ; foreach my $folder ( @wanted_folders ) { ++$requested_folder{ $folder } ; @@ -9564,7 +10951,7 @@ sub tests_remove_from_requested_folders sub remove_from_requested_folders { - my @unwanted_folders = @_ ; + my @unwanted_folders = @ARG ; my @removed_folders = () ; foreach my $folder ( @unwanted_folders ) { @@ -9579,7 +10966,7 @@ sub remove_from_requested_folders sub compare_lists { - my ($list_1_ref, $list_2_ref) = @_; + my ($list_1_ref, $list_2_ref) = @ARG; return($MINUS_ONE) if ((not defined $list_1_ref) and defined $list_2_ref); return(0) if ((not defined $list_1_ref) and not defined $list_2_ref); # end if no list @@ -9668,7 +11055,7 @@ sub tests_compare_lists sub guess_prefix { - my @foldernames = @_ ; + my @foldernames = @ARG ; my $prefix_guessed = q{} ; foreach my $folder ( @foldernames ) { @@ -9707,7 +11094,7 @@ sub tests_guess_prefix sub get_prefix { - my( $imap, $prefix_in, $prefix_opt, $Side, $folders_ref ) = @_ ; + my( $imap, $prefix_in, $prefix_opt, $Side, $folders_ref ) = @ARG ; my( $prefix_out, $prefix_guessed ) ; ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Getting prefix\n" ) ; @@ -9743,25 +11130,25 @@ sub get_prefix } -sub guess_separator +sub guess_separator { - my @foldernames = @_ ; + my @foldernames = @ARG ; #return( undef ) unless ( @foldernames ) ; my $sep_guessed ; my %counter ; foreach my $folder ( @foldernames ) { - $counter{'/'}++ while ( $folder =~ m{/}xg ) ; # count / - $counter{'.'}++ while ( $folder =~ m{\.}xg ) ; # count . - $counter{'\\\\'}++ while ( $folder =~ m{(\\){2}}xg ) ; # count \\ - $counter{'\\'}++ while ( $folder =~ m{[^\\](\\){1}(?=[^\\])}xg ) ; # count \ + $counter{ '/' }++ while ( $folder =~ m{/}xg ) ; # count / + $counter{ '.' }++ while ( $folder =~ m{\.}xg ) ; # count . + $counter{ '\\\\' }++ while ( $folder =~ m{(\\){2}}xg ) ; # count \\ + $counter{ '\\' }++ while ( $folder =~ m{[^\\](\\){1}(?=[^\\])}xg ) ; # count \ } my @race_sorted = sort { $counter{ $b } <=> $counter{ $a } } keys %counter ; $sync->{ debug } and myprint( "@foldernames\n@race_sorted\n", %counter, "\n" ) ; $sep_guessed = shift @race_sorted || $LAST_RESSORT_SEPARATOR ; # / when nothing found. return( $sep_guessed ) ; -} +} sub tests_guess_separator { @@ -9782,7 +11169,7 @@ sub tests_guess_separator sub get_separator { - my( $imap, $sep_in, $sep_opt, $Side, $folders_ref ) = @_ ; + my( $imap, $sep_in, $sep_opt, $Side, $folders_ref ) = @ARG ; my( $sep_out, $sep_guessed ) ; ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Getting separator\n" ) ; @@ -9833,7 +11220,7 @@ sub get_separator sub help_to_guess_sep { - my( $imap, $sep_opt ) = @_ ; + my( $imap, $sep_opt ) = @ARG ; my $help_to_guess_sep = "You can set the separator character with the $sep_opt option,\n" . "the complete listing of folders may help you to find it\n" @@ -9844,7 +11231,7 @@ sub help_to_guess_sep sub help_to_guess_prefix { - my( $imap, $prefix_opt ) = @_ ; + my( $imap, $prefix_opt ) = @ARG ; my $help_to_guess_prefix = "You can set the prefix namespace with the $prefix_opt option,\n" . "the folowing listing of folders may help you to find it:\n" @@ -9856,25 +11243,25 @@ sub help_to_guess_prefix sub folders_list_to_help { - my( $imap ) = shift ; + my( $imap ) = shift @ARG ; my @folders = $imap->folders ; my $listing = join q{}, map { "[$_]\n" } @folders ; return( $listing ) ; } -# Globals are $sync @h1_folders_all @h2_folders_all $prefix1 $prefix2 +# Globals are $sync @h1_folders_all @h2_folders_all sub private_folders_separators_and_prefixes { # what are the private folders separators and prefixes for each server ? - ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Getting separators\n" ) ; - $sync->{ h1_sep } = get_separator( $sync->{imap1}, $sync->{ sep1 }, '--sep1', 'Host1', \@h1_folders_all ) ; - $sync->{ h2_sep } = get_separator( $sync->{imap2}, $sync->{ sep2 }, '--sep2', 'Host2', \@h2_folders_all ) ; + ( $sync->{ debug } or $sync->{ debugfolders } ) and myprint( "Getting separators\n" ) ; + $sync->{ h1_sep } = get_separator( $sync->{ imap1 }, $sync->{ sep1 }, '--sep1', 'Host1', \@h1_folders_all ) ; + $sync->{ h2_sep } = get_separator( $sync->{ imap2 }, $sync->{ sep2 }, '--sep2', 'Host2', \@h2_folders_all ) ; - $sync->{ h1_prefix } = get_prefix( $sync->{imap1}, $prefix1, '--prefix1', 'Host1', \@h1_folders_all ) ; - $sync->{ h2_prefix } = get_prefix( $sync->{imap2}, $prefix2, '--prefix2', 'Host2', \@h2_folders_all ) ; + $sync->{ h1_prefix } = get_prefix( $sync->{ imap1 }, $sync->{ prefix1 }, '--prefix1', 'Host1', \@h1_folders_all ) ; + $sync->{ h2_prefix } = get_prefix( $sync->{ imap2 }, $sync->{ prefix2 }, '--prefix2', 'Host2', \@h2_folders_all ) ; myprint( "Host1: separator and prefix: [$sync->{ h1_sep }][$sync->{ h1_prefix }]\n" ) ; myprint( "Host2: separator and prefix: [$sync->{ h2_sep }][$sync->{ h2_prefix }]\n" ) ; @@ -9882,9 +11269,9 @@ sub private_folders_separators_and_prefixes } -sub subfolder1 +sub subfolder1 { - my $mysync = shift ; + my $mysync = shift @ARG ; my $subfolder1 = sanitize_subfolder( $mysync->{ subfolder1 } ) ; if ( $subfolder1 ) @@ -9896,7 +11283,7 @@ sub subfolder1 $mysync->{ subfolder1 } = $subfolder1 ; if ( ! add_subfolder1_to_folderrec( $mysync ) ) { - $mysync->{nb_errors}++ ; + $mysync->{ nb_errors }++ ; exit_clean( $mysync, $EXIT_SUBFOLDER1_NO_EXISTS, "subfolder1 $subfolder1 does not exist\n" ) ; } } @@ -9906,20 +11293,26 @@ sub subfolder1 } return ; -} +} -sub subfolder2 +sub subfolder2 { - my $mysync = shift ; + my $mysync = shift @ARG ; + + my $subfolder2_option = $mysync->{ subfolder2 } ; my $subfolder2 = sanitize_subfolder( $mysync->{ subfolder2 } ) ; if ( $subfolder2 ) { # turns off automap myprint( "Turning off automapping folders because of --subfolder2\n" ) ; $mysync->{ automap } = undef ; + myprint( "Sanitizing subfolder2: [$mysync->{ subfolder2 }] => [$subfolder2]\n" ) ; $mysync->{ subfolder2 } = $subfolder2 ; + set_regextrans2_for_subfolder2( $mysync ) ; + myprint( "Excluding $subfolder2 because of --subfolder2 $subfolder2_option\n" ) ; + push @exclude, $subfolder2 ; } else { @@ -9927,7 +11320,7 @@ sub subfolder2 } return ; -} +} sub tests_sanitize_subfolder { @@ -9948,7 +11341,7 @@ sub tests_sanitize_subfolder sub sanitize_subfolder { - my $subfolder = shift ; + my $subfolder = shift @ARG ; if ( ! $subfolder ) { @@ -9990,7 +11383,7 @@ sub tests_sanitize_host sub sanitize_host { - my $host = shift ; + my $host = shift @ARG ; if ( ! defined $host ) { return ; } $host =~ tr{ /}{}d ; @@ -9998,82 +11391,299 @@ sub sanitize_host } -sub tests_add_subfolder1_to_folderrec +sub tests_separate_host_port_folder +{ + note( 'Entering tests_separate_host_port_folder()' ) ; + + is_deeply( [], [ separate_host_port_folder( ) ], 'tests_separate_host_port_folder: no args => undef' ) ; + is_deeply( [], [ separate_host_port_folder( '' ) ], 'tests_separate_host_port_folder: empty string => empty array' ) ; + is_deeply( [ 'imap.foo.kk', undef, undef ], [ separate_host_port_folder( 'imap.foo.kk' ) ], 'tests_separate_host_port_folder: imap.foo.kk => imap.foo.kk' ) ; + is_deeply( [ 'imap.foo.kk', undef, '' ], [ separate_host_port_folder( 'imap.foo.kk/' ) ], 'tests_separate_host_port_folder: imap.foo.kk/ => imap.foo.kk' ) ; + is_deeply( [ 'imap.foo.kk', '114433', undef ], [ separate_host_port_folder( 'imap.foo.kk:114433' ) ], 'tests_separate_host_port_folder: imap.foo.kk:114433 => imap.foo.kk 114433' ) ; + is_deeply( [ 'imap.foo.kk', '114433', ''], [ separate_host_port_folder( 'imap.foo.kk:114433/' ) ], 'tests_separate_host_port_folder: imap.foo.kk:114433/ => imap.foo.kk 114433' ) ; + is_deeply( [ 'imap.foo.kk', undef, 'coco' ], [ separate_host_port_folder( 'imap.foo.kk/coco' ) ], 'tests_separate_host_port_folder: imap.foo.kk/coco => imap.foo.kk undef coco' ) ; + is_deeply( [ 'imap.foo.kk', undef, 'coco/cucu/' ], [ separate_host_port_folder( 'imap.foo.kk/coco/cucu/' ) ], 'tests_separate_host_port_folder: imap.foo.kk/coco/cucu/ => imap.foo.kk undef coco/cucu/' ) ; + is_deeply( [ 'imap.foo.kk', '114433', 'coco' ], [ separate_host_port_folder( 'imap.foo.kk:114433/coco' ) ], 'tests_separate_host_port_folder: imap.foo.kk:114433/coco => imap.foo.kk 114433 coco' ) ; + is_deeply( [ 'imap.foo.kk', '114433', 'coco/cucu/' ], [ separate_host_port_folder( 'imap.foo.kk:114433/coco/cucu/' ) ], 'tests_separate_host_port_folder: imap.foo.kk:114433/coco/cucu/ => imap.foo.kk 114433 coco/cucu/' ) ; + + + is_deeply( [ 'imap.foo.kk', undef, 'co co' ], [ separate_host_port_folder( 'imap.foo.kk/co co' ) ], 'tests_separate_host_port_folder: imap.foo.kk/co co => imap.foo.kk undef co co' ) ; + is_deeply( [ 'imap.foo.kk', undef, 'co co/cucu/' ], [ separate_host_port_folder( 'imap.foo.kk/co co/cucu/' ) ], 'tests_separate_host_port_folder: imap.foo.kk/co co/cucu/ => imap.foo.kk undef co co/cucu/' ) ; + is_deeply( [ 'imap.foo.kk', '114433', 'co co' ], [ separate_host_port_folder( 'imap.foo.kk:114433/co co' ) ], 'tests_separate_host_port_folder: imap.foo.kk:114433/co co => imap.foo.kk 114433 co co' ) ; + is_deeply( [ 'imap.foo.kk', '114433', 'co co/cucu/' ], [ separate_host_port_folder( 'imap.foo.kk:114433/co co/cucu/' ) ], 'tests_separate_host_port_folder: imap.foo.kk:114433/co co/cucu/ => imap.foo.kk 114433 co co/cucu/' ) ; + + is_deeply( [ 'imap.foo.kk', undef, 'co co ' ], [ separate_host_port_folder( 'imap.foo.kk/co co ' ) ], 'tests_separate_host_port_folder: imap.foo.kk/co co => imap.foo.kk undef co co ' ) ; + is_deeply( [ 'imap.foo.kk', undef, 'co co/cucu/ ' ], [ separate_host_port_folder( 'imap.foo.kk/co co/cucu/ ' ) ], 'tests_separate_host_port_folder: imap.foo.kk/co co/cucu/ => imap.foo.kk undef co co/cucu/ ' ) ; + is_deeply( [ 'imap.foo.kk', '114433', 'co co ' ], [ separate_host_port_folder( 'imap.foo.kk:114433/co co ' ) ], 'tests_separate_host_port_folder: imap.foo.kk:114433/co co => imap.foo.kk 114433 co co ' ) ; + is_deeply( [ 'imap.foo.kk', '114433', 'co co/cucu/ ' ], [ separate_host_port_folder( 'imap.foo.kk:114433/co co/cucu/ ' ) ], 'tests_separate_host_port_folder: imap.foo.kk:114433/co co/cucu/ => imap.foo.kk 114433 co co/cucu/ ' ) ; + + + note( 'Leaving tests_separate_host_port_folder()' ) ; + return ; +} + + + + + +sub separate_host_port_folder +{ + my $hosturi = shift @ARG ; + + if ( ! $hosturi ) + { + return ; + } + + my ( $host, $port, $folder ) ; + + if ( $hosturi =~ m{\A([a-z0-9_\-.]+)(?:\:([0-9]+))?(?:\/([^\?]*))?\Z}gm ) + { + ( $host, $port, $folder ) = ( $1, $2, $3 ) ; + } + else + { + myprint( "no match host, port, folder for $hosturi\n" ) ; + } + + return( $host, $port, $folder ) ; +} + + + +sub tests_host1_port1_folderrec_from_host1 +{ + note( 'Entering tests_host1_port1_folderrec_from_host1()' ) ; + + is( undef, host1_port1_folderrec_from_host1( ), 'tests_host1_port1_folderrec_from_host1: no args => undef' ) ; + my $mysync = { } ; + is( undef, host1_port1_folderrec_from_host1( $mysync ), 'tests_host1_port1_folderrec_from_host1: { } => undef' ) ; + + $mysync->{ host1 } = '' ; + is( undef, host1_port1_folderrec_from_host1( $mysync ), 'tests_host1_port1_folderrec_from_host1: host1 empty => undef' ) ; + is( '', $mysync->{ host1 }, 'tests_host1_port1_folderrec_from_host1: host1 empty => host1 empty' ) ; + + $mysync->{ host1 } = 'imap.foo.kk' ; + is( undef, host1_port1_folderrec_from_host1( $mysync ), 'tests_host1_port1_folderrec_from_host1: host1 imap.foo.kk => undef' ) ; + is( 'imap.foo.kk', $mysync->{ host1 }, 'tests_host1_port1_folderrec_from_host1: host1 imap.foo.kk => host1 imap.foo.kk' ) ; + + $mysync->{ host1 } = 'imap.foo.kk/' ; + is( undef, host1_port1_folderrec_from_host1( $mysync ), 'tests_host1_port1_folderrec_from_host1: host1 imap.foo.kk/ => undef' ) ; + is( 'imap.foo.kk', $mysync->{ host1 }, 'tests_host1_port1_folderrec_from_host1: host1 imap.foo.kk/ => host1 imap.foo.kk' ) ; + + $mysync->{ host1 } = 'imap.foo.kk:1234' ; + is( undef, host1_port1_folderrec_from_host1( $mysync ), 'tests_host1_port1_folderrec_from_host1: host1 imap.foo.kk:1234 => undef' ) ; + is( 'imap.foo.kk', $mysync->{ host1 }, 'tests_host1_port1_folderrec_from_host1: host1 imap.foo.kk:1234 => host1 imap.foo.kk' ) ; + is( '1234', $mysync->{ port1 }, 'tests_host1_port1_folderrec_from_host1: host1 imap.foo.kk:1234 => port1 1234' ) ; + + $mysync->{ host1 } = 'imap.foo.qq:4321/' ; + is( undef, host1_port1_folderrec_from_host1( $mysync ), 'tests_host1_port1_folderrec_from_host1: host1 imap.foo.qq:4321/ => undef' ) ; + is( 'imap.foo.qq', $mysync->{ host1 }, 'tests_host1_port1_folderrec_from_host1: host1 imap.foo.qq:4321/ => host1 imap.foo.qq' ) ; + is( '4321', $mysync->{ port1 }, 'tests_host1_port1_folderrec_from_host1: host1 imap.foo.qq:4321/ => port1 4321' ) ; + + $mysync->{ host1 } = 'imap.bar.kk/prout/hoho' ; + $mysync->{ folderrec } = [ ] ; + is( undef, host1_port1_folderrec_from_host1( $mysync ), 'tests_host1_port1_folderrec_from_host1: host1 imap.bar.kk/prout/hoho => undef' ) ; + is( 'imap.bar.kk', $mysync->{ host1 }, 'tests_host1_port1_folderrec_from_host1: host1 imap.bar.kk/prout/hoho => host1 imap.bar.kk' ) ; + is_deeply( [ 'prout/hoho' ], $mysync->{ folderrec }, 'tests_host1_port1_folderrec_from_host1: host1 imap.bar.kk/prout/hoho => folderrec prout/hoho' ) ; + + $mysync->{ host1 } = 'imap.bar.qq:2345/prout.haha' ; + $mysync->{ folderrec } = [ ] ; + is( undef, host1_port1_folderrec_from_host1( $mysync ), 'tests_host1_port1_folderrec_from_host1: host1 imap.bar.qq:2345/prout.haha => undef' ) ; + is( 'imap.bar.qq', $mysync->{ host1 }, 'tests_host1_port1_folderrec_from_host1: host1 imap.bar.qq:2345/prout.haha => host1 imap.bar.qq' ) ; + is( '2345', $mysync->{ port1 }, 'tests_host1_port1_folderrec_from_host1: host1 imap.bar.qq:2345/prout.haha => port1 2345' ) ; + is_deeply( [ 'prout.haha' ], $mysync->{ folderrec }, 'tests_host1_port1_folderrec_from_host1: host1 imap.bar.qq:2345/prout.haha => folderrec prout.haha' ) ; + $mysync->{ folderrec } = [ ] ; + + note( 'Leaving tests_host1_port1_folderrec_from_host1()' ) ; + return ; +} + +sub host1_port1_folderrec_from_host1 +{ + my $mysync = shift @ARG ; + + + + my ( $host, $port, $folder ) = separate_host_port_folder( $mysync->{ host1 } ) ; + if ( $host ) + { + $mysync->{ host1 } = $host ; + } + + if ( $port ) + { + myprint( "Acting like --port1 $port\n" ) ; + $mysync->{ port1 } = $port ; + } + + if ( $folder ) + { + myprint( "Acting like --folderrec $folder\n" ) ; + push( @{ $mysync->{ folderrec } }, $folder ) ; + } + + return ; +} + + + +sub tests_host2_port2_subfolder2_from_host2 +{ + note( 'Entering tests_host2_port2_subfolder2_from_host2()' ) ; + + is( undef, host2_port2_subfolder2_from_host2( ), 'tests_host2_port2_subfolder2_from_host2: no args => undef' ) ; + my $mysync = { } ; + is( undef, host2_port2_subfolder2_from_host2( $mysync ), 'tests_host2_port2_subfolder2_from_host2: { } => undef' ) ; + + $mysync->{ host2 } = '' ; + is( undef, host2_port2_subfolder2_from_host2( $mysync ), 'tests_host2_port2_subfolder2_from_host2: host2 empty => undef' ) ; + is( '', $mysync->{ host2 }, 'tests_host2_port2_subfolder2_from_host2: host2 empty => host2 empty' ) ; + + $mysync->{ host2 } = 'imap.foo.kk' ; + is( undef, host2_port2_subfolder2_from_host2( $mysync ), 'tests_host2_port2_subfolder2_from_host2: host2 imap.foo.kk => undef' ) ; + is( 'imap.foo.kk', $mysync->{ host2 }, 'tests_host2_port2_subfolder2_from_host2: host2 imap.foo.kk => host2 imap.foo.kk' ) ; + + $mysync->{ host2 } = 'imap.foo.kk/' ; + is( undef, host2_port2_subfolder2_from_host2( $mysync ), 'tests_host2_port2_subfolder2_from_host2: host2 imap.foo.kk/ => undef' ) ; + is( 'imap.foo.kk', $mysync->{ host2 }, 'tests_host2_port2_subfolder2_from_host2: host2 imap.foo.kk/ => host2 imap.foo.kk' ) ; + + $mysync->{ host2 } = 'imap.foo.kk:1234' ; + is( undef, host2_port2_subfolder2_from_host2( $mysync ), 'tests_host2_port2_subfolder2_from_host2: host2 imap.foo.kk:1234 => undef' ) ; + is( 'imap.foo.kk', $mysync->{ host2 }, 'tests_host2_port2_subfolder2_from_host2: host2 imap.foo.kk:1234 => host2 imap.foo.kk' ) ; + is( '1234', $mysync->{ port2 }, 'tests_host2_port2_subfolder2_from_host2: host2 imap.foo.kk:1234 => port2 1234' ) ; + + $mysync->{ host2 } = 'imap.foo.qq:4321/' ; + is( undef, host2_port2_subfolder2_from_host2( $mysync ), 'tests_host2_port2_subfolder2_from_host2: host2 imap.foo.qq:4321/ => undef' ) ; + is( 'imap.foo.qq', $mysync->{ host2 }, 'tests_host2_port2_subfolder2_from_host2: host2 imap.foo.qq:4321/ => host2 imap.foo.qq' ) ; + is( '4321', $mysync->{ port2 }, 'tests_host2_port2_subfolder2_from_host2: host2 imap.foo.qq:4321/ => port2 4321' ) ; + + $mysync->{ host2 } = 'imap.bar.kk/prout/hoho' ; + is( undef, host2_port2_subfolder2_from_host2( $mysync ), 'tests_host2_port2_subfolder2_from_host2: host2 imap.bar.kk/prout/hoho => undef' ) ; + is( 'imap.bar.kk', $mysync->{ host2 }, 'tests_host2_port2_subfolder2_from_host2: host2 imap.bar.kk/prout/hoho => host2 imap.bar.kk' ) ; + is( 'prout/hoho', $mysync->{ subfolder2 }, 'tests_host2_port2_subfolder2_from_host2: host2 imap.bar.kk/prout/hoho => subfolder2 prout/hoho' ) ; + + $mysync->{ host2 } = 'imap.bar.qq:2345/prout.haha' ; + is( undef, host2_port2_subfolder2_from_host2( $mysync ), 'tests_host2_port2_subfolder2_from_host2: host2 imap.bar.qq:2345/prout.haha => undef' ) ; + is( 'imap.bar.qq', $mysync->{ host2 }, 'tests_host2_port2_subfolder2_from_host2: host2 imap.bar.qq:2345/prout.haha => host2 imap.bar.qq' ) ; + is( '2345', $mysync->{ port2 }, 'tests_host2_port2_subfolder2_from_host2: host2 imap.bar.qq:2345/prout.haha => port2 2345' ) ; + is( 'prout.haha', $mysync->{ subfolder2 }, 'tests_host2_port2_subfolder2_from_host2: host2 imap.bar.qq:2345/prout.haha => subfolder2 prout.haha' ) ; + + note( 'Leaving tests_host2_port2_subfolder2_from_host2()' ) ; + return ; +} + +sub host2_port2_subfolder2_from_host2 +{ + my $mysync = shift @ARG ; + + my ( $host, $port, $folder ) = separate_host_port_folder( $mysync->{ host2 } ) ; + if ( $host ) + { + $mysync->{ host2 } = $host ; + } + + if ( $port ) + { + myprint( "Acting like --port2 $port\n" ) ; + $mysync->{ port2 } = $port ; + } + + if ( $folder ) + { + myprint( "Acting like --subfolder2 $folder\n" ) ; + $mysync->{ subfolder2 } = $folder ; + } + + return ; +} + + + + +sub tests_add_subfolder1_to_folderrec { note( 'Entering tests_add_subfolder1_to_folderrec()' ) ; is( undef, add_subfolder1_to_folderrec( ), 'add_subfolder1_to_folderrec: undef => undef' ) ; is_deeply( [], [ add_subfolder1_to_folderrec( ) ], 'add_subfolder1_to_folderrec: no args => empty array' ) ; - @folderrec = () ; my $mysync = {} ; + $mysync->{ folderrec } = [ ] ; is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: empty => empty array' ) ; - is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: empty => empty folderrec' ) ; + is_deeply( [ ], $mysync->{ folderrec }, 'add_subfolder1_to_folderrec: empty => empty folderrec' ) ; $mysync->{ subfolder1 } = 'SUBI' ; $h1_folders_all{ 'SUBI' } = 1 ; $mysync->{ h1_prefix } = 'INBOX/' ; is_deeply( [ 'SUBI' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBI => SUBI' ) ; - is_deeply( [ 'SUBI' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBI => folderrec SUBI ' ) ; + is_deeply( [ 'SUBI' ], $mysync->{ folderrec }, 'add_subfolder1_to_folderrec: SUBI => folderrec SUBI ' ) ; - @folderrec = () ; + $mysync->{ folderrec } = [ ] ; $mysync->{ subfolder1 } = 'SUBO' ; is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO no exists => empty array' ) ; - is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO no exists => empty folderrec' ) ; + is_deeply( [ ], $mysync->{ folderrec }, 'add_subfolder1_to_folderrec: SUBO no exists => empty folderrec' ) ; $h1_folders_all{ 'INBOX/SUBO' } = 1 ; is_deeply( [ 'INBOX/SUBO' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO' ) ; - is_deeply( [ 'INBOX/SUBO' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO folderrec' ) ; - + is_deeply( [ 'INBOX/SUBO' ], $mysync->{ folderrec }, 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO folderrec' ) ; + note( 'Leaving tests_add_subfolder1_to_folderrec()' ) ; return ; -} +} -sub add_subfolder1_to_folderrec +sub add_subfolder1_to_folderrec { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! $mysync || ! $mysync->{ subfolder1 } ) { return ; } + if ( ! defined( $mysync->{ folderrec } ) ) { $mysync->{ folderrec } = [] } ; + my $subfolder1 = $mysync->{ subfolder1 } ; my $subfolder1_extended = $mysync->{ h1_prefix } . $subfolder1 ; if ( exists $h1_folders_all{ $subfolder1 } ) { myprint( qq{Acting like --folderrec "$subfolder1"\n} ) ; - push @folderrec, $subfolder1 ; + push @{ $mysync->{ folderrec } }, $subfolder1 ; } elsif ( exists $h1_folders_all{ $subfolder1_extended } ) { myprint( qq{Acting like --folderrec "$subfolder1_extended"\n} ) ; - push @folderrec, $subfolder1_extended ; + push @{ $mysync->{ folderrec } }, $subfolder1_extended ; } else { myprint( qq{Nor folder "$subfolder1" nor "$subfolder1_extended" exists on host1\n} ) ; } - return @folderrec ; -} + return @{ $mysync->{ folderrec } } ; +} -sub set_regextrans2_for_subfolder2 +sub set_regextrans2_for_subfolder2 { - my $mysync = shift ; + my $mysync = shift @ARG ; unshift @{ $mysync->{ regextrans2 } }, + # INBOX/foo/bar => INBOX/subfolder2/foo/bar + # foo/bar => subfolder2/foo/bar q(s,^$mysync->{ h2_prefix }(.*),$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }$1,), + # INBOX => INBOX/subfolder2/INBOX q(s,^INBOX$,$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }INBOX,), + # INBOX/INBOX/ => INBOX/ + # INBOX.INBOX. => INBOX. q(s,^($mysync->{ h2_prefix }){2},$mysync->{ h2_prefix },); - #myprint( "@{ $mysync->{ regextrans2 } }\n" ) ; + $mysync->{ debug } and myprint( "regextrans2: @{ $mysync->{ regextrans2 } }\n" ) ; return ; -} +} # Looks like no globals here -sub tests_imap2_folder_name +sub tests_imap2_folder_name { note( 'Entering tests_imap2_folder_name()' ) ; @@ -10181,8 +11791,8 @@ EOS $mysync->{ h2_sep } = '.'; - set_regextrans2_for_subfolder2( $mysync ) ; $mysync->{ subfolder2 } = 'S1.S2' ; + set_regextrans2_for_subfolder2( $mysync ) ; is( 'S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.F1.F2.F3' ) ; is( 'S1.S2.INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.INBOX' ) ; @@ -10256,10 +11866,28 @@ EOS is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2' ), 'imap2_folder_name: S1/S2 -> INBOX' ) ; is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/' ), 'imap2_folder_name: S1/S2/ -> INBOX' ) ; + # Mike Weaver case. + $mysync = {} ; + $mysync->{ h1_prefix } = q{} ; + $mysync->{ h2_prefix } = q{INBOX.} ; + $mysync->{ h1_sep } = '/'; + $mysync->{ h2_sep } = '.'; + $mysync->{ debug } = 1 ; + + @{ $mysync->{ regextrans2 } } = ( 's,Inbox.,,' ) ; + $mysync->{ f1f2h }{ 'Inbox' } = 'INBOX' ; + is( 'INBOX', imap2_folder_name( $mysync, 'Inbox' ), 'imap2_folder_name: Inbox -> INBOX' ) ; + is( 'INBOX.zozo', imap2_folder_name( $mysync, 'Inbox/zozo' ), 'imap2_folder_name: Inbox/zozo -> INBOX.zozo' ) ; + + $mysync->{ f1f2h }{ 'Inbox' } = 'INBOX.SUB' ; + $mysync->{ subfolder2 } = 'SUB' ; + set_regextrans2_for_subfolder2( $mysync ) ; + is( 'INBOX.SUB', imap2_folder_name( $mysync, 'Inbox' ), 'imap2_folder_name: subfolder2 SUB, Inbox -> INBOX.SUB' ) ; + is( 'INBOX.SUB.zozo', imap2_folder_name( $mysync, 'Inbox/zozo' ), 'imap2_folder_name: subfolder2 SUB, Inbox/zozo -> INBOX.SUB.zozo' ) ; note( 'Leaving tests_imap2_folder_name()' ) ; return ; -} +} # Global variables to remove: @@ -10268,8 +11896,8 @@ EOS sub imap2_folder_name { - my $mysync = shift ; - my ( $h1_fold ) = shift ; + my $mysync = shift @ARG ; + my ( $h1_fold ) = shift @ARG ; my ( $h2_fold ) ; if ( $mysync->{f1f2h}{ $h1_fold } ) { $h2_fold = $mysync->{f1f2h}{ $h1_fold } ; @@ -10322,8 +11950,8 @@ sub tests_remove_last_char_if_is sub remove_last_char_if_is { - my $string = shift ; - my $char = shift ; + my $string = shift @ARG ; + my $char = shift @ARG ; if ( ! defined $string ) { @@ -10400,10 +12028,10 @@ sub tests_prefix_seperator_invertion # Global variables to remove: -sub prefix_seperator_invertion +sub prefix_seperator_invertion { - my $mysync = shift ; - my $h1_fold = shift ; + my $mysync = shift @ARG ; + my $h1_fold = shift @ARG ; my $h2_fold ; if ( not defined $h1_fold ) { return ; } @@ -10415,9 +12043,9 @@ sub prefix_seperator_invertion # first we remove the prefix $h1_fold =~ s/^\Q$my_h1_prefix\E//x ; - ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "removed host1 prefix: [$h1_fold]\n" ) ; + ( $mysync->{ debug } or $mysync->{ debugfolders } ) and myprint( "removed host1 prefix: [$h1_fold]\n" ) ; $h2_fold = separator_invert( $mysync, $h1_fold, $my_h1_sep, $my_h2_sep ) ; - ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "inverted separators: [$h2_fold]\n" ) ; + ( $mysync->{ debug } or $mysync->{ debugfolders } ) and myprint( "inverted separators: [$h2_fold]\n" ) ; # Adding the prefix supplied by namespace or the --prefix2 option # except for INBOX or Inbox @@ -10426,9 +12054,9 @@ sub prefix_seperator_invertion $h2_fold = $my_h2_prefix . $h2_fold ; } - ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "added host2 prefix: [$h2_fold]\n" ) ; + ( $mysync->{ debug } or $mysync->{ debugfolders } ) and myprint( "added host2 prefix: [$h2_fold]\n" ) ; return( $h2_fold ) ; -} +} sub tests_separator_invert { @@ -10460,7 +12088,7 @@ sub tests_separator_invert # sub separator_invert { - my( $mysync, $h1_fold, $h1_separator, $h2_separator ) = @_ ; + my( $mysync, $h1_fold, $h1_separator, $h2_separator ) = @ARG ; return( undef ) if ( not all_defined( $mysync, $h1_fold, $h1_separator, $h2_separator ) ) ; # The separator we hope we'll never encounter: 00000000 == 0x00 @@ -10475,23 +12103,25 @@ sub separator_invert } -sub regextrans2 +sub regextrans2 { - my( $mysync, $h2_fold ) = @_ ; + my( $mysync, $h2_fold ) = @ARG ; # Transforming the folder name by the --regextrans2 option(s) - foreach my $regextrans2 ( @{ $mysync->{ regextrans2 } } ) { + foreach my $regextrans2 ( @{ $mysync->{ regextrans2 } } ) + { my $h2_fold_before = $h2_fold ; my $ret = eval "\$h2_fold =~ $regextrans2 ; 1 " ; ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "[$h2_fold_before] -> [$h2_fold] using regextrans2 [$regextrans2]\n" ) ; - if ( not ( defined $ret ) or $EVAL_ERROR ) { - $mysync->{nb_errors}++ ; + if ( not ( defined $ret ) or $EVAL_ERROR ) + { + $mysync->{ nb_errors }++ ; exit_clean( $mysync, $EX_USAGE, "error: eval regextrans2 '$regextrans2': $EVAL_ERROR\n" ) ; } } return( $h2_fold ) ; -} +} sub tests_decompose_regex @@ -10508,7 +12138,7 @@ sub tests_decompose_regex sub decompose_regex { - my $regex = shift ; + my $regex = shift @ARG ; my( $left_part, $right_part ) ; ( $left_part, $right_part ) = $regex =~ m{^s/((?:[^/]|\\/)+)/((?:[^/]|\\/)+)/}x; @@ -10518,26 +12148,28 @@ sub decompose_regex -sub tests_timenext +sub tests_timenext { note( 'Entering tests_timenext()' ) ; - is( undef, timenext( ), 'timenext: no args => undef' ) ; + is( undef, timenext( ), 'tests_timenext: no args => undef' ) ; my $mysync ; - is( undef, timenext( $mysync ), 'timenext: undef => undef' ) ; + is( undef, timenext( $mysync ), 'tests_timenext: undef => undef' ) ; $mysync = {} ; - ok( time - timenext( $mysync ) <= 1e-02, 'timenext: defined first time => ~ time' ) ; - ok( timenext( $mysync ) <= 1e-02, 'timenext: second time => less than 1e-02' ) ; - ok( timenext( $mysync ) <= 1e-02, 'timenext: third time => less than 1e-02' ) ; + ok( time - timenext( $mysync ) <= 2e-02, 'tests_timenext: defined first time => ~ time' ) ; + ok( timenext( $mysync ) <= 2e-02, 'tests_timenext: second time => less than 2e-02' ) ; + ok( timenext( $mysync ) <= 2e-02, 'tests_timenext: third time => less than 2e-02' ) ; note( 'Leaving tests_timenext()' ) ; return ; -} +} + + sub timenext { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! defined $mysync ) { @@ -10558,9 +12190,9 @@ sub tests_timesince { note( 'Entering tests_timesince()' ) ; - ok( timesince( time - 1 ) - 1 <= 1e-02, 'timesince: time - 1 => <= 1 + 1e-02' ) ; - ok( timesince( time ) <= 1e-02, 'timesince: time => <= 1e-02' ) ; - ok( timesince( ) - time <= 1e-02, 'timesince: no args => <= time + 1e-02' ) ; + ok( timesince( time - 1 ) - 1 <= 1e-02, 'tests_timesince: time - 1 => <= 1 + 1e-02' ) ; + ok( timesince( time ) <= 1e-02, 'tests_timesince: time => <= 1e-02' ) ; + ok( timesince( ) - time <= 1e-02, 'tests_timesince: no args => <= time + 1e-02' ) ; note( 'Leaving tests_timesince()' ) ; return ; } @@ -10573,7 +12205,7 @@ sub timesince my ( $timenow, $timediff ) ; $timenow = time ; $timediff = $timenow - $timeinit ; - # Often used in a division so no 0 but a nano seconde. + # Often used in a division so no 0 but a nano second. return( max( $timediff, min( 1e-09, $timediff ) ) ) ; } @@ -10584,57 +12216,57 @@ sub tests_regexflags { note( 'Entering tests_regexflags()' ) ; - 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} ) ; + my $mysync = {} ; + + ok( q{} eq regexflags( $mysync, q{} ), 'tests_regexflags, null string q{}' ) ; + ok( q{\Seen NonJunk $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{tests_regexflags, nothing to do} ) ; @{ $mysync->{ regexflag } } = ('I am BAD' ) ; - ok( not ( defined regexflags( $mysync, q{} ) ), 'regexflags, bad regex' ) ; + ok( not ( defined regexflags( $mysync, q{} ) ), 'tests_regexflags, bad regex' ) ; @{ $mysync->{ regexflag } } = ( 's/NonJunk//g' ) ; - ok( q{\Seen $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, remove NonJunk: 's/NonJunk//g'} ) ; + ok( q{\Seen $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{tests_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'} ) ; + ok( q{\Seen NonJunk } eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{tests_regexflags, remove $Spam: 's/\$Spam//g'} ) ; @{ $mysync->{ regexflag } } = ( 's/\\\\Seen//g' ) ; - ok( q{ NonJunk $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, remove \Seen: 's/\\\\\\\\Seen//g'} ) ; + ok( q{ NonJunk $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{tests_regexflags, remove \Seen: 's/\\\\\\\\Seen//g'} ) ; @{ $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 \End} eq regexflags( $mysync, q{\Seen NonJunk \Middle $Spam \End} ), q{tests_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} ) ; + q{tests_regexflags: only \word among Begin \Seen NonJunk \Middle $Spam \End1 End} ) ; @{ $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 ReB' eq regexflags( $mysync, 'ReA Keep1 REM Keep2 ReB' ), 'tests_regexflags, 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' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM REM Keep1 Keep2' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 REM REM Keep2' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM REM Keep2' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep1 ' eq regexflags( $mysync, 'REM Keep1' ), 'tests_regexflags,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' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2 ReB' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2 REM REM REM' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep2 ' eq regexflags( $mysync, 'Keep2 REM REM REM' ), 'tests_regexflags,Keep only regex' ) ; @{ $mysync->{ regexflag } } = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g}, 's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g' ) ; - 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' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2 REM' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 REM Keep2 REM' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 Keep2 REM' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep1 Keep2 Keep3 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2 REM REM Keep3 REM' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep1 ' eq regexflags( $mysync, 'REM REM Keep1 REM REM REM ' ), 'tests_regexflags,Keep only regex' ) ; + ok( 'Keep1 Keep3 ' eq regexflags( $mysync, 'RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 ' ), 'tests_regexflags,Keep only regex' ) ; @{ $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/'} ) ; + ok('REM REM REM REM REM jrdH8u' eq regexflags( $mysync, 'REM REM REM REM REM' ), q{tests_regexflags, 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 *//} ) ; + ok('REM REM REM REM REM ' eq regexflags( $mysync, 'REM REM REM REM REM jrdH8u' ), q{tests_regexflags, Remove jrdH8u s/jrdH8u *//} ) ; @{ $mysync->{ regexflag } } = ( 's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg' @@ -10642,27 +12274,27 @@ sub tests_regexflags ok( '\\Deleted \\Answered ' eq regexflags( $mysync, 'Blabla \$Junk \\Deleted machin \\Answered truc' ), - 'Keep only regex: Exchange case (Phil)' ) ; + 'tests_regexflags, Keep only regex: Exchange case (Phil)' ) ; - ok( q{} eq regexflags( $mysync, q{} ), 'Keep only regex: Exchange case, null string (Phil)' ) ; + ok( q{} eq regexflags( $mysync, q{} ), 'tests_regexflags, Keep only regex: Exchange case, null string (Phil)' ) ; ok( q{} eq regexflags( $mysync, 'Blabla $Junk machin truc' ), - 'Keep only regex: Exchange case, no accepted flags (Phil)' ) ; + 'tests_regexflags, Keep only regex: Exchange case, no accepted flags (Phil)' ) ; ok('\\Deleted \\Answered \\Draft \\Flagged ' eq regexflags( $mysync, '\\Deleted \\Answered \\Draft \\Flagged ' ), - 'Keep only regex: Exchange case (Phil)' ) ; + 'tests_regexflags, Keep only regex: Exchange case (Phil)' ) ; @{ $mysync->{ regexflag } } = ( 's/\\\\Flagged//g' ) ; is('\Deleted \Answered \Draft ', regexflags( $mysync, '\\Deleted \\Answered \\Draft \\Flagged ' ), - 'regexflags: remove \Flagged 1' ) ; + 'tests_regexflags, remove \Flagged 1' ) ; is('\\Deleted \\Answered \\Draft', regexflags( $mysync, '\\Deleted \\Flagged \\Answered \\Draft' ), - 'regexflags: remove \Flagged 2' ) ; + 'tests_regexflags, remove \Flagged 2' ) ; # I didn't understand why it gives \F # https://perldoc.perl.org/perlrebackslash.html @@ -10676,48 +12308,72 @@ sub tests_regexflags #regexflags( '\Deleted Flagged \Answered \Flagged \Draft \Flagged' ), # 'regexflags: remove \Flagged 3 mistery...' ) ; - $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 \ \\ ' ) ; + is( '\\ \ ', '\ \\ ', 'tests_regexflags, \\ \ is \ \\ ' ) ; note( 'Leaving tests_regexflags()' ) ; return ; } -sub regexflags +sub regexflags { - my $mysync = shift ; - my $flags = shift ; - + my $mysync = shift @ARG ; + my $flags = shift @ARG ; + foreach my $regexflag ( @{ $mysync->{ regexflag } } ) { my $flags_orig = $flags ; - $debugflags and myprint( "eval \$flags =~ $regexflag\n" ) ; + $mysync->{ debugflags } and myprint( "eval \$flags =~ $regexflag\n" ) ; my $ret = eval "\$flags =~ $regexflag ; 1 " ; - $debugflags and myprint( "regexflag $regexflag [$flags_orig] -> [$flags]\n" ) ; + $mysync->{ 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( $flags ) ; +} + +sub tests_filterbuggyflags +{ + note( 'Entering tests_filterbuggyflags()' ) ; + + my $mysync = {} ; + + + $mysync->{ regexflag } = [ ] ; + $mysync->{ filterbuggyflags } = 1 ; + filterbuggyflags( $mysync ) ; + + # + is( '\Deleted \Answered \Draft \Flagged ', + regexflags( $mysync, '\\Deleted \\Answered \\RECEIPTCHECKED \\Draft \\Indexed \\Flagged \\JUNK \\Junk' ), + 'tests_filterbuggyflags: remove famous /X 1' ) ; + + is( '\\Deleted \\Flagged \\Answered \\Draft', + regexflags( $mysync, '\\Deleted \\RECEIPTCHECKED \\Flagged \\Answered \\Indexed \\Draft' ), + 'tests_filterbuggyflags: remove famous /X 2' ) ; + + is( '\ ', '\\ ', 'tests_filterbuggyflags: \ is \\ ' ) ; + is( '\\ ', '\\ ', 'tests_filterbuggyflags: \\ is \\ ' ) ; + + + note( 'Leaving tests_filterbuggyflags()' ) ; + return ; + + +} + +sub buggyflagsregex +{ + # 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|\\\\JUNK|\\\\Indexed|\\\\X-EON-HAS-ATTACHMENT|\\\\UNSEEN|\\\\ATTACHED|\\\\X-HAS-ATTACH|\\\\FORWARDED|\\\\FORWARD|\\\\X-FORWARDED|\\\\\$FORWARDED|\\\\PRIORITY|\\\\READRCPT//gi' ) ; + return( @buggyflagsregex ) ; } sub filterbuggyflags { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( $mysync->{ filterbuggyflags } ) { unshift @{ $mysync->{ regexflag } }, buggyflagsregex( ) ; @@ -10730,24 +12386,24 @@ 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( undef, remove_doublequotes_if_any( ), 'tests_remove_doublequotes_if_any: no args => undef' ) ; + is( q{}, remove_doublequotes_if_any( q{} ), 'tests_remove_doublequotes_if_any: empty string => empty string' ) ; + is( q{}, remove_doublequotes_if_any( q{""} ), 'tests_remove_doublequotes_if_any: double-quotes => empty string' ) ; + is( q{}, remove_doublequotes_if_any( q{"""} ), 'tests_remove_doublequotes_if_any: double-quotes => empty string' ) ; + is( q{}, remove_doublequotes_if_any( q{"""} ), 'tests_remove_doublequotes_if_any: double-quotes => empty string' ) ; + is( q{toto}, remove_doublequotes_if_any( q{"toto"} ), 'tests_remove_doublequotes_if_any: "toto" => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{toto} ), 'tests_remove_doublequotes_if_any: toto => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{to"to} ), 'tests_remove_doublequotes_if_any: to"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{toto"} ), 'tests_remove_doublequotes_if_any: toto" => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{"toto} ), 'tests_remove_doublequotes_if_any: "toto => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{"to"to} ), 'tests_remove_doublequotes_if_any: "to"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{to"to"} ), 'tests_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' ) ; + is( q{toto}, remove_doublequotes_if_any( q{to\"to} ), 'tests_remove_doublequotes_if_any: to\"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{toto\"} ), 'tests_remove_doublequotes_if_any: toto\" => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{\"toto} ), 'tests_remove_doublequotes_if_any: \"toto => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{\"to\"to} ), 'tests_remove_doublequotes_if_any: \"to\"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{to\"to\"} ), 'tests_remove_doublequotes_if_any: to\"to" => toto' ) ; note( 'Leaving tests_remove_doublequotes_if_any()' ) ; @@ -10758,7 +12414,7 @@ sub tests_remove_doublequotes_if_any sub remove_doublequotes_if_any { - my $string = shift ; + my $string = shift @ARG ; if ( ! defined $string ) { return ; } $string =~ s/\\\"//g ; @@ -10774,11 +12430,11 @@ sub acls_sync # Standard Rights: # https://tools.ietf.org/html/rfc4314#section-2.1 - my( $mysync, $h1_fold, $h2_fold ) = @_ ; + my( $mysync, $h1_fold, $h2_fold ) = @ARG ; if ( $mysync->{ syncacls } ) { - my $h1_hash = $mysync->{imap1}->getacl($h1_fold) + 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) + 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 } ) ; @@ -10797,9 +12453,9 @@ sub acls_sync 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 ) + 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" ) ; } } @@ -10808,39 +12464,39 @@ sub acls_sync } -sub tests_permanentflags +sub tests_permanentflags { note( 'Entering tests_permanentflags()' ) ; my $mysync = { } ; ok( q{} eq permanentflags( $mysync, ' * OK [PERMANENTFLAGS (\* \Draft \Answered)] Limited' ), 'permanentflags \*' ) ; - + ok( '\Draft \Answered' eq permanentflags( $mysync, ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited' ), 'permanentflags \Draft \Answered' ) ; - + ok( '\Draft \Answered' eq permanentflags( $mysync, 'Blabla', ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited', 'Blabla' ), 'permanentflags \Draft \Answered' ) ; - + ok( q{} eq permanentflags( $mysync, 'Blabla' ), 'permanentflags nothing' ) ; note( 'Leaving tests_permanentflags()' ) ; return ; } -sub permanentflags +sub permanentflags { - my $mysync = shift ; + my $mysync = shift @ARG ; + + my @lines = @ARG ; - my @lines = @_ ; - - foreach my $line (@lines) { + foreach my $line ( @lines ) { if ( $line =~ m{\[PERMANENTFLAGS\s\(([^)]+?)\)\]}x ) { - ( $debugflags or $sync->{ debug } ) and myprint( "permanentflags: $line" ) ; + ( $mysync->{ debugflags } or $mysync->{ debug } ) and myprint( "permanentflags: $line" ) ; my $permanentflags = $1 ; if ( $permanentflags =~ m{\\\*}x ) { @@ -10850,7 +12506,7 @@ sub permanentflags } ; } return( q{} ) ; -} +} sub tests_flags_filter { @@ -10871,7 +12527,7 @@ sub tests_flags_filter sub flags_filter { - my( $flags, $allowed_flags ) = @_ ; + my( $flags, $allowed_flags ) = @ARG ; my @flags = split /\s+/x, $flags ; my %allowed_flags = map { $_ => 1 } split q{ }, $allowed_flags ; @@ -10901,7 +12557,7 @@ sub tests_flagscase sub flagscase { - my $flags = shift ; + my $flags = shift @ARG ; my @flags = split /\s+/x, $flags ; my %rfc_flags = map { $_ => 1 } split q{ }, '\Answered \Flagged \Deleted \Seen \Draft' ; @@ -10919,37 +12575,37 @@ 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 ; } @@ -10959,30 +12615,30 @@ sub tests_flags_for_host2 sub flags_for_host2 { - my $mysync = shift ; - my $h1_flags = shift ; - my $permanentflags2 = shift ; - - if ( ! all_defined( $mysync, $h1_flags ) ) { return ; } ; - + my $mysync = shift @ARG ; + my $h1_flags = shift @ARG ; + my $permanentflags2 = shift @ARG ; + + 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 ) ; } @@ -10990,7 +12646,7 @@ sub flags_for_host2 sub ucsecond { - my $string = shift ; + my $string = shift @ARG ; my $output ; return( $string ) if ( 1 >= length $string ) ; @@ -11021,21 +12677,21 @@ sub tests_ucsecond sub select_msgs { - my ( $imap, $msgs_all_hash_ref, $search_cmd, $abletosearch, $folder ) = @_ ; + my ( $mysync, $imap, $msgs_all_hash_ref, $search_cmd, $abletosearch, $folder ) = @ARG ; my ( @msgs ) ; if ( $abletosearch ) { - @msgs = select_msgs_by_search( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; + @msgs = select_msgs_by_search( $mysync, $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; }else{ - @msgs = select_msgs_by_fetch( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; + @msgs = select_msgs_by_fetch( $mysync, $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; } return( @msgs ) ; } -sub select_msgs_by_search -{ - my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ; +sub select_msgs_by_search +{ + my ( $mysync, $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @ARG ; my ( @msgs, @msgs_all ) ; # Need to have the whole list in msgs_all_hash_ref @@ -11043,11 +12699,10 @@ sub select_msgs_by_search # Need all messages list to avoid deleting useful cache part # in case of --search or --minage or --maxage - if ( ( defined $msgs_all_hash_ref and $usecache ) - or ( not defined $maxage and not defined $minage and not defined $search_cmd ) - ) { - - $debugdev and myprint( "Calling messages()\n" ) ; + if ( ( defined $msgs_all_hash_ref and $mysync->{ usecache } ) + or ( not defined $mysync->{ maxage } and not defined $mysync->{ minage } and not defined $search_cmd ) + ) + { @msgs_all = $imap->messages( ) ; return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ; @@ -11056,25 +12711,48 @@ sub select_msgs_by_search @{ $msgs_all_hash_ref }{ @msgs_all } = () ; } # return all messages - if ( not defined $maxage and not defined $minage and not defined $search_cmd ) { + if ( not defined $mysync->{ maxage } and not defined $mysync->{ minage } and not defined $search_cmd ) { return( @msgs_all ) ; } } - if ( defined $search_cmd ) { - @msgs = $imap->search( $search_cmd ) ; + if ( defined( $search_cmd ) ) + { + #@msgs = $imap->search( $search_cmd ) ; + @msgs = select_msgs_by_search_cmd( $mysync, $imap, $search_cmd ) ; return( @msgs ) ; } - # we are here only if $maxage or $minage is defined - @msgs = select_msgs_by_age( $imap ) ; + # we are here only if $mysync->{ maxage } or $mysync->{ minage } is defined + @msgs = select_msgs_by_age( $mysync, $imap ) ; return( @msgs ); +} + + + + + +sub select_msgs_by_search_cmd +{ + my ( $mysync, $imap, $search_cmd ) = @ARG ; + my ( @msgs ) ; + + @msgs = $imap->search( $search_cmd ) ; + if ( $@ ) + { + # Error + errors_incr( $mysync, "$@\n" ) ; + return ; + } + else + { + return( @msgs ) ; + } } - sub select_msgs_by_fetch -{ - my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ; +{ + my ( $mysync, $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @ARG ; my ( @msgs, @msgs_all, %fetch ) ; # Need to have the whole list in msgs_all_hash_ref @@ -11082,13 +12760,10 @@ sub select_msgs_by_fetch # Need all messages list to avoid deleting useful cache part # in case of --search or --minage or --maxage - - $debugdev and myprint( "Calling fetch_hash()\n" ) ; - my $fetch_hash_uids = $fetch_hash_set || "1:*" ; + my $fetch_hash_uids = $mysync->{ fetch_hash_set } || "1:*" ; %fetch = %{$imap->fetch_hash( $fetch_hash_uids, 'INTERNALDATE' ) } ; @msgs_all = sort { $a <=> $b } keys %fetch ; - $debugdev and myprint( "Done fetch_hash()\n" ) ; return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ; @@ -11096,78 +12771,79 @@ sub select_msgs_by_fetch @{ $msgs_all_hash_ref }{ @msgs_all } = () ; } # return all messages - if ( not defined $maxage and not defined $minage and not defined $search_cmd ) { + if ( not defined $mysync->{ maxage } and not defined $mysync->{ minage } and not defined $search_cmd ) { return( @msgs_all ) ; } if ( defined $search_cmd ) { myprint( "Warning: strange to see --search with --noabletosearch, an error can happen\n" ) ; - @msgs = $imap->search( $search_cmd ) ; + @msgs = select_msgs_by_search_cmd( $mysync, $imap, $search_cmd ) ; return( @msgs ) ; } # we are here only if $maxage or $minage is defined my( @max, @min, $maxage_epoch, $minage_epoch ) ; - if ( defined $maxage ) { $maxage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ; } - if ( defined $minage ) { $minage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ; } + if ( defined $mysync->{ maxage } ) { $maxage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $mysync->{ maxage } ; } + if ( defined $mysync->{ minage } ) { $minage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $mysync->{ minage } ; } foreach my $msg ( @msgs_all ) { my $idate = $fetch{ $msg }->{'INTERNALDATE'} ; #myprint( "$idate\n" ) ; - if ( defined $maxage and ( epoch( $idate ) >= $maxage_epoch ) ) { + if ( defined $mysync->{ maxage } and ( epoch( $idate ) >= $maxage_epoch ) ) { push @max, $msg ; } - if ( defined $minage and ( epoch( $idate ) <= $minage_epoch ) ) { - push @min, $msg ; + if ( defined $mysync->{ minage } and ( epoch( $idate ) <= $minage_epoch ) ) { + push @min, $msg ; } } - @msgs = msgs_from_maxmin( \@max, \@min ) ; + @msgs = msgs_from_maxmin( $mysync, \@max, \@min ) ; return( @msgs ) ; } -sub select_msgs_by_age +sub select_msgs_by_age { - my( $imap ) = @_ ; + my( $mysync, $imap ) = @ARG ; my( @max, @min, @msgs, @inter, @union ) ; - if ( defined $maxage ) { - @max = $imap->sentsince( $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ) ; + if ( defined $mysync->{ maxage } ) + { + @max = $imap->sentsince( $timestart_int - $NB_SECONDS_IN_A_DAY * $mysync->{ maxage } ) ; } - if ( defined $minage ) { - @min = $imap->sentbefore( $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ) ; + if ( defined $mysync->{ minage } ) + { + @min = $imap->sentbefore( $timestart_int - $NB_SECONDS_IN_A_DAY * $mysync->{ minage } ) ; } - @msgs = msgs_from_maxmin( \@max, \@min ) ; + @msgs = msgs_from_maxmin( $mysync, \@max, \@min ) ; return( @msgs ) ; -} +} -sub msgs_from_maxmin +sub msgs_from_maxmin { - my( $max_ref, $min_ref ) = @_ ; + my( $mysync, $max_ref, $min_ref ) = @ARG ; my( @max, @min, @msgs, @inter, @union ) ; @max = @{ $max_ref } ; @min = @{ $min_ref } ; SWITCH: { - if ( not ( defined $minage or defined $maxage ) ) + if ( not ( defined $mysync->{ minage } or defined $mysync->{ maxage } ) ) { return ; } - unless( defined $minage ) { @msgs = @max ; last SWITCH } ; - unless( defined $maxage ) { @msgs = @min ; last SWITCH } ; + unless( defined $mysync->{ minage } ) { @msgs = @max ; last SWITCH } ; + unless( defined $mysync->{ maxage } ) { @msgs = @min ; last SWITCH } ; my ( %union, %inter ) ; foreach my $m ( @min, @max ) { $union{ $m }++ && $inter{ $m }++ } @inter = sort { $a <=> $b } keys %inter ; @union = sort { $a <=> $b } keys %union ; # normal case - if ( $minage <= $maxage ) { @msgs = @inter ; last SWITCH } ; + if ( $mysync->{ minage } <= $mysync->{ maxage } ) { @msgs = @inter ; last SWITCH } ; # just exclude messages between - if ( $minage > $maxage ) { @msgs = @union ; last SWITCH } ; - + if ( $mysync->{ minage } > $mysync->{ maxage } ) { @msgs = @union ; last SWITCH } ; } return( @msgs ) ; -} +} sub tests_msgs_from_maxmin { @@ -11176,32 +12852,32 @@ sub tests_msgs_from_maxmin my @msgs ; + my $mysync = { } ; # no maxage nor minage - @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; + @msgs = msgs_from_maxmin( $mysync, [ '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' ] ) ; + $mysync->{ maxage } = $NUMBER_200 ; + @msgs = msgs_from_maxmin( $mysync, [ '1', '2' ], [ '2', '3' ] ) ; is_deeply( [ '1', '2' ], \@msgs , 'msgs_from_maxmin: maxage++' ) ; # maxage > minage -> intersection - $minage = $NUMBER_100 ; - @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; + $mysync->{ minage } = $NUMBER_100 ; + @msgs = msgs_from_maxmin( $mysync, [ '1', '2' ], [ '2', '3' ] ) ; is_deeply( [ '2' ], \@msgs , 'msgs_from_maxmin: -maxage++minage-' ) ; # maxage < minage -> union - $minage = $NUMBER_300 ; - @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; + $mysync->{ minage } = $NUMBER_300 ; + @msgs = msgs_from_maxmin( $mysync, [ '1', '2' ], [ '2', '3' ] ) ; is_deeply( [ '1', '2', '3' ], \@msgs, 'msgs_from_maxmin: ++maxage-minage++' ) ; # minage alone - $maxage = undef ; - @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; + $mysync->{ maxage } = undef ; + @msgs = msgs_from_maxmin( $mysync, [ '1', '2' ], [ '2', '3' ] ) ; is_deeply( [ '2', '3' ], \@msgs, 'msgs_from_maxmin: ++minage-' ) ; - note( 'Leaving tests_msgs_from_maxmin()' ) ; return ; } @@ -11225,11 +12901,11 @@ sub info_date_from_uid } -sub lastuid +sub lastuid { - my $imap = shift ; - my $folder = shift ; - my $lastuid_guess = shift ; + my $imap = shift @ARG ; + my $folder = shift @ARG ; + my $lastuid_guess = shift @ARG ; my $lastuid ; # rfc3501: The only reliable way to identify recent messages is to @@ -11246,55 +12922,70 @@ sub lastuid my $max_recent ; $max_recent = max( @recent_messages ) ; - if ( defined $max_recent and ($lastuid_guess <= $max_recent ) ) { + if ( defined $max_recent and ( $lastuid_guess <= $max_recent ) ) + { $lastuid = $max_recent ; - }else{ + } + else + { $lastuid = $lastuid_guess } return( $lastuid ) ; -} +} -sub size_filtered +sub size_filtered { - my( $h1_size, $h1_msg, $h1_fold, $h2_fold ) = @_ ; + my( $mysync, $h1_size, $h1_msg, $h1_fold, $h2_fold ) = @ARG ; $h1_size = 0 if ( ! $h1_size ) ; # null if empty or undef - if ( defined $sync->{ maxsize } and $h1_size > $sync->{ maxsize } ) { - myprint( "msg $h1_fold/$h1_msg skipped ($h1_size exceeds maxsize limit $sync->{ maxsize } bytes)\n" ) ; - $sync->{ total_bytes_skipped } += $h1_size; - $sync->{ nb_msg_skipped } += 1; + if ( defined $mysync->{ maxsize } and $h1_size > $mysync->{ maxsize } ) + { + myprint( "msg $h1_fold/$h1_msg skipped ($h1_size exceeds maxsize limit $mysync->{ maxsize } bytes)\n" ) ; + $mysync->{ total_bytes_skipped } += $h1_size; + $mysync->{ nb_msg_skipped } += 1; return( 1 ) ; } - if ( defined $minsize and $h1_size <= $minsize ) { - myprint( "msg $h1_fold/$h1_msg skipped ($h1_size smaller than minsize $minsize bytes)\n" ) ; - $sync->{ total_bytes_skipped } += $h1_size; - $sync->{ nb_msg_skipped } += 1; + if ( defined $mysync->{ minsize } and $h1_size <= $mysync->{ minsize } ) + { + myprint( "msg $h1_fold/$h1_msg skipped ($h1_size smaller than minsize $mysync->{ minsize } bytes)\n" ) ; + $mysync->{ total_bytes_skipped } += $h1_size; + $mysync->{ nb_msg_skipped } += 1; return( 1 ) ; } return( 0 ) ; -} +} -sub message_exists +sub message_exists_on_host1 { - my( $imap, $msg ) = @_ ; - return( 1 ) if not $imap->Uid( ) ; + my( $mysync, $msg, $folder ) = @ARG ; + + if ( not $mysync->{ imap1 }->Uid( ) ) + { + return( 1 ) ; + } + my $search_uid ; - ( $search_uid ) = $imap->search( "UID $msg" ) ; - #myprint( "$search ? $msg\n" ) ; - return( 1 ) if ( $search_uid eq $msg ) ; - return( 0 ) ; + ( $search_uid ) = $mysync->{ imap1 }->search( "UID $msg" ) ; + + if ( $search_uid eq $msg ) + { + $mysync->{ debug } and myprint( "msg $folder/$msg exists on host1\n" ) ; + return( 1 ) ; + } + else + { + myprint( "msg $folder/$msg does not exist on host1\n" ) ; + return( 0 ) ; + } } -# Globals -# $sync->{ total_bytes_skipped } -# $sync->{ nb_msg_skipped } -# $mysync->{ h1_nb_msg_processed } + sub stats_update_skip_message { - my $mysync = shift ; # to be used - my $h1_size = shift ; + my $mysync = shift @ARG ; # to be used + my $h1_size = shift @ARG ; $mysync->{ total_bytes_skipped } += $h1_size ; $mysync->{ nb_msg_skipped } += 1 ; @@ -11302,18 +12993,18 @@ sub stats_update_skip_message return ; } -sub copy_message +sub copy_message { # copy - my ( $mysync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) = @_ ; - ( $mysync->{ debug } or $mysync->{dry} ) - and myprint( "msg $h1_fold/$h1_msg copying to $h2_fold $mysync->{dry_message} " . eta( $mysync ) . "\n" ) ; + my ( $mysync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $cache_dir ) = @ARG ; + ( $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 ; + $mysync->{ nb_msg_skipped_dry_mode } += 1 ; return ; } @@ -11322,7 +13013,7 @@ sub copy_message my $h1_idate = $h1_fir_ref->{$h1_msg}->{'INTERNALDATE'} || q{} ; - if ( size_filtered( $h1_size, $h1_msg, $h1_fold, $h2_fold ) ) { + if ( size_filtered( $mysync, $h1_size, $h1_msg, $h1_fold, $h2_fold ) ) { $mysync->{ h1_nb_msg_processed } +=1 ; return ; } @@ -11330,16 +13021,17 @@ sub copy_message debugsleep( $mysync ) ; myprint( "- msg $h1_fold/$h1_msg S[$h1_size] F[$h1_flags] I[$h1_idate] has RFC822.SIZE null!\n" ) if ( ! $h1_size ) ; - if ( $checkmessageexists and not message_exists( $mysync->{imap1}, $h1_msg ) ) { + if ( $mysync->{ checkmessageexists } and not message_exists_on_host1( $mysync, $h1_msg, $h1_fold ) ) + { stats_update_skip_message( $mysync, $h1_size ) ; return ; } - myprint( debugmemory( $mysync, " at C1" ) ) ; + myprint( debugmemory( $mysync, " at sub copy_message 1" ) ) ; my ( $string, $string_len ) ; ( $string_len ) = message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, \$string ) ; - myprint( debugmemory( $mysync, " at C2" ) ) ; + myprint( debugmemory( $mysync, " at sub copy_message 2" ) ) ; # not defined or empty $string if ( ( not $string ) or ( not $string_len ) ) { @@ -11349,7 +13041,8 @@ sub copy_message } # Lines too long (or not enough) => do no copy or fix - if ( ( defined $maxlinelength ) or ( defined $minmaxlinelength ) ) { + if ( defined $maxlinelength ) + { $string = linelengthstuff( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) ; if ( not defined $string ) { stats_update_skip_message( $mysync, $h1_size ) ; @@ -11357,14 +13050,14 @@ sub copy_message } } - my $h1_date = date_for_host2( $h1_msg, $h1_idate ) ; + my $h1_date = date_for_host2( $mysync, $h1_msg, $h1_idate ) ; - ( $mysync->{ debug } or $debugflags ) and + ( $mysync->{ debug } or $mysync->{ 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( $mysync, $h1_flags, $permanentflags2 ) ; + $h1_flags = flags_for_host2( $mysync, $h1_flags, $mysync->{ permanentflags2 } ) ; - ( $mysync->{ debug } or $debugflags ) and + ( $mysync->{ debug } or $mysync->{ debugflags } ) and myprint( "Host1: flags filt msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ; $h1_date = undef if ( $h1_date eq q{} ) ; @@ -11373,43 +13066,26 @@ sub copy_message - if ( $new_id and $syncflagsaftercopy ) { - sync_flags_after_copy( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $new_id, $permanentflags2 ) ; + if ( $new_id and $mysync->{ syncflagsaftercopy } ) + { + syncflagsaftercopy( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $new_id ) ; } - myprint( debugmemory( $mysync, " at C3" ) ) ; + myprint( debugmemory( $mysync, " at sub copy_message 3" ) ) ; return $new_id ; -} +} -sub linelengthstuff +sub linelengthstuff { - my( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) = @_ ; + my( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) = @ARG ; my $maxlinelength_string = max_line_length( $string ) ; $debugmaxlinelength and myprint( "msg $h1_fold/$h1_msg maxlinelength: $maxlinelength_string\n" ) ; - if ( ( defined $minmaxlinelength ) and ( $maxlinelength_string <= $minmaxlinelength ) ) { - my $subject = subject( $string ) ; - $debugdev and myprint( "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] " - . "(Subject:[$subject]) (max line length under minmaxlinelength $minmaxlinelength bytes)\n" ) ; - return ; - } - if ( ( defined $maxlinelength ) and ( $maxlinelength_string > $maxlinelength ) ) { my $subject = subject( $string ) ; - if ( $maxlinelengthcmd ) { - $string = pipemess( $string, $maxlinelengthcmd ) ; - # string undef means something was bad. - if ( not ( defined $string ) ) { - myprint( "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] " - . "(Subject:[$subject]) could not be successfully transformed by --maxlinelengthcmd option\n" ) ; - return ; - }else{ - return $string ; - } - } myprint( "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] " . "(Subject:[$subject]) (line length exceeds maxlinelength $maxlinelength bytes)\n" ) ; return ; @@ -11425,8 +13101,6 @@ sub message_for_host2 # @skipmess # @regexmess # @pipemess -# $debugcontent -# $debug # # API current # @@ -11440,7 +13114,7 @@ sub message_for_host2 # API future # # - my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) = @_ ; + my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) = @ARG ; # abort when missing a parameter if ( ( ! $mysync ) or ( ! $h1_msg ) or ( ! $h1_fold ) or ( ! defined $h1_size ) @@ -11450,12 +13124,12 @@ sub message_for_host2 return ; } - myprint( debugmemory( $mysync, " at M1" ) ) ; + myprint( debugmemory( $mysync, " at sub message_for_host2 M1" ) ) ; - my $string_ok = $mysync->{imap1}->message_to_file( $string_ref, $h1_msg ) ; + my $string_ok = $mysync->{ imap1 }->message_to_file( $string_ref, $h1_msg ) ; - myprint( debugmemory( $mysync, " at M2" ) ) ; + myprint( debugmemory( $mysync, " at sub message_for_host2 M2" ) ) ; my $string_len = length_ref( $string_ref ) ; @@ -11464,7 +13138,7 @@ sub message_for_host2 # undef or 0 length my $error = join q{}, "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] could not be fetched: ", - $mysync->{imap1}->LastError || q{}, "\n" ; + $mysync->{ imap1 }->LastError || q{}, "\n" ; errors_incr( $mysync, $error ) ; $mysync->{ h1_nb_msg_processed } +=1 ; return ; @@ -11524,7 +13198,7 @@ sub message_for_host2 $mysync->{ debugcontent } and myprint( debugcontent( $mysync, $string_ref ) ) ; - myprint( debugmemory( $mysync, " at M3" ) ) ; + myprint( debugmemory( $mysync, " at sub message_for_host2 M3" ) ) ; return $string_len ; } @@ -11554,20 +13228,20 @@ sub debugcontent { my $mysync = shift @ARG ; if ( ! defined $mysync ) { return ; } - + my $string_ref = shift @ARG ; if ( ! defined $string_ref ) { return ; } if ( 'SCALAR' ne ref( $string_ref ) ) { return ; } - + my $string_len = length_ref( $string_ref ) ; - + my $string = join( '', q{=} x $STD_CHAR_PER_LINE, "\n", "F message content begin next line ($string_len characters long)\n", ${ $string_ref }, "\nF message content ended on previous line\n", q{=} x $STD_CHAR_PER_LINE, "\n", ) ; - + return $string ; } @@ -11592,8 +13266,8 @@ sub tests_truncmess sub truncmess { - my $string = shift ; - my $length = shift ; + my $string = shift @ARG ; + my $length = shift @ARG ; if ( not defined $string ) { return ; } if ( not defined $length ) { return $string ; } @@ -11614,7 +13288,7 @@ sub tests_message_for_host2 require_ok( "Test::MockObject" ) ; my $imapT = Test::MockObject->new( ) ; - $mysync->{imap1} = $imapT ; + $mysync->{ imap1 } = $imapT ; my $string ; $h1_msg = 1 ; @@ -11626,7 +13300,7 @@ sub tests_message_for_host2 $string_ref = \$string ; $imapT->mock( 'message_to_file', sub { - my ( $imap, $mystring_ref, $msg ) = @_ ; + my ( $imap, $mystring_ref, $msg ) = @ARG ; ${$mystring_ref} = 'blablabla' ; return length ${$mystring_ref} ; } @@ -11672,63 +13346,68 @@ sub tests_message_for_host2 is( undef, $string, q{message_for_host2: --pipemess 'true', value} ) ; } + undef @pipemess ; note( 'Leaving tests_message_for_host2()' ) ; return ; } -sub tests_labels_remove_subfolder1 -{ +sub tests_labels_remove_subfolder1 +{ note( 'Entering tests_labels_remove_subfolder1()' ) ; is( undef, labels_remove_subfolder1( ), 'labels_remove_subfolder1: no parameters => undef' ) ; - is( 'Blabla', labels_remove_subfolder1( 'Blabla' ), 'labels_remove_subfolder1: one parameter Blabla => Blabla' ) ; - is( 'Blan blue', labels_remove_subfolder1( 'Blan blue' ), 'labels_remove_subfolder1: one parameter Blan blue => Blan blue' ) ; - is( '\Bla "Blan blan" Blabla', labels_remove_subfolder1( '\Bla "Blan blan" Blabla' ), + + my $mysync = { } ; + is( 'Blabla', labels_remove_subfolder1( $mysync, 'Blabla' ), 'labels_remove_subfolder1: one parameter Blabla => Blabla' ) ; + is( 'Blan blue', labels_remove_subfolder1( $mysync, 'Blan blue' ), 'labels_remove_subfolder1: one parameter Blan blue => Blan blue' ) ; + is( '\Bla "Blan blan" Blabla', labels_remove_subfolder1( $mysync, '\Bla "Blan blan" Blabla' ), 'labels_remove_subfolder1: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ; - is( 'Bla', labels_remove_subfolder1( 'Subf/Bla', 'Subf' ), 'labels_remove_subfolder1: Subf/Bla Subf => "Bla"' ) ; + is( 'Bla', labels_remove_subfolder1( $mysync, 'Subf/Bla', 'Subf' ), 'labels_remove_subfolder1: Subf/Bla Subf => "Bla"' ) ; - is( '"\\\\Bla"', labels_remove_subfolder1( '"\\\\Bla"', 'Subf' ), 'labels_remove_subfolder1: "\\\\Bla" Subf => "\\\\Bla"' ) ; + is( '"\\\\Bla"', labels_remove_subfolder1( $mysync, '"\\\\Bla"', 'Subf' ), 'labels_remove_subfolder1: "\\\\Bla" Subf => "\\\\Bla"' ) ; - is( 'Bla Kii', labels_remove_subfolder1( 'Subf/Bla Subf/Kii', 'Subf' ), + is( 'Bla Kii', labels_remove_subfolder1( $mysync, 'Subf/Bla Subf/Kii', 'Subf' ), 'labels_remove_subfolder1: Subf/Bla Subf/Kii, Subf => "Bla" "Kii"' ) ; - is( '"\\\\Bla" Kii', labels_remove_subfolder1( '"\\\\Bla" Subf/Kii', 'Subf' ), + is( '"\\\\Bla" Kii', labels_remove_subfolder1( $mysync, '"\\\\Bla" Subf/Kii', 'Subf' ), 'labels_remove_subfolder1: "\\\\Bla" Subf/Kii Subf => "\\\\Bla" Kii' ) ; - is( '"Blan blan"', labels_remove_subfolder1( '"Subf/Blan blan"', 'Subf' ), + is( '"Blan blan"', labels_remove_subfolder1( $mysync, '"Subf/Blan blan"', 'Subf' ), 'labels_remove_subfolder1: "Subf/Blan blan" Subf => "Blan blan"' ) ; - is( '"\\\\Loo" "Blan blan" Kii', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii', 'Subf' ), + is( '"\\\\Loo" "Blan blan" Kii', labels_remove_subfolder1( $mysync, '"\\\\Loo" "Subf/Blan blan" Subf/Kii', 'Subf' ), 'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii + Subf => "\\\\Loo" "Blan blan" Kii' ) ; - is( '"\\\\Inbox"', labels_remove_subfolder1( 'Subf/INBOX', 'Subf' ), + is( '"\\\\Inbox"', labels_remove_subfolder1( $mysync, 'Subf/INBOX', 'Subf' ), 'labels_remove_subfolder1: Subf/INBOX + Subf => "\\\\Inbox"' ) ; - is( '"\\\\Loo" "Blan blan" Kii "\\\\Inbox"', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX', 'Subf' ), + is( '"\\\\Loo" "Blan blan" Kii "\\\\Inbox"', labels_remove_subfolder1( $mysync, '"\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX', 'Subf' ), 'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX + Subf => "\\\\Loo" "Blan blan" Kii "\\\\Inbox"' ) ; - note( 'Leaving tests_labels_remove_subfolder1()' ) ; return ; -} +} -sub labels_remove_subfolder1 -{ - my $labels = shift ; - my $subfolder1 = shift ; +sub labels_remove_subfolder1 +{ + my $mysync = shift @ARG ; + my $labels = shift @ARG ; + my $subfolder1 = shift @ARG ; + if ( not defined $mysync ) { return ; } if ( not defined $labels ) { return ; } if ( not defined $subfolder1 ) { return $labels ; } my @labels = quotewords('\s+', 1, $labels ) ; - #myprint( "@labels\n" ) ; + $mysync->{ debuglabels } and myprint( "In labels_remove_subfolder1 labels: @labels\n" ) ; my @labels_subfolder2 ; foreach my $label ( @labels ) { + # WTF is this zzzzzzzzzz test? if ( $label =~ m{zzzzzzzzzz} ) { # \Seen \Deleted ... stay the same @@ -11761,33 +13440,37 @@ sub labels_remove_subfolder1 my $labels_subfolder2 = join( ' ', sort uniq( @labels_subfolder2 ) ) ; return $labels_subfolder2 ; -} +} -sub tests_labels_remove_special -{ +sub tests_labels_remove_special +{ note( 'Entering tests_labels_remove_special()' ) ; is( undef, labels_remove_special( ), 'labels_remove_special: no parameters => undef' ) ; - is( q{}, labels_remove_special( q{} ), 'labels_remove_special: empty string => empty string' ) ; - is( q{}, labels_remove_special( '"\\\\Inbox"' ), 'labels_remove_special:"\\\\Inbox" => empty string' ) ; - is( q{}, labels_remove_special( '"\\\\Inbox" "\\\\Starred"' ), 'labels_remove_special:"\\\\Inbox" "\\\\Starred" => empty string' ) ; - is( 'Bar Foo', labels_remove_special( 'Foo Bar' ), 'labels_remove_special:Foo Bar => Bar Foo' ) ; - is( 'Bar Foo', labels_remove_special( 'Foo Bar "\\\\Inbox"' ), 'labels_remove_special:Foo Bar "\\\\Inbox" => Bar Foo' ) ; + + my $mysync = { } ; + is( q{}, labels_remove_special( $mysync, q{} ), 'labels_remove_special: empty string => empty string' ) ; + is( q{}, labels_remove_special( $mysync, '"\\\\Inbox"' ), 'labels_remove_special:"\\\\Inbox" => empty string' ) ; + is( q{}, labels_remove_special( $mysync, '"\\\\Inbox" "\\\\Starred"' ), 'labels_remove_special:"\\\\Inbox" "\\\\Starred" => empty string' ) ; + is( 'Bar Foo', labels_remove_special( $mysync, 'Foo Bar' ), 'labels_remove_special:Foo Bar => Bar Foo' ) ; + is( 'Bar Foo', labels_remove_special( $mysync, 'Foo Bar "\\\\Inbox"' ), 'labels_remove_special:Foo Bar "\\\\Inbox" => Bar Foo' ) ; note( 'Leaving tests_labels_remove_special()' ) ; return ; -} +} -sub labels_remove_special -{ - my $labels = shift ; +sub labels_remove_special +{ + my $mysync = shift @ARG ; + my $labels = shift @ARG ; + if ( not defined $mysync ) { return ; } if ( not defined $labels ) { return ; } my @labels = quotewords('\s+', 1, $labels ) ; - myprint( "labels before remove_non_folded: @labels\n" ) ; + $mysync->{ debuglabels } and myprint( "labels before labels_remove_special: @labels\n" ) ; my @labels_remove_special ; foreach my $label ( @labels ) @@ -11805,48 +13488,50 @@ sub labels_remove_special my $labels_remove_special = join( ' ', sort @labels_remove_special ) ; return $labels_remove_special ; -} +} sub tests_labels_add_subfolder2 { note( 'Entering tests_labels_add_subfolder2()' ) ; is( undef, labels_add_subfolder2( ), 'labels_add_subfolder2: no parameters => undef' ) ; - is( 'Blabla', labels_add_subfolder2( 'Blabla' ), 'labels_add_subfolder2: one parameter Blabla => Blabla' ) ; - is( 'Blan blue', labels_add_subfolder2( 'Blan blue' ), 'labels_add_subfolder2: one parameter Blan blue => Blan blue' ) ; - is( '\Bla "Blan blan" Blabla', labels_add_subfolder2( '\Bla "Blan blan" Blabla' ), + + my $mysync = { } ; + is( 'Blabla', labels_add_subfolder2( $mysync, 'Blabla' ), 'labels_add_subfolder2: one parameter Blabla => Blabla' ) ; + is( 'Blan blue', labels_add_subfolder2( $mysync, 'Blan blue' ), 'labels_add_subfolder2: one parameter Blan blue => Blan blue' ) ; + is( '\Bla "Blan blan" Blabla', labels_add_subfolder2( $mysync, '\Bla "Blan blan" Blabla' ), 'labels_add_subfolder2: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ; - is( 'Subf/Bla', labels_add_subfolder2( 'Bla', 'Subf' ), 'labels_add_subfolder2: Bla Subf => "Subf/Bla"' ) ; + is( 'Subf/Bla', labels_add_subfolder2( $mysync, 'Bla', 'Subf' ), 'labels_add_subfolder2: Bla Subf => "Subf/Bla"' ) ; - is( 'Subf/\Bla', labels_add_subfolder2( '\\\\Bla', 'Subf' ), 'labels_add_subfolder2: \Bla Subf => \Bla' ) ; + is( 'Subf/\Bla', labels_add_subfolder2( $mysync, '\\\\Bla', 'Subf' ), 'labels_add_subfolder2: \Bla Subf => \Bla' ) ; - is( 'Subf/Bla Subf/Kii', labels_add_subfolder2( 'Bla Kii', 'Subf' ), + is( 'Subf/Bla Subf/Kii', labels_add_subfolder2( $mysync, 'Bla Kii', 'Subf' ), 'labels_add_subfolder2: Bla Kii Subf => "Subf/Bla" "Subf/Kii"' ) ; - is( 'Subf/Kii Subf/\Bla', labels_add_subfolder2( '\\\\Bla Kii', 'Subf' ), + is( 'Subf/Kii Subf/\Bla', labels_add_subfolder2( $mysync, '\\\\Bla Kii', 'Subf' ), 'labels_add_subfolder2: \Bla Kii Subf => \Bla Subf/Kii' ) ; - is( '"Subf/Blan blan"', labels_add_subfolder2( '"Blan blan"', 'Subf' ), + is( '"Subf/Blan blan"', labels_add_subfolder2( $mysync, '"Blan blan"', 'Subf' ), 'labels_add_subfolder2: "Blan blan" Subf => "Subf/Blan blan"' ) ; - is( '"Subf/Blan blan" Subf/Kii Subf/\Loo', labels_add_subfolder2( '\\\\Loo "Blan blan" Kii', 'Subf' ), + is( '"Subf/Blan blan" Subf/Kii Subf/\Loo', labels_add_subfolder2( $mysync, '\\\\Loo "Blan blan" Kii', 'Subf' ), 'labels_add_subfolder2: \Loo "Blan blan" Kii + Subf => "Subf/Blan blan" Subf/Kii Subf/\Loo' ) ; # "\\Inbox" is special, add to subfolder INBOX also because Gmail will but ... - is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox"', 'Subf' ), + is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( $mysync, '"\\\\Inbox"', 'Subf' ), 'labels_add_subfolder2: "\\\\Inbox" Subf => "Subf/\\\\Inbox" Subf/INBOX' ) ; # but not with INBOX folder - is( '"Subf/\\\\Inbox"', labels_add_subfolder2( '"\\\\Inbox"', 'Subf', 'INBOX' ), + is( '"Subf/\\\\Inbox"', labels_add_subfolder2( $mysync, '"\\\\Inbox"', 'Subf', 'INBOX' ), 'labels_add_subfolder2: "\\\\Inbox" Subf INBOX => "Subf/\\\\Inbox"' ) ; # two times => one time - is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox" "\\\\Inbox"', 'Subf' ), + is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( $mysync, '"\\\\Inbox" "\\\\Inbox"', 'Subf' ), 'labels_add_subfolder2: "\\\\Inbox" "\\\\Inbox" Subf => "Subf/\\\\Inbox"' ) ; - is( '"Subf/\\\\Starred"', labels_add_subfolder2( '"\\\\Starred"', 'Subf' ), + is( '"Subf/\\\\Starred"', labels_add_subfolder2( $mysync, '"\\\\Starred"', 'Subf' ), 'labels_add_subfolder2: "\\\\Starred" Subf => "Subf/\\\\Starred"' ) ; note( 'Leaving tests_labels_add_subfolder2()' ) ; @@ -11855,10 +13540,12 @@ sub tests_labels_add_subfolder2 sub labels_add_subfolder2 { - my $labels = shift ; - my $subfolder2 = shift ; + my $mysync = shift @ARG ; + my $labels = shift @ARG ; + my $subfolder2 = shift @ARG ; my $h1_folder = shift || q{} ; + if ( not defined $mysync ) { return ; } if ( not defined $labels ) { return ; } if ( not defined $subfolder2 ) { return $labels ; } @@ -11869,7 +13556,7 @@ sub labels_add_subfolder2 } my @labels = uniq( quotewords('\s+', 1, $labels ) ) ; - myprint( "labels before subfolder2: @labels\n" ) ; + $mysync->{ debuglabels } and myprint( "labels before subfolder2: @labels\n" ) ; my @labels_subfolder2 ; @@ -11936,7 +13623,7 @@ sub tests_labels } ) ; $myimap->mock( 'Debug' , sub { } ) ; - $myimap->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one + $myimap->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @ARG ) } ) ; # real one is( undef, labels( $myimap ), 'labels: one parameter => undef' ) ; is( '\Seen Blabla', labels( $myimap, '1' ), 'labels: $mysync UID_1 => \Seen Blabla' ) ; @@ -11984,7 +13671,7 @@ sub tests_synclabels } ) ; $myimap1->mock( 'Debug', sub { } ) ; - $myimap1->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one + $myimap1->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @ARG ) } ) ; # real one my $myimap2 = Test::MockObject->new( ) ; @@ -11995,8 +13682,8 @@ sub tests_synclabels ) ; - $mysync->{imap1} = $myimap1 ; - $mysync->{imap2} = $myimap2 ; + $mysync->{ imap1 } = $myimap1 ; + $mysync->{ imap2 } = $myimap2 ; is( undef, synclabels( $mysync ), 'synclabels: fresh $mysync => undef' ) ; @@ -12008,7 +13695,7 @@ sub tests_synclabels } -sub synclabels +sub synclabels { my( $mysync, $uid1, $uid2 ) = @ARG ; @@ -12018,23 +13705,23 @@ sub synclabels my $myimap1 = $mysync->{ 'imap1' } || return ; my $myimap2 = $mysync->{ 'imap2' } || return ; - $mysync->{debuglabels} and $myimap1->Debug( 1 ) ; + $mysync->{ debuglabels } and $myimap1->Debug( 1 ) ; my $labels1 = labels( $myimap1, $uid1 ) ; - $mysync->{debuglabels} and $myimap1->Debug( 0 ) ; - $mysync->{debuglabels} and myprint( "Host1 labels: $labels1\n" ) ; + $mysync->{ debuglabels } and $myimap1->Debug( 0 ) ; + $mysync->{ debuglabels } and myprint( "Host1 labels: $labels1\n" ) ; if ( $mysync->{ subfolder1 } and $labels1 ) { - $labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ; - $mysync->{debuglabels} and myprint( "Host1 labels with subfolder1: $labels1\n" ) ; + $labels1 = labels_remove_subfolder1( $mysync, $labels1, $mysync->{ subfolder1 } ) ; + $mysync->{ debuglabels } and myprint( "Host1 labels without subfolder1: $labels1\n" ) ; } if ( $mysync->{ subfolder2 } and $labels1 ) { - $labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 } ) ; - $mysync->{debuglabels} and myprint( "Host1 labels with subfolder2: $labels1\n" ) ; + $labels1 = labels_add_subfolder2( $mysync, $labels1, $mysync->{ subfolder2 } ) ; + $mysync->{ debuglabels } and myprint( "Host1 labels with subfolder2: $labels1\n" ) ; } my $store ; @@ -12077,7 +13764,7 @@ sub tests_resynclabels } ) ; $myimap2->mock( 'Debug', sub { } ) ; - $mysync->{imap2} = $myimap2 ; + $mysync->{ imap2 } = $myimap2 ; is( 1, resynclabels( $mysync, 11, 22, $h1_fir_ref, $h2_fir_ref ), 'resynclabels: $mysync UID_1 UID_2 labels are not equal => store => 1' ) ; @@ -12092,7 +13779,8 @@ sub resynclabels { my( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref, $h1_folder ) = @ARG ; - if ( not all_defined( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref ) ) { + if ( not all_defined( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref ) ) + { return ; } @@ -12101,13 +13789,14 @@ sub resynclabels if ( $mysync->{ subfolder1 } and $labels1 ) { - $labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ; + $labels1 = labels_remove_subfolder1( $mysync, $labels1, $mysync->{ subfolder1 } ) ; + $mysync->{ debuglabels } and myprint( "Host1 labels without subfolder1: $labels1\n" ) ; } if ( $mysync->{ subfolder2 } and $labels1 ) { - $labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 }, $h1_folder ) ; - $labels2 = labels_remove_special( $labels2 ) ; + $labels1 = labels_add_subfolder2( $mysync, $labels1, $mysync->{ subfolder2 }, $h1_folder ) ; + $labels2 = labels_remove_special( $mysync, $labels2 ) ; } $mysync->{ debuglabels } and myprint( "Host1 labels fixed: $labels1\n" ) ; $mysync->{ debuglabels } and myprint( "Host2 labels : $labels2\n" ) ; @@ -12122,9 +13811,9 @@ sub resynclabels elsif ( not $mysync->{ dry } ) { # sync needed - $mysync->{debuglabels} and $mysync->{imap2}->Debug( 1 ) ; - $store = $mysync->{imap2}->store( $uid2, "X-GM-LABELS ($labels1)" ) ; - $mysync->{debuglabels} and $mysync->{imap2}->Debug( 0 ) ; + $mysync->{debuglabels} and $mysync->{ imap2 }->Debug( 1 ) ; + $store = $mysync->{ imap2 }->store( $uid2, "X-GM-LABELS ($labels1)" ) ; + $mysync->{debuglabels} and $mysync->{ imap2 }->Debug( 0 ) ; } return $store ; @@ -12159,7 +13848,7 @@ sub uniq sub length_ref { - my $string_ref = shift ; + my $string_ref = shift @ARG ; my $string_len = defined ${ $string_ref } ? length( ${ $string_ref } ) : q{} ; # length or empty string return $string_len ; } @@ -12181,33 +13870,35 @@ sub tests_length_ref return ; } -sub date_for_host2 +sub date_for_host2 { - my( $h1_msg, $h1_idate ) = @_ ; + my( $mysync, $h1_msg, $h1_idate ) = @ARG ; my $h1_date = q{} ; - if ( $syncinternaldates ) { + if ( $mysync->{ syncinternaldates } ) + { $h1_date = $h1_idate ; - $sync->{ debug } and myprint( "internal date from host1: [$h1_date]\n" ) ; + $mysync->{ debug } and myprint( "internal date from host1: [$h1_date]\n" ) ; $h1_date = good_date( $h1_date ) ; - $sync->{ debug } and myprint( "internal date from host1: [$h1_date] (fixed)\n" ) ; + $mysync->{ debug } and myprint( "internal date from host1: [$h1_date] (fixed)\n" ) ; } - if ( $idatefromheader ) { - $h1_date = $sync->{imap1}->get_header( $h1_msg, 'Date' ) ; - $sync->{ debug } and myprint( "header date from host1: [$h1_date]\n" ) ; + if ( $mysync->{ idatefromheader } ) + { + $h1_date = $mysync->{ imap1 }->get_header( $h1_msg, 'Date' ) ; + $mysync->{ debug } and myprint( "header date from host1: [$h1_date]\n" ) ; $h1_date = good_date( $h1_date ) ; - $sync->{ debug } and myprint( "header date from host1: [$h1_date] (fixed)\n" ) ; + $mysync->{ debug } and myprint( "header date from host1: [$h1_date] (fixed)\n" ) ; } return( $h1_date ) ; -} +} sub subject { - my $string = shift ; + my $string = shift @ARG ; my $subject = q{} ; my $header = extract_header( $string ) ; @@ -12291,16 +13982,16 @@ EOF # sub append_message_on_host2 { - my( $mysync, $string_ref, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) = @_ ; - myprint( debugmemory( $mysync, " at A1" ) ) ; + my( $mysync, $string_ref, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) = @ARG ; + myprint( debugmemory( $mysync, " at sub append_message_on_host2 A1" ) ) ; my $new_id ; - if ( ! $mysync->{dry} ) { - $new_id = $mysync->{imap2}->append_string( $h2_fold, ${ $string_ref }, $h1_flags, $h1_date ) ; - myprint( debugmemory( $mysync, " at A2" ) ) ; + if ( ! $mysync->{ dry } ) { + $new_id = $mysync->{ imap2 }->append_string( $h2_fold, ${ $string_ref }, $h1_flags, $h1_date ) ; + myprint( debugmemory( $mysync, " at sub append_message_on_host2 A2" ) ) ; if ( ! defined $new_id ){ my $subject = subject( ${ $string_ref } ) ; - my $error_imap = $mysync->{imap2}->LastError || q{} ; + 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" ; errors_incr( $mysync, $error ) ; $mysync->{ h1_nb_msg_processed } +=1 ; @@ -12311,7 +14002,7 @@ sub append_message_on_host2 # $new_id is an id if the IMAP server has the # UIDPLUS capability else just a ref if ( $new_id !~ m{^\d+$}x ) { - $new_id = lastuid( $mysync->{imap2}, $h2_fold, $h2_uidguess ) ; + $new_id = lastuid( $mysync->{ imap2 }, $h2_fold, $h2_uidguess ) ; } if ( $mysync->{ synclabels } ) { synclabels( $mysync, $h1_msg, $new_id ) } $h2_uidguess += 1 ; @@ -12320,8 +14011,8 @@ sub append_message_on_host2 $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_bin( $mysync->{total_bytes_transferred} / $time_spent ) ; + my $time_spent = timesince( $mysync->{ begin_transfer_time } ) ; + my $rate = bytes_display_string_bin( $mysync->{ total_bytes_transferred } / $time_spent ) ; my $eta = eta( $mysync ) ; my $amount_transferred = bytes_display_string_bin( $mysync->{total_bytes_transferred} ) ; myprintf( "msg %s/%-19s copied to %s/%-10s %.2f msgs/s %s/s %s copied %s\n", @@ -12329,8 +14020,9 @@ sub append_message_on_host2 $amount_transferred, $eta ); sleep_if_needed( $mysync ) ; - if ( $usecache and $cacheaftercopy and $new_id =~ m{^\d+$}x ) { - $debugcache and myprint( "touch $cache_dir/${h1_msg}_$new_id\n" ) ; + if ( $mysync->{ usecache } and $mysync->{ cacheaftercopy } and $new_id =~ m{^\d+$}x ) + { + $mysync->{ debugcache } and myprint( "touch new $cache_dir/${h1_msg}_$new_id\n" ) ; touch( "$cache_dir/${h1_msg}_$new_id" ) or croak( "Couldn't touch $cache_dir/${h1_msg}_$new_id" ) ; } @@ -12343,7 +14035,7 @@ sub append_message_on_host2 } } else{ - $nb_msg_skipped_dry_mode += 1 ; + $mysync->{ nb_msg_skipped_dry_mode } += 1 ; $mysync->{ h1_nb_msg_processed } += 1 ; } @@ -12386,7 +14078,7 @@ sub tests_sleep_if_needed sub sleep_if_needed { - my( $mysync ) = shift ; + my( $mysync ) = shift @ARG ; if ( ! $mysync ) { return ; @@ -12431,7 +14123,7 @@ sub sleep_if_needed sub sleep_max_messages { # how long we have to sleep to go under max_messages_per_second - my( $nb_msg_transferred, $time_spent, $maxmessagespersecond ) = @_ ; + my( $nb_msg_transferred, $time_spent, $maxmessagespersecond ) = @ARG ; if ( ( not defined $maxmessagespersecond ) or $maxmessagespersecond <= 0 ) { return( 0 ) } ; my $sleep = ( $nb_msg_transferred / $maxmessagespersecond ) - $time_spent ; # the sleep must be positive @@ -12458,7 +14150,7 @@ sub tests_sleep_max_messages sub sleep_max_bytes { # how long we have to sleep to go under max_bytes_per_second - my( $total_bytes_to_consider, $time_spent, $maxbytespersecond ) = @_ ; + my( $total_bytes_to_consider, $time_spent, $maxbytespersecond ) = @ARG ; $total_bytes_to_consider ||= 0 ; $time_spent ||= 0 ; @@ -12490,7 +14182,7 @@ sub tests_sleep_max_bytes sub delete_message_on_host1 { - my( $mysync, $h1_fold, $expunge, @h1_msg ) = @_ ; + my( $mysync, $h1_fold, $expunge, @h1_msg ) = @ARG ; if ( ! $mysync->{ delete1 } ) { return ; } if ( ! @h1_msg ) { return ; } delete_messages_on_any( @@ -12537,7 +14229,7 @@ sub delete_messages_on_any { # $acc is not used yet, # - my( $mysync, $acc, $imap, $hostX_folder, $expunge, $split, @messages ) = @_ ; + my( $mysync, $acc, $imap, $hostX_folder, $expunge, $split, @messages ) = @ARG ; my $expunge_message = q{} ; my $dry_message = $mysync->{ dry_message } ; @@ -12553,7 +14245,7 @@ sub delete_messages_on_any { myprint( "$hostX_folder/$message marking deleted $expunge_message $dry_message\n" ) ; } - if ( ! $mysync->{dry} && @messages_part ) + if ( ! $mysync->{ dry } && @messages_part ) { my $nb_deleted = $imap->delete_message( $imap->Range( @messages_part ) ) ; if ( defined $nb_deleted ) @@ -12618,8 +14310,8 @@ sub tests_uidexpunge_or_expunge sub uidexpunge_or_expunge { - my $mysync = shift ; - my $imap = shift ; + my $mysync = shift @ARG ; + my $imap = shift @ARG ; my @messages = @ARG ; if ( ! $imap ) { return ; } ; @@ -12641,7 +14333,7 @@ sub uidexpunge_or_expunge sub eta_print { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( my $eta = eta( $mysync ) ) { myprint( "$eta\n" ) ; @@ -12681,7 +14373,7 @@ sub tests_eta sub eta { - my( $mysync ) = shift ; + my( $mysync ) = shift @ARG ; if ( ! $mysync ) { @@ -12692,7 +14384,7 @@ sub eta my $h1_nb_msg_start = $mysync->{ h1_nb_msg_start } ; my $h1_nb_processed = $mysync->{ h1_nb_msg_processed } ; - my $nb_msg_transferred = ( $mysync->{dry} ) ? $mysync->{ h1_nb_msg_processed } : $mysync->{ nb_msg_transferred } ; + my $nb_msg_transferred = ( $mysync->{ dry } ) ? $mysync->{ h1_nb_msg_processed } : $mysync->{ nb_msg_transferred } ; my $time_spent = timesince( $mysync->{ begin_transfer_time } ) ; $h1_nb_processed ||= 0 ; $h1_nb_msg_start ||= 0 ; @@ -12712,7 +14404,7 @@ sub eta sub time_remaining { - my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @_ ; + my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @ARG ; $nb_transferred ||= 1 ; # At least one is done (no division by zero) $h1_nb_processed ||= 0 ; @@ -12724,28 +14416,64 @@ sub time_remaining } -sub tests_time_remaining +sub tests_time_remaining { note( 'Entering tests_time_remaining()' ) ; # time_spent, nb_processed, nb_to_do_total, nb_transferred is( 0, time_remaining( ), 'time_remaining: no args -> 0' ) ; - is( 0, time_remaining( 0, 0, 0, 0 ), 'time_remaining: 0, 0, 0, 0 -> 0' ) ; - is( 1, time_remaining( 1, 1, 2, 1 ), 'time_remaining: 1, 1, 2, 1 -> 1' ) ; - is( 1, time_remaining( 9, 9, 10, 9 ), 'time_remaining: 9, 9, 10, 9 -> 1' ) ; - is( 9, time_remaining( 1, 1, 10, 1 ), 'time_remaining: 1, 1, 10, 1 -> 9' ) ; - is( 5, time_remaining( 5, 5, 10, 5 ), 'time_remaining: 5, 5, 10, 5 -> 5' ) ; + is( 0, time_remaining( 0, 0, 0, 0 ), 'time_remaining: 0, 0, 0, 0 -> 0' ) ; + is( 1, time_remaining( 1, 1, 2, 1 ), 'time_remaining: 1, 1, 2, 1 -> 1' ) ; + is( 1, time_remaining( 9, 9, 10, 9 ), 'time_remaining: 9, 9, 10, 9 -> 1' ) ; + is( 9, time_remaining( 1, 1, 10, 1 ), 'time_remaining: 1, 1, 10, 1 -> 9' ) ; + is( 5, time_remaining( 5, 5, 10, 5 ), 'time_remaining: 5, 5, 10, 5 -> 5' ) ; is( 25, time_remaining( 5, 5, 10, 0 ), 'time_remaining: 5, 5, 10, 0 -> ( 5 / 1 ) * ( 10 - 5) = 25' ) ; + + # 1 mess transferred in 5 sec, 10 mess initially, 5 processed is( 25, time_remaining( 5, 5, 10, 1 ), 'time_remaining: 5, 5, 10, 1 -> ( 5 / 1 ) * ( 10 - 5) = 25' ) ; note( 'Leaving tests_time_remaining()' ) ; return ; +} + + + + +sub tests_usecache_and_skipcrossduplicates +{ + note( 'Entering tests_usecache_and_skipcrossduplicates()' ) ; + + is( undef, usecache_and_skipcrossduplicates( ), 'usecache_and_skipcrossduplicates: no args => undef' ) ; + my $mysync = { } ; + is( undef, usecache_and_skipcrossduplicates( $mysync ), 'usecache_and_skipcrossduplicates: undef => undef' ) ; + + $mysync->{ usecache } = $mysync->{ skipcrossduplicates } = 1 ; + is( 1, usecache_and_skipcrossduplicates( $mysync ), 'usecache_and_skipcrossduplicates: usecache=skipcrossduplicates=1 => wrong' ) ; + + note( 'Leaving tests_usecache_and_skipcrossduplicates()' ) ; + return ; } +sub usecache_and_skipcrossduplicates +{ + my $mysync = shift @ARG ; + + if ( ! defined $mysync ) { return ; } + + if ( ( $mysync->{ usecache } ) and ( $mysync->{ skipcrossduplicates } ) ) + { + return 1 ; + } + + return ; +} + + + sub cache_map { - my ( $cache_files_ref, $h1_msgs_ref, $h2_msgs_ref ) = @_; + my ( $mysync, $cache_files_ref, $h1_msgs_ref, $h2_msgs_ref ) = @ARG; my ( %map1_2, %map2_1, %done2 ) ; my $h1_msgs_hash_ref = { } ; @@ -12755,7 +14483,7 @@ sub cache_map @{ $h2_msgs_hash_ref }{ @{ $h2_msgs_ref } } = ( ) ; foreach my $file ( sort @{ $cache_files_ref } ) { - $debugcache and myprint( "C12: $file\n" ) ; + $mysync->{ debugcache } and myprint( "Cache C12: $file\n" ) ; ( $uid1, $uid2 ) = match_a_cache_file( $file ) ; if ( exists( $h1_msgs_hash_ref->{ defined $uid1 ? $uid1 : q{} } ) @@ -12785,11 +14513,15 @@ sub cache_map return( \%map1_2, \%map2_1) ; } -sub tests_cache_map +sub tests_cache_map { note( 'Entering tests_cache_map()' ) ; - #$debugcache = 1 ; + + my $mysync = { } ; + + #$mysync->{ debugcache } = 1 ; + my @cache_files = qw ( 100_200 101_201 @@ -12813,7 +14545,7 @@ sub tests_cache_map my $msgs_2 = [ 242, 243, 260, 299, 377, 279, 255, 280, 231, 2301 ]; my( $c12, $c21 ) ; - ok( ( $c12, $c21 ) = cache_map( \@cache_files, $msgs_1, $msgs_2 ), 'cache_map: 02' ); + ok( ( $c12, $c21 ) = cache_map( $mysync, \@cache_files, $msgs_1, $msgs_2 ), 'cache_map: 02' ); my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; ok( 0 == compare_lists( [ 130, 142, 143, 177, 182, 1601 ], $a1 ), 'cache_map: 03' ); @@ -12826,11 +14558,11 @@ sub tests_cache_map note( 'Leaving tests_cache_map()' ) ; return ; -} +} sub cache_dir_fix { - my $cache_dir = shift ; + my $cache_dir = shift @ARG ; $cache_dir =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\])/\\$1/xg ; #myprint( "cache_dir_fix: $cache_dir\n" ) ; return( $cache_dir ) ; @@ -12856,7 +14588,7 @@ sub tests_cache_dir_fix sub cache_dir_fix_win { - my $cache_dir = shift ; + my $cache_dir = shift @ARG ; $cache_dir =~ s/(\[|\])/[$1]/xg ; #myprint( "cache_dir_fix_win: $cache_dir\n" ) ; return( $cache_dir ) ; @@ -12874,16 +14606,14 @@ sub tests_cache_dir_fix_win } - - -sub get_cache +sub get_cache { - my ( $cache_dir, $h1_msgs_ref, $h2_msgs_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_; + my ( $mysync, $cache_dir, $h1_msgs_ref, $h2_msgs_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @ARG; - $debugcache and myprint( "Entering get_cache\n" ) ; + $mysync->{ debugcache } and myprint( "Entering get_cache\n" ) ; -d $cache_dir or return( undef ); # exit if cache directory doesn't exist - $debugcache and myprint( "cache_dir : $cache_dir\n" ) ; + $mysync->{ debugcache } and myprint( "cache_dir : $cache_dir\n" ) ; if ( 'MSWin32' ne $OSNAME ) { @@ -12892,19 +14622,19 @@ sub get_cache $cache_dir = cache_dir_fix_win( $cache_dir ) ; } - $debugcache and myprint( "cache_dir_fix: $cache_dir\n" ) ; + $mysync->{ debugcache } and myprint( "cache_dir_fix: $cache_dir\n" ) ; my @cache_files = bsd_glob( "$cache_dir/*" ) ; - #$debugcache and myprint( "cache_files: [@cache_files]\n" ) ; + #$mysync->{ debugcache } and myprint( "cache_files: [@cache_files]\n" ) ; - $debugcache and myprint( 'cache_files: ', scalar @cache_files , " files found\n" ) ; + $mysync->{ debugcache } and myprint( 'cache_files: ', scalar @cache_files , " files found\n" ) ; my( $cache_1_2_ref, $cache_2_1_ref ) - = cache_map( \@cache_files, $h1_msgs_ref, $h2_msgs_ref ) ; + = cache_map( $mysync, \@cache_files, $h1_msgs_ref, $h2_msgs_ref ) ; - clean_cache( \@cache_files, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; + clean_cache( $mysync, \@cache_files, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; - $debugcache and myprint( "Exiting get_cache\n" ) ; + $mysync->{ debugcache } and myprint( "Exiting get_cache\n" ) ; return( $cache_1_2_ref, $cache_2_1_ref ) ; } @@ -12913,9 +14643,10 @@ sub tests_get_cache { note( 'Entering tests_get_cache()' ) ; - ok( not( get_cache('/cache_no_exist') ), 'get_cache: /cache_no_exist' ); - ok( ( not -d 'W/tmp/cache/F1/F2' or rmtree( 'W/tmp/cache/F1/F2' ) ), 'get_cache: rmtree W/tmp/cache/F1/F2' ) ; - ok( mkpath( 'W/tmp/cache/F1/F2' ), 'get_cache: mkpath W/tmp/cache/F1/F2' ) ; + my $mysync = { } ; + ok( not( get_cache( $mysync, '/cache_no_exist') ), 'tests_get_cache: /cache_no_exist' ); + ok( ( not -d 'W/tmp/cache/F1/F2' or rmtree( 'W/tmp/cache/F1/F2' ) ), 'tests_get_cache: rmtree W/tmp/cache/F1/F2' ) ; + ok( mkpath( 'W/tmp/cache/F1/F2' ), 'tests_get_cache: mkpath W/tmp/cache/F1/F2' ) ; my @test_files_cache = ( qw( W/tmp/cache/F1/F2/100_200 @@ -12928,7 +14659,7 @@ sub tests_get_cache W/tmp/cache/F1/F2/177_777 W/tmp/cache/F1/F2/155_255 ) ) ; - ok( touch( @test_files_cache ), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ; + ok( touch( @test_files_cache ), 'tests_get_cache: touch W/tmp/cache/F1/F2/...' ) ; # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 @@ -12940,31 +14671,32 @@ sub tests_get_cache my $msgs_all_2 = { 242 => 0, 243 => 0, 299 => 0, 377 => 0, 777 => 0, 255 => 0 } ; my( $c12, $c21 ) ; - ok( ( $c12, $c21 ) = get_cache( 'W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' ); + ok( ( $c12, $c21 ) = get_cache( $mysync, 'W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'tests_get_cache: 02' ); my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; - ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: 03' ); - ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: 04' ); - ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); - ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); - ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file removed 100_200'); - ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file removed 101_201'); + ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'tests_get_cache: 03' ); + ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'tests_get_cache: 04' ); + ok( -f 'W/tmp/cache/F1/F2/142_242', 'tests_get_cache: file kept 142_242'); + ok( -f 'W/tmp/cache/F1/F2/142_242', 'tests_get_cache: file kept 143_243'); + ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'tests_get_cache: file removed 100_200'); + ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'tests_get_cache: file removed 101_201'); # test clean_cache executed - $maxage = 2 ; - ok( touch(@test_files_cache), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ; - ok( ( $c12, $c21 ) = get_cache('W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' ); - ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); - ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); - ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file NOT removed 100_200'); - ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file NOT removed 101_201'); + $mysync = { } ; + $mysync->{ maxage } = 2 ; + ok( touch(@test_files_cache), 'tests_get_cache: touch W/tmp/cache/F1/F2/...' ) ; + ok( ( $c12, $c21 ) = get_cache( $mysync, 'W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'tests_get_cache: 02' ); + ok( -f 'W/tmp/cache/F1/F2/142_242', 'tests_get_cache: file kept 142_242'); + ok( -f 'W/tmp/cache/F1/F2/142_242', 'tests_get_cache: file kept 143_243'); + ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'tests_get_cache: file NOT removed 100_200'); + ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'tests_get_cache: file NOT removed 101_201'); # strange files - #$debugcache = 1 ; - $maxage = undef ; - ok( ( not -d 'W/tmp/cache/rr\uee' or rmtree( 'W/tmp/cache/rr\uee' )), 'get_cache: rmtree W/tmp/cache/rr\uee' ) ; - ok( mkpath( 'W/tmp/cache/rr\uee' ), 'get_cache: mkpath W/tmp/cache/rr\uee' ) ; + #$mysync->{ debugcache } = 1 ; + $mysync->{ maxage } = undef ; + ok( ( not -d 'W/tmp/cache/rr\uee' or rmtree( 'W/tmp/cache/rr\uee' )), 'tests_get_cache: rmtree W/tmp/cache/rr\uee' ) ; + ok( mkpath( 'W/tmp/cache/rr\uee' ), 'tests_get_cache: mkpath W/tmp/cache/rr\uee' ) ; @test_files_cache = ( qw( W/tmp/cache/rr\uee/100_200 @@ -12977,7 +14709,7 @@ sub tests_get_cache W/tmp/cache/rr\uee/177_777 W/tmp/cache/rr\uee/155_255 ) ) ; - ok( touch(@test_files_cache), 'get_cache: touch strange W/tmp/cache/...' ) ; + ok( touch(@test_files_cache), 'tests_get_cache: touch strange W/tmp/cache/...' ) ; # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 # on live: @@ -12987,23 +14719,23 @@ sub tests_get_cache $msgs_all_1 = { 120 => q{}, 142 => q{}, 143 => q{}, 144 => q{}, 177 => q{} } ; $msgs_all_2 = { 242 => q{}, 243 => q{}, 299 => q{}, 377 => q{}, 777 => q{}, 255 => q{} } ; - ok( ( $c12, $c21 ) = get_cache('W/tmp/cache/rr\uee', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2), 'get_cache: strange path 02' ); + ok( ( $c12, $c21 ) = get_cache( $mysync, 'W/tmp/cache/rr\uee', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2), 'tests_get_cache: strange path 02' ); $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; - ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: strange path 03' ); - ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: strange path 04' ); - ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 142_242'); - ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 143_243'); - ok( ! -f 'W/tmp/cache/rr\uee/100_200', 'get_cache: strange path file removed 100_200'); - ok( ! -f 'W/tmp/cache/rr\uee/101_201', 'get_cache: strange path file removed 101_201'); + ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'tests_get_cache: strange path 03' ); + ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'tests_get_cache: strange path 04' ); + ok( -f 'W/tmp/cache/rr\uee/142_242', 'tests_get_cache: strange path file kept 142_242'); + ok( -f 'W/tmp/cache/rr\uee/142_242', 'tests_get_cache: strange path file kept 143_243'); + ok( ! -f 'W/tmp/cache/rr\uee/100_200', 'tests_get_cache: strange path file removed 100_200'); + ok( ! -f 'W/tmp/cache/rr\uee/101_201', 'tests_get_cache: strange path file removed 101_201'); note( 'Leaving tests_get_cache()' ) ; return ; -} +} sub match_a_cache_file { - my $file = shift ; + my $file = shift @ARG ; my ( $cache_uid1, $cache_uid2 ) ; return( ( undef, undef ) ) if ( ! $file ) ; @@ -13019,31 +14751,31 @@ sub tests_match_a_cache_file note( 'Entering tests_match_a_cache_file()' ) ; my ( $tuid1, $tuid2 ) ; - ok( ( $tuid1, $tuid2 ) = match_a_cache_file( ), 'match_a_cache_file: no arg' ) ; + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( ), 'tests_match_a_cache_file: no arg' ) ; ok( ! defined $tuid1 , 'match_a_cache_file: no arg 1' ) ; ok( ! defined $tuid2 , 'match_a_cache_file: no arg 2' ) ; - ok( ( $tuid1, $tuid2 ) = match_a_cache_file( q{} ), 'match_a_cache_file: empty arg' ) ; + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( q{} ), 'tests_match_a_cache_file: empty arg' ) ; ok( ! defined $tuid1 , 'match_a_cache_file: empty arg 1' ) ; ok( ! defined $tuid2 , 'match_a_cache_file: empty arg 2' ) ; - ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '000_000' ), 'match_a_cache_file: 000_000' ) ; + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '000_000' ), 'tests_match_a_cache_file: 000_000' ) ; ok( '000' eq $tuid1, 'match_a_cache_file: 000_000 1' ) ; ok( '000' eq $tuid2, 'match_a_cache_file: 000_000 2' ) ; - ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '123_456' ), 'match_a_cache_file: 123_456' ) ; + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '123_456' ), 'tests_match_a_cache_file: 123_456' ) ; ok( '123' eq $tuid1, 'match_a_cache_file: 123_456 1' ) ; ok( '456' eq $tuid2, 'match_a_cache_file: 123_456 2' ) ; - ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/tmp/truc/123_456' ), 'match_a_cache_file: /tmp/truc/123_456' ) ; + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/tmp/truc/123_456' ), 'tests_match_a_cache_file: /tmp/truc/123_456' ) ; ok( '123' eq $tuid1, 'match_a_cache_file: /tmp/truc/123_456 1' ) ; ok( '456' eq $tuid2, 'match_a_cache_file: /tmp/truc/123_456 2' ) ; - ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/lala123_456' ), 'match_a_cache_file: NO /lala123_456' ) ; + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/lala123_456' ), 'tests_match_a_cache_file: NO /lala123_456' ) ; ok( ! $tuid1, 'match_a_cache_file: /lala123_456 1' ) ; ok( ! $tuid2, 'match_a_cache_file: /lala123_456 2' ) ; - ok( ( $tuid1, $tuid2 ) = match_a_cache_file( 'la123_456' ), 'match_a_cache_file: NO la123_456' ) ; + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( 'la123_456' ), 'tests_match_a_cache_file: NO la123_456' ) ; ok( ! $tuid1, 'match_a_cache_file: la123_456 1' ) ; ok( ! $tuid2, 'match_a_cache_file: la123_456 2' ) ; @@ -13053,15 +14785,15 @@ sub tests_match_a_cache_file sub clean_cache { - my ( $cache_files_ref, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_ ; + my ( $mysync, $cache_files_ref, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @ARG ; - $debugcache and myprint( "Entering clean_cache\n" ) ; + $mysync->{ debugcache } and myprint( "Entering clean_cache\n" ) ; - $debugcache and myprint( map { "$_ -> " . $cache_1_2_ref->{ $_ } . "\n" } keys %{ $cache_1_2_ref } ) ; + $mysync->{ debugcache } and myprint( map { "$_ -> " . $cache_1_2_ref->{ $_ } . "\n" } keys %{ $cache_1_2_ref } ) ; foreach my $file ( @{ $cache_files_ref } ) { - $debugcache and myprint( "$file\n" ) ; + $mysync->{ debugcache } and myprint( "$file\n" ) ; my ( $cache_uid1, $cache_uid2 ) = match_a_cache_file( $file ) ; - $debugcache and myprint( "u1: $cache_uid1 u2: $cache_uid2 c12: ", $cache_1_2_ref->{ $cache_uid1 } || q{}, "\n") ; + $mysync->{ debugcache } and myprint( "u1: $cache_uid1 u2: $cache_uid2 c12: ", $cache_1_2_ref->{ $cache_uid1 } || q{}, "\n") ; # or ( ! exists( $cache_1_2_ref->{ $cache_uid1 } ) ) # or ( ! ( $cache_uid2 == $cache_1_2_ref->{ $cache_uid1 } ) ) if ( ( not defined $cache_uid1 ) @@ -13069,21 +14801,20 @@ sub clean_cache or ( not exists $h1_msgs_all_hash_ref->{ $cache_uid1 } ) or ( not exists $h2_msgs_all_hash_ref->{ $cache_uid2 } ) ) { - $debugcache and myprint( "remove $file\n" ) ; + $mysync->{ debugcache } and myprint( "remove $file\n" ) ; unlink $file or myprint( "$OS_ERROR" ) ; } } - - $debugcache and myprint( "Exiting clean_cache\n" ) ; + $mysync->{ debugcache } and myprint( "Exiting clean_cache\n" ) ; return( 1 ) ; } -sub tests_clean_cache +sub tests_clean_cache { note( 'Entering tests_clean_cache()' ) ; - ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache: rmtree W/tmp/cache/G1/G2' ) ; - ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache: mkpath W/tmp/cache/G1/G2' ) ; + ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'tests_clean_cache: rmtree W/tmp/cache/G1/G2' ) ; + ok( mkpath( 'W/tmp/cache/G1/G2' ), 'tests_clean_cache: mkpath W/tmp/cache/G1/G2' ) ; my @test_files_cache = ( qw( W/tmp/cache/G1/G2/100_200 @@ -13096,14 +14827,14 @@ sub tests_clean_cache W/tmp/cache/G1/G2/177_777 W/tmp/cache/G1/G2/155_255 ) ) ; - ok( touch(@test_files_cache), 'clean_cache: touch W/tmp/cache/G1/G2/...' ) ; + ok( touch(@test_files_cache), 'tests_clean_cache: touch W/tmp/cache/G1/G2/...' ) ; - ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 before' ); - ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 before' ); - ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 before' ); - ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 before' ); - ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 before' ); - ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 before' ); + ok( -f 'W/tmp/cache/G1/G2/100_200', 'tests_clean_cache: 100_200 before' ); + ok( -f 'W/tmp/cache/G1/G2/142_242', 'tests_clean_cache: 142_242 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_277', 'tests_clean_cache: 177_277 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_377', 'tests_clean_cache: 177_377 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_777', 'tests_clean_cache: 177_777 before' ); + ok( -f 'W/tmp/cache/G1/G2/155_255', 'tests_clean_cache: 155_255 before' ); my $cache = { 142 => 242, @@ -13120,25 +14851,27 @@ sub tests_clean_cache 242 => q{}, 777 => q{}, } ; - ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache: ' ) ; + + my $mysync = { } ; + ok( clean_cache( $mysync, \@test_files_cache, $cache, $all_1, $all_2 ), 'tests_clean_cache: ' ) ; - ok( ! -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 after' ); - ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 after' ); - ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 after' ); - ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 after' ); - ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 after' ); - ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/100_200', 'tests_clean_cache: 100_200 after' ); + ok( -f 'W/tmp/cache/G1/G2/142_242', 'tests_clean_cache: 142_242 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'tests_clean_cache: 177_277 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'tests_clean_cache: 177_377 after' ); + ok( -f 'W/tmp/cache/G1/G2/177_777', 'tests_clean_cache: 177_777 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'tests_clean_cache: 155_255 after' ); note( 'Leaving tests_clean_cache()' ) ; return ; -} +} -sub tests_clean_cache_2 +sub tests_clean_cache_2 { note( 'Entering tests_clean_cache_2()' ) ; - ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache_2: rmtree W/tmp/cache/G1/G2' ) ; - ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache_2: mkpath W/tmp/cache/G1/G2' ) ; + ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'tests_clean_cache_2: rmtree W/tmp/cache/G1/G2' ) ; + ok( mkpath( 'W/tmp/cache/G1/G2' ), 'tests_clean_cache_2: mkpath W/tmp/cache/G1/G2' ) ; my @test_files_cache = ( qw( W/tmp/cache/G1/G2/100_200 @@ -13151,14 +14884,14 @@ sub tests_clean_cache_2 W/tmp/cache/G1/G2/177_777 W/tmp/cache/G1/G2/155_255 ) ) ; - ok( touch(@test_files_cache), 'clean_cache_2: touch W/tmp/cache/G1/G2/...' ) ; + ok( touch(@test_files_cache), 'tests_clean_cache_2: touch W/tmp/cache/G1/G2/...' ) ; - ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 before' ); - ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 before' ); - ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 before' ); - ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 before' ); - ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 before' ); - ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 before' ); + ok( -f 'W/tmp/cache/G1/G2/100_200', 'tests_clean_cache_2: 100_200 before' ); + ok( -f 'W/tmp/cache/G1/G2/142_242', 'tests_clean_cache_2: 142_242 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_277', 'tests_clean_cache_2: 177_277 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_377', 'tests_clean_cache_2: 177_377 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_777', 'tests_clean_cache_2: 177_777 before' ); + ok( -f 'W/tmp/cache/G1/G2/155_255', 'tests_clean_cache_2: 155_255 before' ); my $cache = { 142 => 242, @@ -13178,19 +14911,20 @@ sub tests_clean_cache_2 } ; + my $mysync = { } ; + + ok( clean_cache( $mysync, \@test_files_cache, $cache, $all_1, $all_2 ), 'tests_clean_cache_2: ' ) ; - ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache_2: ' ) ; - - ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 after' ); - ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 after' ); - ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 after' ); - ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 after' ); - ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 after' ); - ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 after' ); + ok( -f 'W/tmp/cache/G1/G2/100_200', 'tests_clean_cache_2: 100_200 after' ); + ok( -f 'W/tmp/cache/G1/G2/142_242', 'tests_clean_cache_2: 142_242 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'tests_clean_cache_2: 177_277 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'tests_clean_cache_2: 177_377 after' ); + ok( -f 'W/tmp/cache/G1/G2/177_777', 'tests_clean_cache_2: 177_777 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'tests_clean_cache_2: 155_255 after' ); note( 'Leaving tests_clean_cache_2()' ) ; return ; -} +} @@ -13270,22 +15004,29 @@ sub tests_touch } -sub touch +sub touch { - my @files = @_ ; + # return 1 if it went good + # return 0 in case of failures + + my @files = @ARG ; my $failures = 0 ; - foreach my $file ( @files ) { + foreach my $file ( @files ) + { my $fh = IO::File->new ; - if ( $fh->open(">> $file" ) ) { + if ( $fh->open(">> $file" ) ) + { $fh->close ; - }else{ - myprint( "Could not open file $file in write/append mode\n" ) ; + } + else + { + #myprint( "Could not open file $file in write/append mode\n" ) ; $failures++ ; } } - return( ! $failures ); -} + return( ! $failures ) ; +} @@ -13304,7 +15045,7 @@ sub tests_tmpdir_has_colon_bug sub tmpdir_has_colon_bug { - my $path = shift ; + my $path = shift @ARG ; my $path_filtered = filter_forbidden_characters( $path ) ; if ( $path_filtered ne $path ) { @@ -13316,7 +15057,7 @@ sub tmpdir_has_colon_bug sub tmpdir_fix_colon_bug { - my $mysync = shift ; + my $mysync = shift @ARG ; my $err = 0 ; if ( not (-d $mysync->{ tmpdir } and -r _ and -w _) ) { myprint( "tmpdir $mysync->{ tmpdir } is not valid\n" ) ; @@ -13382,7 +15123,7 @@ sub tests_cache_folder sub cache_folder { - my( $cache_base, $cache_dir, $h1_fold, $h2_fold ) = @_ ; + my( $cache_base, $cache_dir, $h1_fold, $h2_fold ) = @ARG ; my $sep_1 = $sync->{ h1_sep } || '/'; my $sep_2 = $sync->{ h2_sep } || '/'; @@ -13396,11 +15137,12 @@ sub cache_folder return( $cache_folder ) ; } -sub tests_filter_forbidden_characters +sub tests_filter_forbidden_characters { note( 'Entering tests_filter_forbidden_characters()' ) ; is( undef , filter_forbidden_characters( ), 'filter_forbidden_characters: no args -> undef' ) ; + is( '' , filter_forbidden_characters( '' ), 'filter_forbidden_characters: empty string -> empty string' ) ; 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' ) ; @@ -13418,7 +15160,7 @@ sub tests_filter_forbidden_characters 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( 'abcdABCDwxyzWXYZ012789' , filter_forbidden_characters( 'abcdABCDwxyzWXYZ012789' ), 'filter_forbidden_characters: abcdABCDwxyzWXYZ012789 -> abcdABCDwxyzWXYZ012789' ) ; @@ -13426,22 +15168,67 @@ sub tests_filter_forbidden_characters note( 'Leaving tests_filter_forbidden_characters()' ) ; return ; -} +} -sub filter_forbidden_characters + +sub filter_forbidden_characters { - my $string = shift ; + my $string = shift @ARG ; if ( ! defined $string ) { return ; } - $string =~ s{[\Q*|?:"<>' \E\t\r\n\\]}{_}xg ; + $string =~ s{[\Q*|?:"<>' &\E\t\r\n\\]}{_}xg ; # replace all non-ascii and control characters by _ $string =~ s/[[:^ascii:][:cntrl:]]/_/xg ; #myprint( "[$string]\n" ) ; return( $string ) ; +} + + + +sub tests_filter_forbidden_characters_cgi_context +{ + note( 'Entering tests_filter_forbidden_characters()' ) ; + + is( undef , filter_forbidden_characters_cgi_context( ), 'tests_filter_forbidden_characters_cgi_context: no args -> undef' ) ; + is( '' , filter_forbidden_characters_cgi_context( '' ), 'tests_filter_forbidden_characters_cgi_context: empty string -> empty string' ) ; + + is( 'a______________b', filter_forbidden_characters_cgi_context( q{a*|?:(){}[]"<>'b} ), q{tests_filter_forbidden_characters_cgi_context: a*|?:"<>'b -> a________b} ) ; + + + is( 'a_b_' , filter_forbidden_characters_cgi_context( 'a b ' ), 'tests_filter_forbidden_characters_cgi_context: "a b " -> "a_b_"' ) ; + + is( 'a_b' , filter_forbidden_characters_cgi_context( "a\tb" ), 'tests_filter_forbidden_characters_cgi_context: a\tb -> a_b' ) ; + is( "a_b" , filter_forbidden_characters_cgi_context( "a\rb" ), 'tests_filter_forbidden_characters_cgi_context: a\rb -> a_b' ) ; + is( "a_b" , filter_forbidden_characters_cgi_context( "a\nb" ), 'tests_filter_forbidden_characters_cgi_context: a\nb -> a_b' ) ; + is( "a_b" , filter_forbidden_characters_cgi_context( "a\\b" ), 'tests_filter_forbidden_characters_cgi_context: a\b -> a_b' ) ; + + is( 'a-b' , filter_forbidden_characters_cgi_context( 'a-b' ), 'tests_filter_forbidden_characters_cgi_context: a-b -> a-b' ) ; + is( 'a__-__-__-__-__b' , filter_forbidden_characters_cgi_context( 'aé-è-à-ç-Öb' ), 'tests_filter_forbidden_characters_cgi_context: aé-è-à-ç-Öb -> a__-__-__-__-__b' ) ; + + is( 'abcd_ABCDwxyz-WXYZ012789' , filter_forbidden_characters_cgi_context( 'abcd_ABCDwxyz-WXYZ012789' ), + 'tests_filter_forbidden_characters_cgi_context: abcd_ABCDwxyz-WXYZ012789 -> abcd_ABCDwxyz-WXYZ012789' ) ; + + note( 'Leaving tests_filter_forbidden_characters()' ) ; + return ; } + + +sub filter_forbidden_characters_cgi_context +{ + my $string = shift @ARG ; + + if ( ! defined $string ) { return ; } + + $string =~ s{[^a-zA-Z0-9_-]}{_}xg ; + + #myprint( "[$string]\n" ) ; + return( $string ) ; +} + + sub tests_convert_sep_to_slash { note( 'Entering tests_convert_sep_to_slash()' ) ; @@ -13461,7 +15248,7 @@ sub tests_convert_sep_to_slash sub convert_sep_to_slash { - my ( $folder, $sep ) = @_ ; + my ( $folder, $sep ) = @ARG ; $folder =~ s{\Q$sep\E}{/}xg ; return( $folder ) ; @@ -13997,11 +15784,11 @@ EOM # 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'); + 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'); + 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'); @@ -14222,7 +16009,42 @@ caca\r Hello,\r Bye.\r EOM - ), 'regexmess: 8 remove buggy X-Spam-Report: across several lines, final header, with \r'); + ), 'regexmess: 8 remove buggy X-Spam-Report: across several lines, final header, with \r') ; + + + @regexmess = ( 's{\A(.*?(?! ^$))\n^Date:(.*?$)}{$1}gxms', 's{\A(.*?(?! ^$))^Received:(.*?);(.*?)$}{$1Received:$2;$3\nDate:$3}gxms' ) ; + is( +<<'EOM' +Haha: Couliii +Received: from smtp.lamiral.info (smtp.lamiral.info [91.121.221.224]) + by lamiral.info (Postfix) with ESMTPS id E065A5C0010 + for ; Sat, 28 Sep 2024 10:25:52 +0200 (CEST) +Date: Sat, 28 Sep 2024 10:25:52 +0200 (CEST) +Received: from idf.news.ffme.fr (idf.news.ffme.fr [185.245.221.25]) + by smtp.lamiral.info (Postfix) with ESMTPS id BAB2A3287BB2 + for ; Sat, 28 Sep 2024 08:25:51 +0000 (UTC) +From: + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +Haha: Couliii +Received: from smtp.lamiral.info (smtp.lamiral.info [91.121.221.224]) + by lamiral.info (Postfix) with ESMTPS id E065A5C0010 + for ; Sat, 28 Sep 2024 10:25:52 +0200 (CEST) +Received: from idf.news.ffme.fr (idf.news.ffme.fr [185.245.221.25]) + by smtp.lamiral.info (Postfix) with ESMTPS id BAB2A3287BB2 + for ; Sat, 28 Sep 2024 08:25:51 +0000 (UTC) +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + ), 'regexmess: date replaced by first received date' ) ; + undef @regexmess ; @@ -14232,7 +16054,7 @@ EOM sub regexmess { - my ( $string ) = @_ ; + my ( $string ) = @ARG ; foreach my $regexmess ( @regexmess ) { $sync->{ debug } and myprint( "eval \$string =~ $regexmess\n" ) ; my $ret = eval "\$string =~ $regexmess ; 1" ; @@ -14544,7 +16366,7 @@ EOM sub skipmess { - my ( $string ) = @_ ; + my ( $string ) = @ARG ; my $match ; #myprint( "$string\n" ) ; foreach my $skipmess ( @skipmess ) { @@ -14577,7 +16399,7 @@ sub tests_bytes_display_string_bin is( '0.010 KiB', bytes_display_string_bin( 10 ), 'bytes_display_string_bin: 10 => 0.010 KiB' ) ; is( '0.976 KiB', bytes_display_string_bin( 999 ), 'bytes_display_string_bin: 999 => 0.976 KiB' ) ; note( bytes_display_string_bin( 999 ) ) ; - + is( '0.999 KiB', bytes_display_string_bin( 1023 ), 'bytes_display_string_bin: 1023 => 0.999 KiB' ) ; note( bytes_display_string_bin( 1023 ) ) ; is( '1.000 KiB', bytes_display_string_bin( 1024 ), 'bytes_display_string_bin: 1024 => 1.000 KiB' ) ; @@ -14586,25 +16408,25 @@ sub tests_bytes_display_string_bin is( '9.999 KiB', bytes_display_string_bin( 10_239 ), 'bytes_display_string_bin: 10_239 => 9.999 KiB' ) ; note( bytes_display_string_bin( 10_239 ) ) ; - + is( '10.000 KiB', bytes_display_string_bin( 10_240 ), 'bytes_display_string_bin: 10_240 => 10.000 KiB' ) ; note( bytes_display_string_bin( 10_240 ) ) ; - + is( '999.999 KiB', bytes_display_string_bin( 1_023_999 ), 'bytes_display_string_bin: 1_023_999 => 999.999 KiB' ) ; note( bytes_display_string_bin( 1_023_999 ) ) ; - + is( '0.977 MiB', bytes_display_string_bin( 1_024_000 ), 'bytes_display_string_bin: 1_024_000 => 0.977 MiB' ) ; note( bytes_display_string_bin( 1_024_000 ) ) ; - + is( '0.999 MiB', bytes_display_string_bin( 1_047_527 ), 'bytes_display_string_bin: 1_047_527 => 0.999 MiB' ) ; - note( bytes_display_string_bin( 1_047_527 ) ) ; - + note( bytes_display_string_bin( 1_047_527 ) ) ; + is( '0.999 MiB', bytes_display_string_bin( 1_048_051 ), 'bytes_display_string_bin: 1_048_051 => 0.999 MiB' ) ; note( bytes_display_string_bin( 1_048_051 ) ) ; - + is( '1.000 MiB', bytes_display_string_bin( 1_048_052 ), 'bytes_display_string_bin: 1_048_052 => 1.000 MiB' ) ; note( bytes_display_string_bin( 1_048_052 ) ) ; - + is( '1.000 MiB', bytes_display_string_bin( 1_048_575 ), 'bytes_display_string_bin: 1_048_575 => 1.000 MiB' ) ; is( '1.000 MiB', bytes_display_string_bin( 1_048_576 ), 'bytes_display_string_bin: 1_048_576 => 1.000 MiB' ) ; @@ -14631,7 +16453,7 @@ sub tests_bytes_display_string_bin sub bytes_display_string_bin { - my ( $bytes ) = @_ ; + my ( $bytes ) = @ARG ; my $readable_value = q{} ; @@ -14682,12 +16504,12 @@ sub tests_bytes_display_string_dec is( '1 bytes', bytes_display_string_dec( 1 ), 'bytes_display_string_dec: 1 => 1 bytes' ) ; is( '10 bytes', bytes_display_string_dec( 10 ), 'bytes_display_string_dec: 10 => 10 bytes' ) ; is( '999 bytes', bytes_display_string_dec( 999 ), 'bytes_display_string_dec: 999 => 999 bytes' ) ; - + is( '1.000 KB', bytes_display_string_dec( 1000 ), 'bytes_display_string_dec: 1000 => 1.000 KB' ) ; is( '1.001 KB', bytes_display_string_dec( 1001 ), 'bytes_display_string_dec: 1000 => 1.1001 KB' ) ; - + is( '999.999 KB', bytes_display_string_dec( 999_999 ), 'bytes_display_string_dec: 999_999 => 999.999 KB' ) ; - + is( '1.000 MB', bytes_display_string_dec( 1_000_000 ), 'bytes_display_string_dec: 1_000_000 => 1.000 MB' ) ; is( '1.000 MB', bytes_display_string_dec( 1_000_500 ), 'bytes_display_string_dec: 1_000_500 => 1.000 MB' ) ; is( '1.001 MB', bytes_display_string_dec( 1_000_501 ), 'bytes_display_string_dec: 1_000_501 => 1.001 MB' ) ; @@ -14717,7 +16539,7 @@ sub tests_bytes_display_string_dec sub bytes_display_string_dec { - my ( $bytes ) = @_ ; + my ( $bytes ) = @ARG ; my $readable_value = q{} ; @@ -14779,7 +16601,7 @@ sub tests_useheader_suggestion sub useheader_suggestion { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! defined $mysync->{ h1_nb_msg_noheader } ) { return ; @@ -14795,36 +16617,56 @@ sub useheader_suggestion return ; } -sub do_and_print_stats -{ - my $mysync = shift ; - if ( ! $mysync->{can_do_stats} ) { +sub timeend_str +{ + my $timeend = shift @ARG ; # = time + my $timeend_str = localtimez( $timeend ) ; + return( $timeend_str ) ; +} + +sub timediff +{ + my $mysync = shift @ARG ; + my $timeend = shift @ARG ; # = time + my $timediff = $timeend - $mysync->{ timestart } ; + return( $timediff ) ; +} + + +sub do_and_print_stats +{ + my $mysync = shift @ARG ; + + if ( ! $mysync->{ can_do_stats } ) { return ; } - my $timeend = time ; - my $timediff = $timeend - $mysync->{timestart} ; - - my $timeend_str = localtimez( $timeend ) ; + my $timeend = time ; + my $timediff = timediff( $mysync, $timeend ) ; + my $timeend_str = timeend_str( $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_end = memory_consumption_of_myself( ) || 0 ; my $memory_consumption_at_start = $mysync->{ memory_consumption_at_start } || 0 ; 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 : $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" ) ; + myprint( "Folders deleted on host2 : $mysync->{ deleted_folders_host2 } $mysync->{ dry_message }\n" ) ; + if ( $mysync->{ deleted_folders_host2_failures } ) + { + myprint( "Folders failed to be deleted on host2 : $mysync->{ deleted_folders_host2_failures }\n" ) ; + } myprint( "Messages transferred : $mysync->{ nb_msg_transferred } " ) ; - myprint( "(could be $nb_msg_skipped_dry_mode without dry mode)" ) if ( $mysync->{dry} ) ; + myprint( "\t(could be $mysync->{ 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 : $mysync->{ acc1 }->{ nb_msg_duplicate }\n" ) ; @@ -14847,44 +16689,457 @@ sub do_and_print_stats $timediff ||= 1 ; # No division per 0 myprintf("Message rate : %.1f messages/s\n", $mysync->{nb_msg_transferred} / $timediff ) ; myprintf("Average bandwidth rate : %.1f KiB/s\n", $mysync->{total_bytes_transferred} / $KIBI / $timediff ) ; - myprint( "Reconnections to host1 : $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ; - myprint( "Reconnections to host2 : $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ; - myprintf("Memory consumption at the end : %.1f MiB (started with %.1f MiB)\n", + myprint( "Reconnections to host1 : $mysync->{ imap1 }->{IMAPSYNC_RECONNECT_COUNT}\n" ) ; + myprint( "Reconnections to host2 : $mysync->{ imap2 }->{IMAPSYNC_RECONNECT_COUNT}\n" ) ; + + myprintf("Memory consumption at the end : %.1f MiB (*time %.1f MiB*h) (started with %.1f MiB)\n", $memory_consumption_at_end / $KIBI / $KIBI, + memory_consumption_surface( $mysync, $memory_consumption_at_end, $timediff ), $memory_consumption_at_start / $KIBI / $KIBI ) ; + myprint( "Load end is : " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $mysync->{cpu_number} cores\n" ) ; 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_bin( $mysync->{ biggest_message_transferred } ) ) ; myprint( "Memory/biggest message ratio : $memory_ratio\n" ) ; - if ( $mysync->{ foldersizesatend } and $mysync->{ foldersizes } ) { - - - my $nb_msg_start_diff = diff_or_NA( $mysync->{ h2_nb_msg_start }, $mysync->{ h1_nb_msg_start } ) ; - my $bytes_start_diff = diff_or_NA( $mysync->{ h2_bytes_start }, $mysync->{ h1_bytes_start } ) ; + if ( $mysync->{ foldersizesatend } and $mysync->{ foldersizes } ) + { + my $nb_msg_start_diff = diff_or_NA( $mysync->{ h2_nb_msg_start }, $mysync->{ h1_nb_msg_start } ) ; + my $bytes_start_diff = diff_or_NA( $mysync->{ h2_bytes_start }, $mysync->{ h1_bytes_start } ) ; myprintf("Start difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_start_diff, - $bytes_start_diff, - bytes_display_string_bin( $bytes_start_diff ) ) ; + $bytes_start_diff, + bytes_display_string_bin( $bytes_start_diff ) ) ; - my $nb_msg_end_diff = diff_or_NA( $h2_nb_msg_end, $h1_nb_msg_end ) ; - my $bytes_end_diff = diff_or_NA( $h2_bytes_end, $h1_bytes_end ) ; + my $nb_msg_end_diff = diff_or_NA( $h2_nb_msg_end, $h1_nb_msg_end ) ; + my $bytes_end_diff = diff_or_NA( $h2_bytes_end, $h1_bytes_end ) ; myprintf("Final difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_end_diff, - $bytes_end_diff, - bytes_display_string_bin( $bytes_end_diff ) ) ; + $bytes_end_diff, + bytes_display_string_bin( $bytes_end_diff ) ) ; } comment_on_final_diff_in_1_not_in_2( $mysync ) ; comment_on_final_diff_in_2_not_in_1( $mysync ) ; - myprint( "Detected $mysync->{nb_errors} errors\n\n" ) ; + myprint( "Detected $mysync->{nb_errors} errors\n" ) ; myprint( $mysync->{ warn_release }, "\n" ) ; myprint( homepage( ), "\n" ) ; return ; +} + + + +sub tests_memory_consumption_surface +{ + note( 'Entering tests_memory_consumption_surface()' ) ; + + is( undef, memory_consumption_surface( ), 'memory_consumption_surface: no args => undef' ) ; + my $mysync = { } ; + is( undef, memory_consumption_surface( $mysync ), 'memory_consumption_surface: { } => undef' ) ; + is( "1.0", memory_consumption_surface( $mysync, 1_048_576, 3600 ), 'memory_consumption_surface: 1 MB 1 hour => 1' ) ; + is( "238.4", memory_consumption_surface( $mysync, 500_000_000, 1800 ), 'memory_consumption_surface: 500 MB 30 min => 238' ) ; + + + note( 'Leaving tests_memory_consumption_surface()' ) ; + return ; } +sub memory_consumption_surface +{ + my ( $mysync, $memory_consumption_at_end, $timediff ) = @ARG ; + + if ( ! all_defined( $mysync, $memory_consumption_at_end, $timediff ) ) { return } ; + + my $memory_consumption_surface = sprintf( "%.1f", $timediff * $memory_consumption_at_end / $KIBI / $KIBI / 3600 ) ; + + return $memory_consumption_surface ; +} + + + + +sub tests_email_report_message_id +{ + note( 'Entering tests_email_report_message_id()' ) ; + + local $ENV{TZ} = 'GMT' ; + + like( email_report_message_id( ), + qr{^...._.._.._.._.._.._...__\@imapsync.tk$}xms, + 'email_report_message_id: no args => ...._.._.._.._.._.._...__@imapsync.tk' ) ; + + my $mysync = { } ; + like( email_report_message_id( $mysync ), + qr{^...._.._.._.._.._.._...__\@imapsync.tk$}xms, + 'email_report_message_id: undef => ...._.._.._.._.._.._...__@imapsync.tk' ) ; + + $mysync->{ timestart } = 1357902468.531 ; + like( + email_report_message_id( $mysync ), + qr{^2013_01_11_\d\d_07_48_530__\@imapsync.tk$}xms, + 'email_report_message_id: 1357902468.531 => 2013_01_11_\d\d_07_48_530__@imapsync.tk' ) ; + + $mysync->{ user1 } = 'sarah' ; + $mysync->{ user2 } = 'haras' ; + $mysync->{ timestart } = 1357902468.531 ; + like( + email_report_message_id( $mysync ), + qr{^2013_01_11_\d\d_07_48_530_sarah_haras\@imapsync.tk$}xms, + 'email_report_message_id: 1357902468.531 sarah haras => 2013_01_11_\d\d_07_48_530_sarah_haras@imapsync.tk' ) ; + + $mysync->{ user1 } = 'sar@ah' ; + $mysync->{ user2 } = 'har@as' ; + $mysync->{ timestart } = 1357902468.531 ; + like( + email_report_message_id( $mysync ), + qr{2013_01_11_\d\d_07_48_530_sar_ah_har_as\@imapsync.tk}, + 'email_report_message_id: 1357902468.531 sar@ah har@as => 2013_01_11_\d\d_07_48_530_sar_ah_har_as@imapsync.tk' ) ; + + note( 'Leaving tests_email_report_message_id()' ) ; + return ; +} + + +sub email_report_message_id +{ + my $mysync = shift @ARG ; + + my $time = $mysync->{ timestart } || time ; + my $user1_filtered = $mysync->{ user1 } || '' ; + my $user2_filtered = $mysync->{ user2 } || '' ; + + # Nothing but alphanumeric characters and underscores to replace the others + $user1_filtered =~ s/[^a-zA-Z0-9]/_/g ; + $user2_filtered =~ s/[^a-zA-Z0-9]/_/g ; + + my $message_id = join( '', + year_month_day_hour_min_sec_ms( $time ), + '_', + $user1_filtered, + '_', + $user2_filtered, + '@imapsync.tk', + ) ; + return $message_id ; +} + + +sub tests_date_rfc822 +{ + note( 'Entering tests_email_report_date()' ) ; + + ok( date_rfc822( ), 'date_rfc822: no args => now: ' . date_rfc822( ) ) ; + + if ( 'MSWin32' eq $OSNAME ) + { + like( date_rfc822( 1671706800 ), qr{Thu, 22 Dec 2022 \d\d:00:00 \+0000}, 'date_rfc822: 1671706800 => Thu, 22 Dec 2022 \d\d:00:00 \+0000' ) ; + like( date_rfc822( 1671534000 ), qr{Tue, 20 Dec 2022 \d\d:00:00 \+0000}, 'date_rfc822: 1671534000 => Tue, 20 Dec 2022 \d\d:00:00 \+0000' ) ; + + } + else + { + local $ENV{TZ} = 'GMT' ; + is( 'Thu, 01 Jan 1970 00:00:00 +0000', date_rfc822( 0 ), 'date_rfc822: 0 => Thu, 01 Jan 1970 00:00:00 +0000' ) ; + is( 'Thu, 22 Dec 2022 11:00:00 +0000', date_rfc822( 1671706800 ), 'date_rfc822: 1671706800 => Thu, 22 Dec 2022 11:00:00 +0000' ) ; + } + note( 'Leaving tests_email_report_date()' ) ; + return ; +} + + + +sub date_rfc822 +{ + # Later I found Mail::IMAPCLient::Rfc822_date() + # https://metacpan.org/pod/Mail::IMAPClient#Rfc822_date + my $time = shift @ARG ; + $time = defined( $time ) ? $time : time ; + my $old_locale = POSIX::setlocale( POSIX::LC_TIME, "C" ) ; + + my $date_rfc822 ; + + if ( 'MSWin32' eq $OSNAME ) + { + $date_rfc822 = POSIX::strftime( "%a, %d %b %Y %H:%M:%S +0000", localtime( $time ) ) ; + } + else + { + $date_rfc822 = POSIX::strftime( "%a, %d %b %Y %H:%M:%S %z", localtime( $time ) ) ; + } + + POSIX::setlocale( POSIX::LC_TIME, $old_locale ) ; + return $date_rfc822 ; +} + + + +sub tests_email_report_from +{ + note( 'Entering tests_email_report_from()' ) ; + + is( 'help@imapsync.tk', email_report_from( ), 'email_report_from: no args => help@imapsync.tk' ) ; + my $mysync = { } ; + is( 'help@imapsync.tk', email_report_from( $mysync ), 'email_report_from: undef => help@imapsync.tk' ) ; + $mysync->{ email_report_from } = 'foo@example.com' ; + is( 'foo@example.com', email_report_from( $mysync ), 'email_report_from: foo@example.com => foo@example.com' ) ; + + note( 'Leaving tests_email_report_from()' ) ; + return ; +} + +sub email_report_from +{ + my $mysync = shift @ARG ; + + my $email_report_from = defined( $mysync->{ email_report_from } ) + ? $mysync->{ email_report_from } + : 'help@imapsync.tk' ; + + return $email_report_from ; +} + + +sub tests_email_report_to +{ + note( 'Entering tests_email_report_from()' ) ; + + is( 'unknown@imapsync.tk', email_report_to( ), 'email_report_to: no args => help@imapsync.tk' ) ; + my $mysync = { } ; + is( 'unknown@imapsync.tk', email_report_to( $mysync ), 'email_report_to: undef => help@imapsync.tk' ) ; + $mysync->{ user2 } = 'foo@example.com' ; + is( 'foo@example.com', email_report_to( $mysync ), 'email_report_to: foo@example.com => foo@example.com' ) ; + + note( 'Leaving tests_email_report_from()' ) ; + return ; +} + +sub email_report_to +{ + my $mysync = shift @ARG ; + + my $email_report_to = defined( $mysync->{ user2 } ) + ? $mysync->{ user2 } + : 'unknown@imapsync.tk' ; + + return $email_report_to ; +} + +sub email_report_subject +{ + my $mysync = shift @ARG ; + + my $email_report_subject = 'Imapsync transferred your account' ; + return $email_report_subject ; +} + +sub tests_email_report_body_base +{ + note( 'Entering tests_email_report_body_base()' ) ; + + is( '', email_report_body_base( ), 'email_report_body_base: no args => empty string' ) ; + my $mysync = { } ; + is( '', email_report_body_base( $mysync ), 'email_report_body_base: undef => empty string' ) ; + $mysync->{ user1 } = 'user1@example.com' ; + $mysync->{ user2 } = 'user2@example.com' ; + + note( email_report_body_base( $mysync ) ) ; + + note( 'Leaving tests_email_report_body_base()' ) ; + return ; +} + +sub email_report_body_base +{ + my $mysync = shift @ARG ; + + if( ! $mysync ) { return '' ; } + if( ! all_defined( + $mysync->{ user1 }, + $mysync->{ user2 }, + ) ) { return '' ; } + + my $email_report_body_base = <<"EOM"; +\r +\r +\r +Imapsync transfer from $mysync->{ user1 } to $mysync->{ user2 }\r +\r +\r +

Hello!

\r +

\r +Imapsync just ended the synchronization from the imap account $mysync->{ user1 } to the imap account $mysync->{ user2 }.
\r +

\r +EOM + return $email_report_body_base ; +} + +sub email_report_body_extra1 +{ + my $image = '' + .'imapsync website' + .'' + . "\r\n" + ; + return $image ; +} + + +sub email_report_body_extra2 +{ + my $image = '' + .'imapsync website' + .'' + . "\r\n" + ; + return $image ; +} + + + + + +sub email_report_html_begin +{ + return '' + . "\r\n" + ; +} + +sub email_report_html_end +{ + return '' + . "\r\n" + ; +} + +sub email_report_body_begin +{ + return '' + . "\r\n" + ; +} + +sub email_report_body_end +{ + return '' + . "\r\n" + ; +} + + +sub email_report_header +{ + my $mysync = shift @ARG ; + + my @header ; + + push( @header, join( "\r\n", + 'Message-Id: ' . email_report_message_id( $mysync ), + 'Date: ' . date_rfc822( time ), + 'From: ' . email_report_from( $mysync ), + 'To: ' . email_report_to( $mysync ), + 'Subject: ' . email_report_subject( $mysync ), + 'Content-Type: text/html', + "\r\n", + ) + ) ; + + return @header ; +} + + +sub tests_email_report +{ + note( 'Entering tests_email_report()' ) ; + + is( '', email_report( ), 'email_report: undef => empty string' ) ; + my $mysync = { } ; + $mysync->{ user1 } = 'user1@example.com' ; + $mysync->{ user2 } = 'user2@example.com' ; + + note( email_report( $mysync, "c'est extra !\r\n" ) ) ; + + note( 'Leaving tests_email_report()' ) ; + return ; +} + + +sub email_report +{ + my $mysync = shift @ARG ; + + my $extra = shift @ARG ; + + if ( ! defined $mysync ) { return '' ; } + + my @email_report = ( ) ; + + push( @email_report, email_report_header( $mysync ), + email_report_html_begin( ), + email_report_body_begin( ), + email_report_body_base( $mysync ), + $extra, + email_report_body_end( ), + email_report_html_end( ), + ) ; + + my $email_report = join( "", @email_report ) ; + + return $email_report ; +} + +sub email_report_append +{ + my $acc = shift @ARG ; + my $text = shift @ARG ; + + if ( $acc->{ imap }->IsAuthenticated && $text ) + { + my $newuid = $acc->{ imap }->append_string( 'INBOX', $text ) ; + if ( $newuid ) + { + myprint( "$acc->{ Side }: Successfully put the email final report in INBOX. Use --noemailreport" . $acc->{N} . " to avoid it.\n" ) ; + } + else + { + myprint( "$acc->{ Side }: Failed to put the email final report in INBOX. Use --noemailreport" . $acc->{N} . " to avoid it.\n" ) ; + } + return $newuid ; + } + else + { + return ; + } +} + + +sub final_emails_reports +{ + my $mysync = shift @ARG ; + + if ( condition_to_put_final_emails_reports( $mysync ) ) + { + $mysync->{ emailreport2 } and email_report_append( $mysync->{ acc2 }, email_report( $mysync, email_report_body_extra2( ) ) ) ; + $mysync->{ emailreport1 } and email_report_append( $mysync->{ acc1 }, email_report( $mysync, email_report_body_extra1( ) ) ) ; + } + + return ; +} + + +sub condition_to_put_final_emails_reports +{ + my $mysync = shift @ARG ; + + if ( $mysync->{ dry } ) { return 0 ; } + if ( $mysync->{ justfolders } ) { return 0 ; } + + return 1 ; +} + + sub diff_or_NA { my( $n1, $n2 ) = @ARG ; @@ -14985,14 +17240,14 @@ sub load_modules # Globals: $skipsize $wholeheaderifneeded sub parse_header_msg { - my ( $mysync, $imap, $m_uid, $s_heads, $s_fir, $side, $s_hash ) = @_ ; + my ( $mysync, $imap, $m_uid, $folder, $s_heads, $s_fir, $side, $s_hash ) = @ARG ; my $head = $s_heads->{$m_uid} ; my $headnum = scalar keys %{ $head } ; - $mysync->{ debug } and myprint( "$side: uid $m_uid number of headers, pass one: ", $headnum, "\n" ) ; + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid number of headers, pass one: ", $headnum, "\n" ) ; if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){ - $mysync->{ debug } and myprint( "$side: uid $m_uid no header by parse_headers so taking whole header with BODY.PEEK[HEADER]\n" ) ; + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid no header by parse_headers so taking whole header with BODY.PEEK[HEADER]\n" ) ; $imap->fetch($m_uid, 'BODY.PEEK[HEADER]' ) ; my $whole_header = $imap->_transaction_literals ; @@ -15000,16 +17255,14 @@ sub parse_header_msg $head = decompose_header( $whole_header ) ; $headnum = scalar keys %{ $head } ; - $mysync->{ debug } and myprint( "$side: uid $m_uid number of headers, pass two: ", $headnum, "\n" ) ; + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid number of headers, pass two: ", $headnum, "\n" ) ; } - #myprint( Data::Dumper->Dump( [ $head, \%useheader ] ) ) ; - - my $headstr = header_construct( $mysync, $head, $side, $m_uid ) ; + my $headstr = header_construct( $mysync, $head, $side, $folder, $m_uid ) ; if ( ( ! $headstr ) and ( $mysync->{addheader} ) and ( $side eq 'Host1' ) ) { my $header = add_header( $m_uid ) ; - $mysync->{ debug } and myprint( "$side: uid $m_uid no header found so adding our own [$header]\n" ) ; + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid no header found so adding our own [$header]\n" ) ; $headstr .= uc $header ; $s_fir->{$m_uid}->{NO_HEADER} = 1; } @@ -15037,7 +17290,7 @@ sub parse_header_msg 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" ) ; + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid sig $keydup size $size idate $idate dup @{ $dup_ref }\n" ) ; if ( $mysync->{ syncduplicates } ) { $s_hash->{"$keydup"}{'5'} = $m_md5 ; @@ -15056,7 +17309,7 @@ sub parse_header_msg $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" ) ; + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid sig $key size $size idate $idate\n" ) ; return( 1 ) ; } @@ -15064,7 +17317,7 @@ sub parse_header_msg return ; } -sub tests_header_construct +sub tests_header_construct { note( 'Entering tests_header_construct()' ) ; @@ -15073,39 +17326,38 @@ sub tests_header_construct 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' ) ; + is( undef, header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), 'header_construct: key1 val1_key1 no useheader => undef' ) ; + $mysync->{ useheader_h }->{ 'KEY1' } = 1 ; + is( 'KEY1: VAL1_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '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' ), + is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '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' ), + is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), 'header_construct: key1 val1_key1 val3_key1 val2_key1 => KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1' ) ; - $mysync->{useheader}->{ 'ALL' } = 1 ; + $mysync->{ useheader_h }->{ 'ALL' } = 1 ; - is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', '1' ), + is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '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' ), + is( undef, header_construct( $mysync, $head, 'Host1', 'INBOX', '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' ), + is( 'KEY2: VAL1_KEY2KEY2: VAL2_KEY2KEY2: VAL3_KEY2', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), 'header_construct: ... useheader ALL skipheader key1 => KEY2: VAL1_KEY2KEY2: VAL2_KEY2KEY2: VAL3_KEY2' ) ; @@ -15115,24 +17367,26 @@ sub tests_header_construct # No global in header_construct -sub header_construct +sub header_construct { - my( $mysync, $head, $side, $m_uid ) = @_ ; + my( $mysync, $head, $side, $folder, $m_uid ) = @ARG ; my @headstr ; - foreach my $h ( sort keys %{ $head } ) { - next if ( not ( exists $mysync->{useheader}->{ uc $h } ) - and ( not exists $mysync->{useheader}->{ 'ALL' } ) + foreach my $h ( sort keys %{ $head } ) + { + next if ( not ( exists $mysync->{ useheader_h }->{ uc $h } ) + and ( not exists $mysync->{ useheader_h }->{ 'ALL' } ) ) ; - foreach my $val ( @{$head->{$h}} ) { + foreach my $val ( @{ $head->{ $h } } ) + { my $H = header_line_normalize( $h, $val ) ; # show stuff in debug mode - $mysync->{ debug } and myprint( "$side uid $m_uid header [$H]", "\n" ) ; + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid header [$H]", "\n" ) ; - if ( $mysync->{skipheader} and $H =~ m/$mysync->{skipheader}/xi) { - $mysync->{ 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: folder/uid $folder/$m_uid skipping header [$H]\n" ) ; next ; } push @headstr, $H ; @@ -15140,12 +17394,12 @@ sub header_construct } my $headstr = join( '', sort @headstr ) || undef ; return( $headstr ) ; -} +} sub header_line_normalize { - my( $header_key, $header_val ) = @_ ; + my( $header_key, $header_val ) = @ARG ; # no 8-bit data in headers ! $header_val =~ s/[\x80-\xff]/X/xog; @@ -15191,36 +17445,82 @@ sub tests_header_line_normalize } -sub tests_firstline + +sub tests_firstline_or_string +{ + note( 'Entering tests_firstline_or_string()' ) ; + + is( undef, firstline_or_string( ), 'tests_firstline_or_string: no args => undef' ) ; + + is( q{please, give a value}, firstline_or_string( q{} ), 'tests_firstline_or_string: empty string => please, give a value' ) ; + + is( q{W/tmp/tests/noexist.txt}, firstline_or_string( 'W/tmp/tests/noexist.txt' ), 'tests_firstline_or_string: get W/tmp/tests/noexist.txt string from inexisting W/tmp/tests/noexist.txt' ) ; + + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'tests_firstline_or_string: mkpath W/tmp/tests/' ) ; + + is( "blabla\n" , string_to_file( "blabla\n", 'W/tmp/tests/firstline.txt' ), 'tests_firstline_or_string: put blabla in W/tmp/tests/firstline.txt' ) ; + is( 'blabla' , firstline_or_string( 'W/tmp/tests/firstline.txt' ), 'tests_firstline_or_string: get blabla from W/tmp/tests/firstline.txt' ) ; + + + note( 'Leaving tests_firstline_or_string()' ) ; + return ; +} + + +sub firstline_or_string +{ + my $file = shift @ARG ; + + if ( ! defined $file ) { return ; } + + my $string ; + + if ( -f -r $file ) + { + myprint( "Reading first line of file $file\n" ) ; + $string = firstline( $file ) ; + } + else + { + myprint( "Taking string $file as the value since it is not a file\n" ) ; + $string = $file || 'please, give a value' ; + } + + return $string ; +} + + +sub tests_firstline { note( 'Entering tests_firstline()' ) ; - is( q{}, firstline( 'W/tmp/tests/noexist.txt' ), 'firstline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; + is( q{}, firstline( 'W/tmp/tests/noexist.txt' ), 'tests_firstline: get empty string from inexisting W/tmp/tests/noexist.txt' ) ; - ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'firstline: mkpath W/tmp/tests/' ) ; + my $mysync = { } ; + ok( (-d 'W/tmp/tests/' or make_valid_directory( $mysync, 'W/tmp/tests/' ) ), 'tests_firstline: make_valid_directory W/tmp/tests/' ) ; - is( "blabla\n" , string_to_file( "blabla\n", 'W/tmp/tests/firstline.txt' ), 'firstline: put blabla in W/tmp/tests/firstline.txt' ) ; - is( 'blabla' , firstline( 'W/tmp/tests/firstline.txt' ), 'firstline: get blabla from W/tmp/tests/firstline.txt' ) ; + is( "blabla\n" , string_to_file( "blabla\n", 'W/tmp/tests/firstline.txt' ), 'tests_firstline: put blabla in W/tmp/tests/firstline.txt' ) ; + is( 'blabla' , firstline( 'W/tmp/tests/firstline.txt' ), 'tests_firstline: get blabla from W/tmp/tests/firstline.txt' ) ; - is( q{} , string_to_file( q{}, 'W/tmp/tests/firstline2.txt' ), 'firstline: put empty string in W/tmp/tests/firstline2.txt' ) ; - is( q{} , firstline( 'W/tmp/tests/firstline2.txt' ), 'firstline: get empty string from W/tmp/tests/firstline2.txt' ) ; + is( q{} , string_to_file( q{}, 'W/tmp/tests/firstline2.txt' ), 'tests_firstline: put empty string in W/tmp/tests/firstline2.txt' ) ; + is( q{} , firstline( 'W/tmp/tests/firstline2.txt' ), 'tests_firstline: get empty string from W/tmp/tests/firstline2.txt' ) ; - is( "\n" , string_to_file( "\n", 'W/tmp/tests/firstline3.txt' ), 'firstline: put CR in W/tmp/tests/firstline3.txt' ) ; - is( q{} , firstline( 'W/tmp/tests/firstline3.txt' ), 'firstline: get empty string from W/tmp/tests/firstline3.txt' ) ; + is( "\n" , string_to_file( "\n", 'W/tmp/tests/firstline3.txt' ), 'tests_firstline: put CR in W/tmp/tests/firstline3.txt' ) ; + is( q{} , firstline( 'W/tmp/tests/firstline3.txt' ), 'tests_firstline: get empty string from W/tmp/tests/firstline3.txt' ) ; - is( "blabla\nTiti\n" , string_to_file( "blabla\nTiti\n", 'W/tmp/tests/firstline4.txt' ), 'firstline: put blabla\nTiti\n in W/tmp/tests/firstline4.txt' ) ; - is( 'blabla' , firstline( 'W/tmp/tests/firstline4.txt' ), 'firstline: get blabla from W/tmp/tests/firstline4.txt' ) ; + is( "blabla\nTiti\n" , string_to_file( "blabla\nTiti\n", 'W/tmp/tests/firstline4.txt' ), 'tests_firstline: put blabla\nTiti\n in W/tmp/tests/firstline4.txt' ) ; + is( 'blabla' , firstline( 'W/tmp/tests/firstline4.txt' ), 'tests_firstline: get blabla from W/tmp/tests/firstline4.txt' ) ; note( 'Leaving tests_firstline()' ) ; return ; -} +} sub firstline { # extract the first line of a file (without \n) # return empty string if error or empty string - my $file = shift ; + my $file = shift @ARG ; my $line ; $line = nthline( $file, 1 ) ; @@ -15229,7 +17529,7 @@ sub firstline -sub tests_secondline +sub tests_secondline { note( 'Entering tests_secondline()' ) ; @@ -15241,10 +17541,12 @@ sub tests_secondline is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/secondline.txt' ), 'secondline: put L1\nL2\nL3\nL4\n in W/tmp/tests/secondline.txt' ) ; is( 'L2' , secondline( 'W/tmp/tests/secondline.txt' ), 'secondline: get L2 from W/tmp/tests/secondline.txt' ) ; + is( "L1\n" , string_to_file( "L1\n", 'W/tmp/tests/secondline2.txt' ), 'secondline: put L1\n in W/tmp/tests/secondline2.txt' ) ; + is( '' , secondline( 'W/tmp/tests/secondline2.txt' ), 'secondline: get empty string from W/tmp/tests/secondline2.txt' ) ; note( 'Leaving tests_secondline()' ) ; return ; -} +} sub secondline @@ -15252,7 +17554,7 @@ sub secondline # extract the second line of a file (without \n) # return empty string if error or empty string - my $file = shift ; + my $file = shift @ARG ; my $line ; $line = nthline( $file, 2 ) ; @@ -15284,8 +17586,8 @@ sub nthline # extract the nth line of a file (without \n) # return empty string if error or empty string - my $file = shift ; - my $num = shift ; + my $file = shift @ARG ; + my $num = shift @ARG ; if ( ! all_defined( $file, $num ) ) { return q{} ; } @@ -15322,12 +17624,12 @@ sub tests_file_to_array sub file_to_array { - my( $file ) = shift ; + my( $file ) = shift @ARG ; if ( ! $file ) { return ; } if ( ! -e $file ) { return ; } if ( ! -f $file ) { return ; } if ( ! -r $file ) { return ; } - + my @string ; if ( open my $FILE, '<', $file ) @@ -15367,12 +17669,12 @@ sub tests_file_to_string sub file_to_string { - my $file = shift ; + my $file = shift @ARG ; if ( ! $file ) { return ; } if ( ! -e $file ) { return ; } if ( ! -f $file ) { return ; } if ( ! -r $file ) { return ; } - + return( join q{}, file_to_array( $file ) ) ; } @@ -15385,6 +17687,7 @@ sub tests_string_to_file is( undef, string_to_file( 'lalala' ), 'string_to_file: one arg => undef' ) ; is( undef, string_to_file( 'lalala', '.' ), 'string_to_file: writing a directory => undef' ) ; ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'string_to_file: mkpath W/tmp/tests/' ) ; + ok( (-d 'W/tmp/tests/' and chmod( 755, 'W/tmp/tests/' ) ), 'string_to_file: chmod 755 W/tmp/tests/' ) ; is( 'lalala', string_to_file( 'lalala', 'W/tmp/tests/canbewritten' ), 'string_to_file: W/tmp/tests/canbewritten with lalala' ) ; is( q{}, string_to_file( q{}, 'W/tmp/tests/empty' ), 'string_to_file: W/tmp/tests/empty with empty string' ) ; @@ -15400,11 +17703,12 @@ sub tests_string_to_file sub string_to_file { - my( $string, $file ) = @_ ; + my( $string, $file ) = @ARG ; if( ! defined $string ) { return ; } if( ! defined $file ) { return ; } - if ( ! -e $file && ! -w dirname( $file ) ) { + if ( ! -e $file && ! -w dirname( $file ) ) + { myprint( "string_to_file: directory of $file is not writable\n" ) ; return ; } @@ -15418,26 +17722,23 @@ sub string_to_file return $string ; } -0 and <<'MULTILINE_COMMENT' ; -This is a multiline comment. -Based on David Carter discussion, to do: -* Call parameters stay the same. -* Now always "return( $string, $error )". Descriptions below. -OK * Still capture STDOUT via "1> $output_tmpfile" to finish in $string and "return( $string, $error )" -OK * Now also capture STDERR via "2> $error_tmpfile" to finish in $error and "return( $string, $error )" -OK * in case of CHILD_ERROR, return( undef, $error ) - and print $error, with folder/UID/maybeSubject context, - on console and at the end with the final error listing. Count this as a sync error. -* in case of good command, take final $string as is, unless void. In case $error with value then print it. -* in case of good command and final $string empty, consider it like CHILD_ERROR => - return( undef, $error ) and print $error, with folder/UID/maybeSubject context, - on console and at the end with the final error listing. Count this as a sync error. -MULTILINE_COMMENT -# End of multiline comment. + +# * Call parameters stay the same. +# * Now always "return( $string, $error )". Descriptions below. +# OK * Still capture STDOUT via "1> $output_tmpfile" to finish in $string and "return( $string, $error )" +# OK * Now also capture STDERR via "2> $error_tmpfile" to finish in $error and "return( $string, $error )" +# OK * in case of CHILD_ERROR, return( undef, $error ) +# and print $error, with folder/UID/maybeSubject context, +# on console and at the end with the final error listing. Count this as a sync error. +# * in case of good command, take final $string as is, unless void. In case $error with value then print it. +# * in case of good command and final $string empty, consider it like CHILD_ERROR => +# return( undef, $error ) and print $error, with folder/UID/maybeSubject context, +# on console and at the end with the final error listing. Count this as a sync error. + sub pipemess { - my ( $string, @commands ) = @_ ; + my ( $string, @commands ) = @ARG ; my $error = q{} ; foreach my $command ( @commands ) { my $input_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.inp.txt" ; @@ -15469,17 +17770,22 @@ sub pipemess myprint( qq{STDERR of --pipemess "$command": $error_cmd\n} ) ; } } + #myprint( "[$string]\n" ) ; - if ( wantarray ) { - return ( $string, $error ) ; - }else{ - return $string ; + + if ( wantarray ) + { + return( $string, $error ) ; + } + else + { + return( $string ) ; } } -sub tests_pipemess +sub tests_pipemess { note( 'Entering tests_pipemess()' ) ; @@ -15490,11 +17796,11 @@ sub tests_pipemess # Windows # "type" command does not accept redirection of STDIN with < # "sort" does - ok( "nochange\n" eq pipemess( 'nochange', 'sort' ), 'pipemess: nearly no change by sort' ) ; - ok( "nochange2\n" eq pipemess( 'nochange2', qw( sort sort ) ), 'pipemess: nearly no change by sort,sort' ) ; + ok( "nochange\n" eq pipemess( 'nochange', 'sort' ), 'tests_pipemess: nearly no change by sort' ) ; + ok( "nochange2\n" eq pipemess( 'nochange2', qw( sort sort ) ), 'tests_pipemess: nearly no change by sort,sort' ) ; # command not found #diag( 'Warning and failure about cacaprout are on purpose' ) ; - ok( ! defined( pipemess( q{}, 'cacaprout' ) ), 'pipemess: command not found' ) ; + ok( ! defined( pipemess( q{}, 'cacaprout' ) ), 'tests_pipemess: command not found' ) ; } ; @@ -15504,75 +17810,75 @@ sub tests_pipemess Readonly my $NB_UNX_tests_pipemess => 25 ; skip( 'Not on Unix', $NB_UNX_tests_pipemess ) if ('MSWin32' eq $OSNAME) ; # Unix - ok( 'nochange' eq pipemess( 'nochange', 'cat' ), 'pipemess: no change by cat' ) ; + ok( 'nochange' eq pipemess( 'nochange', 'cat' ), 'tests_pipemess: no change by cat' ) ; - ok( 'nochange2' eq pipemess( 'nochange2', 'cat', 'cat' ), 'pipemess: no change by cat,cat' ) ; + ok( 'nochange2' eq pipemess( 'nochange2', 'cat', 'cat' ), 'tests_pipemess: no change by cat,cat' ) ; - ok( " 1\tnumberize\n" eq pipemess( "numberize\n", 'cat -n' ), 'pipemess: numberize by cat -n' ) ; - ok( " 1\tnumberize\n 2\tnumberize\n" eq pipemess( "numberize\nnumberize\n", 'cat -n' ), 'pipemess: numberize by cat -n' ) ; + ok( " 1\tnumberize\n" eq pipemess( "numberize\n", 'cat -n' ), 'tests_pipemess: numberize by cat -n' ) ; + ok( " 1\tnumberize\n 2\tnumberize\n" eq pipemess( "numberize\nnumberize\n", 'cat -n' ), 'tests_pipemess: numberize by cat -n' ) ; - ok( "A\nB\nC\n" eq pipemess( "A\nC\nB\n", 'sort' ), 'pipemess: sort' ) ; + ok( "A\nB\nC\n" eq pipemess( "A\nC\nB\n", 'sort' ), 'tests_pipemess: sort' ) ; # command not found #diag( 'Warning and failure about cacaprout are on purpose' ) ; - is( undef, pipemess( q{}, 'cacaprout' ), 'pipemess: command not found' ) ; + is( undef, pipemess( q{}, 'cacaprout' ), 'tests_pipemess: command not found' ) ; # success with true but no output at all - is( undef, pipemess( q{blabla}, 'true' ), 'pipemess: true but no output' ) ; + is( undef, pipemess( q{blabla}, 'true' ), 'tests_pipemess: true but no output' ) ; # failure with false and no output at all - is( undef, pipemess( q{blabla}, 'false' ), 'pipemess: false and no output' ) ; + is( undef, pipemess( q{blabla}, 'false' ), 'tests_pipemess: false and no output' ) ; # Failure since pipemess is not a real pipe, so first cat wait for standard input - is( q{blabla}, pipemess( q{blabla}, '( cat|cat ) ' ), 'pipemess: ok by ( cat|cat )' ) ; + is( q{blabla}, pipemess( q{blabla}, '( cat|cat ) ' ), 'tests_pipemess: ok by ( cat|cat )' ) ; ( $stringT, $errorT ) = pipemess( 'nochange', 'cat' ) ; - is( $stringT, 'nochange', 'pipemess: list context, no change by cat, string' ) ; - is( $errorT, q{}, 'pipemess: list context, no change by cat, no error' ) ; + is( $stringT, 'nochange', 'tests_pipemess: list context, no change by cat, string' ) ; + is( $errorT, q{}, 'tests_pipemess: list context, no change by cat, no error' ) ; ( $stringT, $errorT ) = pipemess( 'dontcare', 'true' ) ; - is( $stringT, undef, 'pipemess: list context, true but no output, string' ) ; - like( $errorT, qr{\QFailure: --pipemess command "true" ended with "0" characters exit value "0" and STDERR ""\E}xm, 'pipemess: list context, true but no output, error' ) ; + is( $stringT, undef, 'tests_pipemess: list context, true but no output, string' ) ; + like( $errorT, qr{\QFailure: --pipemess command "true" ended with "0" characters exit value "0" and STDERR ""\E}xm, 'tests_pipemess: list context, true but no output, error' ) ; ( $stringT, $errorT ) = pipemess( 'dontcare', 'false' ) ; - is( $stringT, undef, 'pipemess: list context, false and no output, string' ) ; + is( $stringT, undef, 'tests_pipemess: list context, false and no output, string' ) ; like( $errorT, qr{\QFailure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""\E}xm, - 'pipemess: list context, false and no output, error' ) ; + 'tests_pipemess: list context, false and no output, error' ) ; ( $stringT, $errorT ) = pipemess( 'dontcare', '/bin/echo -n blablabla' ) ; - is( $stringT, q{blablabla}, 'pipemess: list context, "echo -n blablabla", string' ) ; - is( $errorT, q{}, 'pipemess: list context, "echo blablabla", error' ) ; + is( $stringT, q{blablabla}, 'tests_pipemess: list context, "echo -n blablabla", string' ) ; + is( $errorT, q{}, 'tests_pipemess: list context, "echo blablabla", error' ) ; ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ; - is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla", string' ) ; - like( $errorT, qr{blablabla"}xm, 'pipemess: list context, "no output STDERR blablabla", error' ) ; + is( $stringT, undef, 'tests_pipemess: list context, "no output STDERR blablabla", string' ) ; + like( $errorT, qr{blablabla"}xm, 'tests_pipemess: list context, "no output STDERR blablabla", error' ) ; ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )', 'false' ) ; - is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla then false", string' ) ; - like( $errorT, qr{blablabla"}xm, 'pipemess: list context, "no output STDERR blablabla then false", error' ) ; + is( $stringT, undef, 'tests_pipemess: list context, "no output STDERR blablabla then false", string' ) ; + like( $errorT, qr{blablabla"}xm, 'tests_pipemess: list context, "no output STDERR blablabla then false", error' ) ; ( $stringT, $errorT ) = pipemess( 'dontcare', 'false', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ; - is( $stringT, undef, 'pipemess: list context, "false then STDERR blablabla", string' ) ; + is( $stringT, undef, 'tests_pipemess: list context, "false then STDERR blablabla", string' ) ; like( $errorT, qr{\QFailure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""\E}xm, - 'pipemess: list context, "false then STDERR blablabla", error' ) ; + 'tests_pipemess: list context, "false then STDERR blablabla", error' ) ; ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo rrrrr ; echo -n error_blablabla 3>&1 1>&2 2>&3 )' ) ; - like( $stringT, qr{rrrrr}xm, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", string' ) ; - like( $errorT, qr{STDERR.*error_blablabla}xm, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", error' ) ; + like( $stringT, qr{rrrrr}xm, 'tests_pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", string' ) ; + like( $errorT, qr{STDERR.*error_blablabla}xm, 'tests_pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", error' ) ; } ( $stringT, $errorT ) = pipemess( 'dontcare', 'cacaprout' ) ; - is( $stringT, undef, 'pipemess: list context, cacaprout not found, string' ) ; + is( $stringT, undef, 'tests_pipemess: list context, cacaprout not found, string' ) ; like( $errorT, qr{\QFailure: --pipemess command "cacaprout" ended with "0" characters exit value\E}xm, - 'pipemess: list context, cacaprout not found, error' ) ; + 'tests_pipemess: list context, cacaprout not found, error' ) ; note( 'Leaving tests_pipemess()' ) ; return ; -} +} @@ -15592,7 +17898,7 @@ sub tests_is_a_release_number sub is_a_release_number { - my $number = shift ; + my $number = shift @ARG ; if ( ! defined $number ) { return ; } return( $number =~ m{^\d+\.\d+$}xo ) ; } @@ -15631,7 +17937,7 @@ sub not_long_imapsync_version_public { #myprint( "Entering not_long_imapsync_version_public\n" ) ; - my $fake = shift ; + my $fake = shift @ARG ; if ( $fake ) { return $fake } my $val ; @@ -15688,7 +17994,7 @@ sub tests_not_long_imapsync_version_public sub check_last_release { - my $fake = shift ; + my $fake = shift @ARG ; my $public_release = not_long_imapsync_version_public( $fake ) ; $sync->{ debug } and myprint( "check_last_release: [$public_release]\n" ) ; my $inline_help_when_on = '( Use --noreleasecheck to avoid this release check. )' ; @@ -15747,7 +18053,7 @@ sub tests_imapsync_context sub imapsync_context { - my $mysync = shift ; + my $mysync = shift @ARG ; my $context = q{} ; @@ -15774,7 +18080,7 @@ sub imapsync_context sub imapsync_version { - my $mysync = shift ; + my $mysync = shift @ARG ; my $rcs = $mysync->{rcs} ; my $version ; @@ -15799,7 +18105,7 @@ sub tests_version_from_rcs sub version_from_rcs { - my $rcs = shift ; + my $rcs = shift @ARG ; if ( ! $rcs ) { return ; } my $version = 'UNKNOWN' ; @@ -15833,12 +18139,12 @@ sub imapsync_basename sub localhost_info { - my $mysync = shift ; + my $mysync = shift @ARG ; my( $infos ) = join( q{}, "Here is imapsync ", imapsync_version( $mysync ), - " on host " . hostname(), + " $PROGRAM_NAME on host " . hostname(), ", a $OSNAME system with ", - ram_memory_info( ), + ram_memory_info( $mysync ), "\n", 'with Perl ', mysprintf( '%vd ', $PERL_VERSION), @@ -15847,16 +18153,16 @@ sub localhost_info return( $infos ) ; } -sub tests_cpu_number +sub tests_cpu_number { note( 'Entering tests_cpu_number()' ) ; - 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" ) ; + is( 1, is_integer( cpu_number( ) ), "tests_cpu_number: is_integer" ) ; + ok( 1 <= cpu_number( ), "tests_cpu_number: 1 or more" ) ; + is( 1, cpu_number( 1 ), "tests_cpu_number: 1 => 1" ) ; + is( 1, cpu_number( $MINUS_ONE ), "tests_cpu_number: -1 => 1" ) ; + is( 1, cpu_number( 'lalala' ), "tests_cpu_number: lalala => 1" ) ; + is( $NUMBER_42, cpu_number( $NUMBER_42 ), "tests_cpu_number: $NUMBER_42 => $NUMBER_42" ) ; note( "cpu_number = " . cpu_number( ) . "\n" ) ; note( "hostname = " . hostname( ) . "\n" ) ; @@ -15865,15 +18171,16 @@ sub tests_cpu_number { skip( 'cpu_number on host != i005 (FreeBSD)', 1 ) ; } - is( 4, cpu_number( ), "cpu_number: on i005 (FreeBSD) => 4" ) ; + is( 4, cpu_number( ), "tests_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" ) ; + #is( 2, cpu_number( ), "tests_cpu_number: on petite (Linux) => 2" ) ; + is( 1, cpu_number( 1 ), "tests_cpu_number: on petite (Linux) => 1" ) ; } ; SKIP: { @@ -15881,34 +18188,35 @@ sub tests_cpu_number { 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" ) ; + is( 2, cpu_number( ), "tests_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" ) ; + is( 2, cpu_number( ), "tests_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" ) ; + is( 1, cpu_number( ), "tests_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 ; + my $cpu_number_forced = shift @ARG ; # Well, here 1 is better than 0 or undef my $cpu_number = 1 ; # Default value, erased if better found @@ -15919,33 +18227,33 @@ sub cpu_number { $cpu_number = $ENV{"NUMBER_OF_PROCESSORS"} ; #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 ) ; #myprint( "Number of processors found by cmd 'sysctl -n hw.ncpu': $cpu_number\n" ) ; } - + 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 ) ) ; } @@ -15965,7 +18273,7 @@ sub tests_integer_or_1 sub integer_or_1 { - my $number = shift ; + my $number = shift @ARG ; if ( is_integer( $number ) ) { return $number ; } @@ -15994,7 +18302,7 @@ sub tests_is_integer sub is_integer { - my $number = shift ; + my $number = shift @ARG ; if ( ! defined $number ) { return ; } return( $number =~ m{^\d+$}xo ) ; } @@ -16009,7 +18317,7 @@ sub tests_loadavg SKIP: { skip( 'Tests for darwin', 3 ) if ('darwin' ne $OSNAME) ; is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ; - is_deeply( + is_deeply( [ '0.11', '0.22', '0.33' ], [ loadavg( 'vm.loadavg: { 0.11 0.22 0.33 }' ) ], 'loadavg: "vm.loadavg: { 0.11 0.22 0.33 }" => 0.11 0.22 0.33' @@ -16042,16 +18350,20 @@ sub tests_loadavg sub loadavg { - if ( 'linux' eq $OSNAME ) { + if ( 'linux' eq $OSNAME ) + { return ( loadavg_linux( @ARG ) ) ; } - if ( 'freebsd' eq $OSNAME ) { + if ( 'freebsd' eq $OSNAME ) + { return ( loadavg_freebsd( @ARG ) ) ; } - if ( 'darwin' eq $OSNAME ) { + if ( 'darwin' eq $OSNAME ) + { return ( loadavg_darwin( @ARG ) ) ; } - if ( 'MSWin32' eq $OSNAME ) { + if ( 'MSWin32' eq $OSNAME ) + { return ( loadavg_windows( @ARG ) ) ; } return( 'unknown' ) ; @@ -16059,14 +18371,16 @@ sub loadavg sub loadavg_linux { - my $line = shift ; + my $line = shift @ARG ; - if ( ! $line ) { + if ( ! $line ) + { $line = firstline( '/proc/loadavg' ) or return ; } my ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) = split /\s/mxs, $line ; - if ( all_defined( $avg_1_min, $avg_5_min, $avg_15_min ) ) { + if ( all_defined( $avg_1_min, $avg_5_min, $avg_15_min ) ) + { $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min $current_runs\n" ) ; return ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) ; } @@ -16075,18 +18389,21 @@ sub loadavg_linux sub loadavg_freebsd { - my $file = shift ; + my $file = shift @ARG ; # Example of output of command "sysctl vm.loadavg": # vm.loadavg: { 0.15 0.08 0.08 } my $loadavg ; - if ( ! defined $file ) { + if ( ! defined $file ) + { eval { - $loadavg = `/sbin/sysctl vm.loadavg` ; + $loadavg = `LANG=C /sbin/sysctl vm.loadavg` ; #myprint( "LOADAVG FREEBSD: $loadavg\n" ) ; } ; if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; } - }else{ + } + else + { $loadavg = firstline( $file ) or return ; } @@ -16098,15 +18415,16 @@ sub loadavg_freebsd sub loadavg_darwin { - my $line = shift ; + my $line = shift @ARG ; # Example of output of command "sysctl vm.loadavg": # vm.loadavg: { 0.15 0.08 0.08 } my $loadavg ; - if ( ! defined $line ) { + if ( ! defined $line ) + { eval { # $loadavg = `/usr/sbin/sysctl vm.loadavg` ; - $loadavg = `LANG= /usr/sbin/sysctl vm.loadavg` ; + $loadavg = `LANG=C /usr/sbin/sysctl vm.loadavg` ; #myprint( "LOADAVG DARWIN: $loadavg\n" ) ; } ; if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; } @@ -16122,13 +18440,14 @@ sub loadavg_darwin sub loadavg_windows { - my $file = shift ; + my $file = shift @ARG ; # Example of output of command "wmic cpu get loadpercentage": # LoadPercentage # 12 my $loadavg ; - if ( ! defined $file ) { + if ( ! defined $file ) + { eval { #$loadavg = `CMD wmic cpu get loadpercentage` ; $loadavg = "LoadPercentage\n0\n" ; @@ -16152,69 +18471,94 @@ sub loadavg_windows -sub tests_load_and_delay +sub tests_load_and_delay { note( 'Entering 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( undef, load_and_delay( ), 'load_and_delay: no args => undef ' ) ; + is( undef, load_and_delay( 1, 2 ), 'load_and_delay: not 3 args => undef ' ) ; + is( undef, load_and_delay( 2, 0, 1, 1, 1 ), 'load_and_delay: division per 0 => undef ' ) ; -# ( $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) +# ( $max_load_per_core, $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) - 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 ' ) ; + # load max = 1 per cpu + is( 0, load_and_delay( 1, 1, 0 ), 'load_and_delay: max=1, one core, loads is 0 => ok ' ) ; + is( 0, load_and_delay( 1, 1, 0, 0, 0 ), 'load_and_delay: max=1, one core, loads are all 0 => ok ' ) ; + is( 0, load_and_delay( 3, 1, 1, 1, 1, 1 ), 'load_and_delay: six arguments => ok' ) ; + is( 0, load_and_delay( 1, 2, 1, 1, 1 ), 'load_and_delay: max=1, two core, loads are all 1 => ok ' ) ; + is( 0, load_and_delay( 1, 2, 1, 4, 5 ), 'load_and_delay: max=1, two core, load1m is 1 => ok ' ) ; + is( 0, load_and_delay( 1, 1, 0, 0, 0 ), 'load_and_delay: max=1, one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, 0, 0, 2 ), 'load_and_delay: max=1, one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, 0, 2, 0 ), 'load_and_delay: max=1, one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, 0, 2, 2 ), 'load_and_delay: max=1, one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, 0, 3, 3 ), 'load_and_delay: max=1, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, 0, 4, 4 ), 'load_and_delay: max=1, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, .2, 0, 0 ), 'load_and_delay: max=1, one core, load1m=.2 load5m=0 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, .2, 0, .2 ), 'load_and_delay: max=1, one core, load1m=.2 load5m=0 load15m=.2 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, .2, .2, 0 ), 'load_and_delay: max=1, one core, load1m=2 load5m=2 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, .2, .2, .2 ), 'load_and_delay: max=1, one core, load1m=.2 load5m=.2 load15m=.2 => 0 ' ) ; + is( 1, load_and_delay( 1, 1, 1, 0, 0 ), 'load_and_delay: max=1, one core, load1m=3 load5m=0 load15m=0 => 0 ' ) ; + is( 1, load_and_delay( 1, 1, 1, .9, .9 ), 'load_and_delay: max=1, one core, load1m=3 load5m=.9 load15m=.9 => 0 ' ) ; + is( 5, load_and_delay( 1, 1, 1, 1, .9 ), 'load_and_delay: max=1, one core, load1m=3 load5m=3 load15m=.9 => 5 ' ) ; + is( 15, load_and_delay( 1, 1, 1, 1, 1 ), 'load_and_delay: max=1, one core, load1m=3 load5m=3 load15m=3 => 15 ' ) ; + is( 0, load_and_delay( 1, 1, .9, .9, .9 ), 'load_and_delay: max=1, one core, load1m=.9 load5m=.9 load15m=.9 => 0 ' ) ; + + # load max = 3 per cpu + is( 0, load_and_delay( 3, 1, 1, 1, 1 ), 'load_and_delay: max=3, one core, loads are all 1 => ok ' ) ; + is( 0, load_and_delay( 3, 2, 2, 2, 2 ), 'load_and_delay: max=3, two core, loads are all 2 => ok ' ) ; + is( 0, load_and_delay( 3, 2, 2, 4, 5 ), 'load_and_delay: max=3, two core, load1m is 2 => ok ' ) ; + is( 0, load_and_delay( 3, 1, 0, 0, 0 ), 'load_and_delay: max=3, one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 0, 0, 2 ), 'load_and_delay: max=3, one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 0, 2, 0 ), 'load_and_delay: max=3, one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 0, 2, 2 ), 'load_and_delay: max=3, one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 0, 3, 3 ), 'load_and_delay: max=3, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 0, 4, 4 ), 'load_and_delay: max=3, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 2, 0, 0 ), 'load_and_delay: max=3, one core, load1m=2 load5m=0 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 2, 0, 2 ), 'load_and_delay: max=3, one core, load1m=2 load5m=0 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 2, 2, 0 ), 'load_and_delay: max=3, one core, load1m=2 load5m=2 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 2, 2, 2 ), 'load_and_delay: max=3, one core, load1m=2 load5m=2 load15m=2 => 0 ' ) ; + is( 1, load_and_delay( 3, 1, 3, 0, 0 ), 'load_and_delay: max=3, one core, load1m=3 load5m=0 load15m=0 => 0 ' ) ; + is( 1, load_and_delay( 3, 1, 3, 2.9, 2.9 ), 'load_and_delay: max=3, one core, load1m=3 load5m=2.9 load15m=2.9 => 0 ' ) ; + is( 5, load_and_delay( 3, 1, 3, 3, 2.9 ), 'load_and_delay: max=3, one core, load1m=3 load5m=3 load15m=2.9 => 0 ' ) ; + is( 15, load_and_delay( 3, 1, 3, 3, 3 ), 'load_and_delay: max=3, one core, load1m=3 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 2.9, 2.9, 2.9 ), 'load_and_delay: max=3, one core, load1m=2.9 load5m=2.9 load15m=2.9 => 0 ' ) ; - 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( 6, 1, 6, 0, 0 ), 'load_and_delay: max=6, one core, load1m=6 load5m=0 load15m=0 => 1 ' ) ; + is( 1, load_and_delay( 6, 1, 6, 5.9, 5.9 ), 'load_and_delay: max=6, one core, load1m=6 load5m=5.9 load15m=5.9 => 1 ' ) ; + is( 5, load_and_delay( 6, 1, 6, 6, 5.9 ), 'load_and_delay: max=6, one core, load1m=6 load5m=6 load15m=5.9 => 5 ' ) ; + is( 15, load_and_delay( 6, 1, 6, 6, 6 ), 'load_and_delay: max=6, one core, load1m=6 load5m=6 load15m=6 => 15 ' ) ; + is( 0, load_and_delay( 6, 1, 5.9, 5.9, 5.9 ), 'load_and_delay: max=6, one core, load1m=5.9 load5m=5.9 load15m=5.9 => 1 ' ) ; note( 'Leaving tests_load_and_delay()' ) ; return ; -} +} -sub load_and_delay +sub load_and_delay { - # Basically return 0 if load is not heavy, ie <= 1 per processor + # Basically return 0 if load is not heavy, ie load 1 min <= $max_load_per_core - # Not enough arguments - if ( 4 > scalar @ARG ) { return ; } + # 5 arguments at least (loadavg return 4 arguments like "0.19 0.16 0.17 3/444" ) + if ( 3 > scalar @ARG ) { return ; } - my ( $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) = @ARG ; + my ( $max_load_per_core, $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) = @ARG ; if ( 0 == $cpu_num ) { return ; } + # No avg_5_min nor avg_15_min on Windows + $avg_5_min ||= 0 ; + $avg_15_min ||= 0 ; + # 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 < 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 -} + + # If one period 1m is ok => ok ( 0 ) else Nok ( return > 0, 1 or 5 or 15 ) + if ( $avg_1_min < $max_load_per_core ) { return 0 ; } + if ( $avg_5_min < $max_load_per_core ) { return 1 ; } # Message: retry in 1 minute + if ( $avg_15_min < $max_load_per_core ) { return 5 ; } # Message: retry in 5 minutes + return 15 ; # Message: retry in 15 minutes +} sub tests_cpu_time @@ -16225,7 +18569,7 @@ sub tests_cpu_time my $mysync = { } ; $mysync->{ debug } = 1 ; - ok( is_number( cpu_time( $mysync ) ), 'cpu_time: {} => a number' ) ; + ok( is_number( cpu_time( $mysync ) ), 'cpu_time: {} => a number' ) ; note( 'Leaving tests_cpu_time()' ) ; return ; @@ -16233,16 +18577,16 @@ sub tests_cpu_time sub cpu_time { - my $mysync = shift ; - + my $mysync = shift @ARG ; + 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 ] ; - my $cpu_time_round = mysprintf( '%.2f', $cpu_time ) ; - $mysync->{ debug } and myprint( join(' + ', @cpu_times), " = $cpu_time ~ $cpu_time_round\n" ) ; + my $cpu_time_rounded = mysprintf( '%.2f', $cpu_time ) ; + $mysync->{ debug } and myprint( join(' + ', @cpu_times), " = $cpu_time ~ $cpu_time_rounded\n" ) ; return $cpu_time ; } @@ -16266,7 +18610,7 @@ sub tests_cpu_percent sub cpu_percent { - my $mysync = shift ; + my $mysync = shift @ARG ; my $cpu_time = shift || 0 ; my $timediff = shift || 1 ; # no division by 0 @@ -16277,35 +18621,36 @@ sub cpu_percent 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' ) ; + is( '0.0', cpu_percent_global( ), 'tests_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' ) ; + is( '0.0', cpu_percent_global( $mysync ), 'tests_cpu_percent_global: {} => 0' ) ; + is( '0.0', cpu_percent_global( $mysync, 0 ), 'tests_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' ) ; + is( '25.0', cpu_percent_global( $mysync, 100 ), 'tests_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' ) ; + #is( '50.0', cpu_percent_global( $mysync, 100 ), 'tests_cpu_percent_global: {} 100 => 50 on host petite' ) ; + is( '100.0', cpu_percent_global( $mysync, 100, 1 ), 'tests_cpu_percent_global: {} 100 => 100 on host petite' ) ; } ; note( 'Leaving tests_cpu_percent_global()' ) ; @@ -16314,29 +18659,94 @@ sub tests_cpu_percent_global sub cpu_percent_global { - my $mysync = shift ; + my $mysync = shift @ARG ; my $cpu_percent = shift || 0 ; - - my $cpu_number = cpu_number( ) ; - + my $cpu_number_forced = shift @ARG ; + + my $cpu_number = cpu_number( $cpu_number_forced ) ; + 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 tests_ram_memory_info +{ + note( 'Entering tests_ram_memory_info()' ) ; + + note( "ram_memory_info:", ram_memory_info( ) ) ; + note( "total_ram_memory_bytes_sys_meminfo:", total_ram_memory_bytes_sys_meminfo( ) ) ; + #note( "total_ram_memory_bytes_hw_memsize:", total_ram_memory_bytes_hw_memsize( ) ) ; + + ok( ram_memory_info( ), 'ram_memory_info: => some text' ) ; + + note( 'Leaving tests_ram_memory_info()' ) ; + return ; +} + + +sub total_ram_memory_bytes +{ + my $total_ram_memory_bytes ; + + # Found Sys::MemInfo::get( "totalmem" ) + # wrong on macOS 11.5.2 (20G95) + # good on Mac OS X 10.7.5 (11G63) + # ( commands "sw_vers" or "system_profiler SPSoftwareDataType" ) + + if ( 'darwin' eq $OSNAME ) + { + $total_ram_memory_bytes = total_ram_memory_bytes_hw_memsize( ) ; + } + else + { + $total_ram_memory_bytes = total_ram_memory_bytes_sys_meminfo( ) ; + } + + return $total_ram_memory_bytes ; +} + + + +sub total_ram_memory_bytes_hw_memsize +{ + my $total_ram_memory_bytes = `sysctl -n hw.memsize` ; + chomp $total_ram_memory_bytes ; + return $total_ram_memory_bytes ; +} + + +sub total_ram_memory_bytes_sys_meminfo +{ + my $total_ram_memory_bytes = Sys::MemInfo::get( "totalmem" ) ; + return $total_ram_memory_bytes ; +} + + + + sub ram_memory_info { + my $mysync = shift @ARG ; # In GigaBytes so division by 1024 * 1024 * 1024 # - return( - sprintf( "%.1f/%.1f free GiB of RAM", + + my $ram_memory_info = sprintf( + "%.1f/%.1f free GiB of RAM", Sys::MemInfo::get("freemem") / ( $KIBI ** 3 ), - Sys::MemInfo::get("totalmem") / ( $KIBI ** 3 ), - ) - ) ; + total_ram_memory_bytes( ) / ( $KIBI ** 3 ), + ) ; + + my $memory_consumption_all_pids_percent = memory_consumption_all_pids_percent( $mysync ) || 0 ; + if ( $memory_consumption_all_pids_percent ) + { + $ram_memory_info .= ", $memory_consumption_all_pids_percent% used by processes." + } + + return $ram_memory_info ; } @@ -16344,7 +18754,8 @@ sub ram_memory_info sub tests_memory_stress { note( 'Entering tests_memory_stress()' ) ; - + my $mysync = { } ; + sig_install( $mysync, 'catch_ignore', ( 'QUIT', 'TERM', 'INT' ) ) ; is( undef, memory_stress( ), 'memory_stress: => undef' ) ; note( 'Leaving tests_memory_stress()' ) ; @@ -16353,34 +18764,35 @@ sub tests_memory_stress sub memory_stress { - my $total_ram_in_MB = Sys::MemInfo::get("totalmem") / ( $KIBI * $KIBI ) ; + my $total_ram_in_MB = total_ram_memory_bytes( ) / ( $KIBI * $KIBI ) ; my $i = 1 ; - myprintf("Stress memory consumption before: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ; - while ( $i < $total_ram_in_MB / 1.7 ) { $a .= "A" x 1000_000; $i++ } ; - myprintf("Stress memory consumption after: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ; + myprintf("Stress memory consumption before: %.1f MiB of %.1f MiB my PID is $PROCESS_ID\n", memory_consumption_of_myself( ) / $KIBI / $KIBI, $total_ram_in_MB ) ; + while ( $i < $total_ram_in_MB / 1.7 ) + { + $a .= "A" x 1000_000; + myprint( "$i " ) ; + $i++ ; + } ; + myprintf( "\nStress memory consumption after: %.1f MiB of %.1f MiB my PID is $PROCESS_ID\n", memory_consumption_of_myself( ) / $KIBI / $KIBI, $total_ram_in_MB ) ; return ; } -sub tests_memory_consumption +sub tests_memory_consumption_of_myself { - note( 'Entering tests_memory_consumption()' ) ; + note( 'Entering tests_memory_consumption_of_myself()' ) ; - note( "memory_consumption: " . memory_consumption() . " bytes aka " . bytes_display_string_dec( memory_consumption() ) ) ; - like( memory_consumption( ), qr{\d+}xms,'memory_consumption no args') ; - like( memory_consumption( 1 ), qr{\d+}xms,'memory_consumption 1') ; - like( memory_consumption( $PROCESS_ID ), qr{\d+}xms,"memory_consumption_of_pids $PROCESS_ID") ; - - like( memory_consumption_ratio(), qr{\d+}xms, 'memory_consumption_ratio' ) ; - like( memory_consumption_ratio(1), qr{\d+}xms, 'memory_consumption_ratio 1' ) ; - like( memory_consumption_ratio(10), qr{\d+}xms, 'memory_consumption_ratio 10' ) ; + note( "memory_consumption_of_myself: " . memory_consumption_of_myself( ) . " bytes aka " . bytes_display_string_dec( memory_consumption_of_myself( ) ) ) ; + like( memory_consumption_of_myself( ), qr{\d+}xms,'tests_memory_consumption_of_myself no args') ; + like( memory_consumption_of_myself( 1 ), qr{\d+}xms,'tests_memory_consumption_of_myself 1') ; + like( memory_consumption_of_myself( $PROCESS_ID ), qr{\d+}xms,"tests_memory_consumption_of_myself $PROCESS_ID") ; - note( 'Leaving tests_memory_consumption()' ) ; + note( 'Leaving tests_memory_consumption_of_myself()' ) ; return ; } -sub memory_consumption +sub memory_consumption_of_myself { # memory consumed by imapsync until now in bytes return( ( memory_consumption_of_pids( ) )[0] ); @@ -16388,89 +18800,300 @@ sub memory_consumption sub debugmemory { - my $mysync = shift ; - if ( ! $mysync->{debugmemory} ) { return q{} ; } + my $mysync = shift @ARG ; + if ( ! $mysync->{ debugmemory } ) { return q{} ; } - my $precision = shift ; - return( mysprintf( "Memory consumption$precision: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ) ; + my $precision = shift @ARG ; + return( mysprintf( "Memory consumption$precision: %.1f MiB\n", memory_consumption_of_myself( ) / $KIBI / $KIBI ) ) ; } -sub memory_consumption_of_pids +sub memory_consumption_of_pids { - - my @pid = @_; + my @pid = @ARG ; + # No pid in ARG means find myself memory @pid = ( @pid ) ? @pid : ( $PROCESS_ID ) ; - $sync->{ debug } and myprint( "memory_consumption_of_pids PIDs: @pid\n" ) ; + #$sync->{ debug } and myprint( "memory_consumption_of_pids PIDs: @pid\n" ) ; my @val ; - if ( ( 'MSWin32' eq $OSNAME ) or ( 'cygwin' eq $OSNAME ) ) { - @val = memory_consumption_of_pids_win32( @pid ) ; - } - elsif ( 'darwin' eq $OSNAME ) + if ( ( 'MSWin32' eq $OSNAME ) or ( 'cygwin' eq $OSNAME ) ) { - @val = memory_consumption_of_pids_mac( @pid ) ; + @val = memory_consumption_of_pids_win32( @pid ) ; } else { - # Unix - my @ps = qx{ ps -o vsz -p @pid } ; - shift @ps ; # First line is column name "VSZ" - chomp @ps ; - # convert to octets - - @val = map { $_ * $KIBI } @ps ; + # Unix, Mac OS X included + @val = memory_consumption_of_pids_unix( @pid ) ; } return( @val ) ; -} +} -sub memory_consumption_of_pids_mac +sub memory_consumption_of_pids_unix { - my @pid = @_ ; + my @pid = @ARG ; # Use IPC::Open3 from perlcrit -3 # But it stalls on Darwin, I don't understand why! #my @ps = backtick( "ps -o rss -p @pid" ) ; #myprint( "ps: @ps" ) ; my @ps = qx{ ps -o rss -p @pid } ; - shift @ps ; # First line is column name "RSS" + shift @ps ; # First line is the column name "RSS" chomp @ps ; + # convert to octets my @val = map { $_ * $KIBI } @ps ; return( @val ) ; } -sub memory_consumption_of_pids_win32 + +sub tests_memory_consumption_of_all_pids { + note( 'Entering tests_memory_consumption_of_all_pids()' ) ; + + note( "memory_consumption_of_all_pids: " . memory_consumption_of_all_pids( ) . " bytes aka " . bytes_display_string_dec( memory_consumption_of_all_pids( ) ) ) ; + like( memory_consumption_of_all_pids( ), qr{\d+}xms, 'tests_memory_consumption_of_all_pids no args') ; + + note( 'Leaving tests_memory_consumption_of_all_pids()' ) ; + return ; +} + + +sub memory_consumption_of_all_pids +{ + my @all_pids = all_pids( ) ; + my @memory_consumption_of_all_pids = memory_consumption_of_pids( @all_pids ) ; + my $memory_consumption_of_all_pids = add( @memory_consumption_of_all_pids ) ; + return $memory_consumption_of_all_pids ; +} + + +sub tests_all_pids +{ + note( 'Entering tests_all_pids()' ) ; + + note( 'all_pids', join( ' ', all_pids( ) ) ) ; + ok( all_pids( ), 'tests_all_pids: no args => list of pids' ) ; + + + note( 'Leaving tests_all_pids()' ) ; + return ; +} + + +sub all_pids +{ + my @all_pids ; + if ( ( 'MSWin32' eq $OSNAME ) or ( 'cygwin' eq $OSNAME ) ) { + @all_pids = all_pids_win32( ) ; + } + else + { + # Unix + @all_pids = all_pids_unix( ) ; + } + return( @all_pids ) ; +} + +sub all_pids_unix +{ + my @ps = qx{ ps -e -o pid } ; + shift @ps ; # First line is the column name "PID" + chomp @ps ; + return @ps ; +} + + + +sub tests_memory_consumption_of_pids_win32 +{ + note( 'Entering tests_memory_consumption_of_pids_win32()' ) ; + + note( memory_consumption_of_pids_win32( $PROCESS_ID ) ) ; + #ok( memory_consumption_of_pids_win32( $PROCESS_ID ), 'tests_memory_consumption_of_pids_win32: no args => ' ) ; + + note( 'Leaving tests_memory_consumption_of_pids_win32()' ) ; + return ; +} + + +sub memory_consumption_of_pids_win32 +{ # Windows - my @PID = @_; + my @PID = @ARG; my %PID; # hash of pids as key values - map { $PID{$_}++ } @PID; + map { $PID{ $_ }++ } @PID ; # Does not work but should work reading the tasklist documentation #@ps = qx{ tasklist /FI "PID eq @PID" }; - my @ps = qx{ tasklist /NH /FO CSV } ; - #my @ps = backtick( 'tasklist /NH /FO CSV' ) ; + my @ps = qx{ tasklist /NH /FO TABLE } ; + #my @ps = backtick( 'tasklist /NH /FO TABLE' ) ; #myprint( "-" x $STD_CHAR_PER_LINE, "\n", @ps, "-" x $STD_CHAR_PER_LINE, "\n" ) ; - my @val; - foreach my $line (@ps) { - my($name, $pid, $mem) = (split ',', $line )[0,1,4]; + my @val ; + #myprint( @ps ) ; + foreach my $line ( @ps ) + { + my( $name, $pid, $mem ) = ( split / +/, $line )[ 0, 1, 4 ] ; next if (! $pid); - #myprint( "[$name][$pid][$mem]" ) ; - if ($PID{remove_qq($pid)}) { - #myprint( "MATCH !\n" ) ; + #myprint( "[$name][$pid][$mem]\n" ) ; + $pid = remove_qq( $pid ) ; + if ( $PID{ $pid } ) + { + #myprint( "MATCH $pid\n" ) ; chomp $mem ; - $mem = remove_qq($mem); - $mem = remove_Ko($mem); - $mem = remove_not_num($mem); - #myprint( "[$mem]\n" ) ; - push @val, $mem * $KIBI; + $mem = remove_qq( $mem ) ; + $mem = remove_not_num( $mem ) ; + if ( is_number( $mem ) ) + { + #myprint( "[$mem] ", $mem * $KIBI, "\n" ) ; + push @val, $mem * $KIBI ; + } } } - return(@val); + return( @val ) ; } + +sub all_pids_win32 +{ + my @ps = qx{ tasklist /NH /FO CSV } ; + my @pids ; + foreach my $line ( @ps ) + { + my( $name, $pid, $mem ) = ( split ',', $line )[ 0, 1, 4 ] ; + next if ( ! $pid ) ; + #myprint( "[$name][$pid][$mem]\n" ) ; + $pid = remove_qq( $pid ) ; + push @pids, $pid ; + } + return( @pids ) ; +} + + + +sub tests_memory_consumption_all_pids_percent +{ + note( 'Entering tests_memory_consumption_all_pids_percent()' ) ; + + note( memory_consumption_all_pids_percent( ) . " (%)" ) ; + like( memory_consumption_all_pids_percent( ), qr{^0|^(\d+\.\d+)$}xms, 'tests_memory_consumption_all_pids_percent: no args => like 12.34' ) ; + + ok( 0 <= memory_consumption_all_pids_percent( ), 'tests_memory_consumption_all_pids_percent: > 0' ) ; + ok( 100 >= memory_consumption_all_pids_percent( ), 'tests_memory_consumption_all_pids_percent: <= 100' ) ; + note( 'Leaving tests_memory_consumption_all_pids_percent()' ) ; + + return ; +} + + + +sub memory_consumption_all_pids_percent +{ + my $percent ; + + my $memory_consumption_of_all_pids = memory_consumption_of_all_pids( ) ; + my $total_memory_bytes = total_ram_memory_bytes( ) || return 0 ; + + $percent = sprintf( "%.2f", 100 * $memory_consumption_of_all_pids / $total_memory_bytes ) ; + return $percent ; +} + + + +sub tests_memory_consumption_all_pids_percent_Proc_ProcessTable +{ + note( 'Entering tests_memory_consumption_all_pids_percent_Proc_ProcessTable()' ) ; + require_ok( 'Proc::ProcessTable' ) ; + + note( memory_consumption_all_pids_percent_Proc_ProcessTable( ) . " (%)" ) ; + like( memory_consumption_all_pids_percent_Proc_ProcessTable( ), qr{^0|^(\d+\.\d+)$}xms, 'tests_memory_consumption_all_pids_percent_Proc_ProcessTable: no args => like 12.34' ) ; + + my $mysync = { } ; + + like( memory_consumption_all_pids_percent_Proc_ProcessTable( $mysync ), qr{^0|^(\d+\.\d+)$}xms, 'tests_memory_consumption_all_pids_percent_Proc_ProcessTable: { } => like 12.34' ) ; + note( 'Leaving tests_memory_consumption_all_pids_percent_Proc_ProcessTable()' ) ; + + return ; +} + +# Proc::ProcessTable pctmem does NOT work for Win32 Darwin +# Negative values and negative zeros for Darwin +# zeros for Win32 +# +sub memory_consumption_all_pids_percent_Proc_ProcessTable +{ + my $mysync = shift @ARG ; + + my $percent ; + if ( eval { require Proc::ProcessTable } ) + { + my $table_all_processes = Proc::ProcessTable->new( ) ; + + if ( pctmem_available( $table_all_processes ) ) + { + #pctmem is memory percentage of a process + foreach my $process ( @{ $table_all_processes->table( ) } ) + { + #myprint( "pctmem: ", $process->pctmem( ), "\n" ) ; + # + $percent += max( 0, $process->pctmem( ) ) ; + } + } + else + { + $percent = 0 ; + } + } + else + { + $percent = 0 ; + } + + $percent = sprintf( "%.2f", $percent ) ; + + return $percent ; +} + + +sub tests_pctmem_available +{ + note( 'Entering tests_pctmem_available()' ) ; + + is( undef, pctmem_available( ), 'pctmem_available: no args => undef' ) ; + + SKIP: { + skip( 'no Proc::ProcessTable', 1 ) if ( ! eval { require Proc::ProcessTable } ) ; + my $table_all_processes = Proc::ProcessTable->new( ) ; + like( pctmem_available( $table_all_processes ), qr{^(0|1)$}xms, 'pctmem_available: => 0 or 1' ) ; + } + + note( 'Leaving tests_pctmem_available()' ) ; + return ; +} + + +sub pctmem_available +{ + my $table_all_processes = shift @ARG ; + + if ( ! defined $table_all_processes ) { return ; } ; + + my @fields = $table_all_processes->fields( ) ; + + my %fields = map { defined( $_ ) ? ( $_ => 1 ) : ( ) } @fields ; + + if ( exists( $fields{ pctmem } ) ) + { + return 1 ; + } + else + { + return 0 ; + } + + return ; +} + sub tests_backtick { note( 'Entering tests_backtick()' ) ; @@ -16526,7 +19149,7 @@ sub tests_backtick sub backtick { - my $command = shift ; + my $command = shift @ARG ; if ( ! $command ) { return ; } @@ -16550,7 +19173,8 @@ sub backtick #myprint( @output ) ; if ( $output[0] =~ /\Qopen3: exec of $command failed\E/mxs ) { return ; } - if ( wantarray ) { + if ( wantarray ) + { return( @output ) ; } else { return( join( q{}, @output) ) ; @@ -16645,7 +19269,7 @@ sub search_dyn_lib_locale_MSWin32 sub remove_not_num { - my $string = shift ; + my $string = shift @ARG ; $string =~ tr/0-9//cd ; #myprint( "tr [$string]\n" ) ; return( $string ) ; @@ -16655,48 +19279,58 @@ sub tests_remove_not_num { note( 'Entering tests_remove_not_num()' ) ; - ok( '123' eq remove_not_num( 123 ), 'remove_not_num( 123 )' ) ; - ok( '123' eq remove_not_num( '123' ), q{remove_not_num( '123' )} ) ; - ok( '123' eq remove_not_num( '12 3' ), q{remove_not_num( '12 3' )} ) ; - ok( '123' eq remove_not_num( 'a 12 3 Ko' ), q{remove_not_num( 'a 12 3 Ko' )} ) ; + is( '123', remove_not_num( 123 ), 'remove_not_num( 123 )' ) ; + is( '123', remove_not_num( '123' ), q{remove_not_num( '123' )} ) ; + is( '123', remove_not_num( '12 3' ), q{remove_not_num( '12 3' )} ) ; + is( '123', remove_not_num( 'a 12 3 Ko' ), q{remove_not_num( 'a 12 3 Ko' )} ) ; + is( '123', remove_not_num( 'a 12 3 K' ), q{remove_not_num( 'a 12 3 K' )} ) ; + is( '123', remove_not_num( 'a 12,3 K' ), q{remove_not_num( 'a 12, 3 K' )} ) ; + is( '173892', remove_not_num( 'a 173,892 K' ), q{remove_not_num( 'a 173,892 K' )} ) ; note( 'Leaving tests_remove_not_num()' ) ; return ; } -sub remove_Ko + + + +sub tests_remove_qq { - my $string = shift; - if ($string =~ /^(.*)\sKo$/xo) { - return($1); + note( 'Entering tests_remove_qq()' ) ; + + is( undef, remove_qq( ), 'tests_remove_qq: no args => undef' ) ; + is( '', remove_qq( '' ), 'tests_remove_qq: empty => empty' ) ; + is( 'ABC', remove_qq( 'ABC' ), 'tests_remove_qq: ABC => ABC' ) ; + is( 'ABC', remove_qq( '"ABC"' ), 'tests_remove_qq: "ABC" => ABC' ) ; + is( '"ABC', remove_qq( '""ABC"' ), 'tests_remove_qq: ""ABC" => "ABC' ) ; + is( 'ABC"', remove_qq( '"ABC""' ), 'tests_remove_qq: "ABC"" => ABC"' ) ; + is( '"ABC"', remove_qq( '""ABC""' ), 'tests_remove_qq: ""ABC"" => "ABC"' ) ; + + note( 'Leaving tests_remove_qq()' ) ; + return ; +} + + +sub remove_qq +{ + my $string = shift ; + + if ( ! defined $string ) { return ; } + + #myprint( "$string\n" ) ; + + if ( $string =~ /^"(.*)"$/xo ) + { + return( $1 ) ; }else{ - return($string); + return( $string ) ; } -} - -sub remove_qq -{ - my $string = shift; - if ($string =~ /^"(.*)"$/xo) { - return($1); - }else{ - return($string); - } -} - -sub memory_consumption_ratio -{ - - my ($base) = @_; - $base ||= 1; - my $consu = memory_consumption(); - return($consu / $base); -} +} sub date_from_rcs { - my $d = shift ; + my $d = shift @ARG ; my %num2mon = qw( 01 Jan 02 Feb 03 Mar 04 Apr 05 May 06 Jun 07 Jul 08 Aug 09 Sep 10 Oct 11 Nov 12 Dec ) ; if ($d =~ m{(\d{4})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) { @@ -16732,7 +19366,7 @@ sub good_date # outgoing format: internal date format # 24-Aug-2010 16:00:00 +0200 - my $d = shift ; + my $d = shift @ARG ; return(q{}) if not defined $d; SWITCH: { @@ -16885,7 +19519,7 @@ sub tests_good_date ok('"18-Dec-2002 15:07:00 +0000"' eq good_date('Wednesday, December 18, 2002 03:07 PM'), 'good_date kbtoys.com orders'); ok('"16-Dec-2004 02:01:49 -0500"' eq good_date('Dec 16 2004 02:01:49 -0500'), 'good_date jr.com orders'); ok('"21-Jun-2001 11:11:11 +0000"' eq good_date('21-Jun-2001'), 'good_date register.com domain transfer'); - ok('"18-Nov-2012 18:34:38 +0100"' eq good_date('Sun, 18 Nov 2012 18:34:38 +0100'), 'good_date pop2imap bug (Westeuropäische Normalzeit)'); + ok('"18-Nov-2012 18:34:38 +0100"' eq good_date('Sun, 18 Nov 2012 18:34:38 +0100'), 'good_date pop2imap bug (Westeuropäische Normalzeit)'); ok('"19-Sep-2015 16:11:07 +0000"' eq good_date('Date: 2015/09/19 16:11:07 '), 'good_date from RCS date' ) ; note( 'Leaving tests_good_date()' ) ; @@ -16967,7 +19601,7 @@ sub tests_nb_messages_in_2_not_in_1 sub nb_messages_in_2_not_in_1 { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( not defined $mysync ) { return ; } $mysync->{ nb_messages_in_2_not_in_1 } = scalar( @@ -16981,7 +19615,7 @@ sub nb_messages_in_2_not_in_1 sub nb_messages_in_1_not_in_2 { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( not defined $mysync ) { return ; } $mysync->{ nb_messages_in_1_not_in_2 } = scalar( @@ -16996,7 +19630,7 @@ sub nb_messages_in_1_not_in_2 sub comment_on_final_diff_in_1_not_in_2 { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( not defined $mysync or $mysync->{ justfolders } @@ -17053,7 +19687,7 @@ sub comment_on_final_diff_in_1_not_in_2 sub comment_on_final_diff_in_2_not_in_1 { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( not defined $mysync or $mysync->{ justfolders } @@ -17076,6 +19710,16 @@ sub comment_on_final_diff_in_2_not_in_1 $nb_identified_h2_messages, " identified messages in host2 are on host1.\n" ) ; } + elsif ( $mysync->{ delete2 } ) + { + myprint( "The sync was not strict, there were at least ", + $mysync->{ nb_messages_in_2_not_in_1 }, + " among ", + $nb_identified_h2_messages, + " identified messages in host2 that were not on host1.", + " Run a sync again with --delete2 to be sure of a strict sync.\n" + ) ; + } else { myprint( "The sync is not strict, there are ", @@ -17083,8 +19727,8 @@ sub comment_on_final_diff_in_2_not_in_1 " 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" - ) ; + " Use --delete2 and sync again to delete them and have a strict sync.\n" + ) ; } return ; } @@ -17140,7 +19784,8 @@ sub match if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; } # normal cases - if ( eval { $var =~ qr{$regex} } ) { + if ( eval { $var =~ qr{$regex} } ) + { return $var ; }elsif ( $EVAL_ERROR ) { myprint( "Fatal regex $regex\n" ) ; @@ -17195,7 +19840,8 @@ sub notmatch if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; } # normal cases - if ( eval { $var !~ $regex } ) { + if ( eval { $var !~ $regex } ) + { return 1 ; }elsif ( $EVAL_ERROR ) { myprint( "Fatal regex $regex\n" ) ; @@ -17207,45 +19853,183 @@ sub notmatch } -sub delete_folders_in_2_not_in_1 -{ - foreach my $folder ( @h2_folders_not_in_1 ) { - if ( defined $delete2foldersonly and eval "\$folder !~ $delete2foldersonly" ) { - myprint( "Not deleting $folder because of --delete2foldersonly $delete2foldersonly\n" ) ; - next ; + +sub tests_subfolder2_with_delete2folders +{ + note( 'Entering tests_subfolder2_with_delete2folders()' ) ; + + is( undef, subfolder2_with_delete2folders( ), 'tests_subfolder2_with_delete2folders: no args => undef' ) ; + + my $mysync = { } ; + is( undef, subfolder2_with_delete2folders( $mysync ), 'tests_subfolder2_with_delete2folders: { } => undef' ) ; + + $mysync->{ delete2foldersonly } = '/QQQ/' ; + is( undef, subfolder2_with_delete2folders( $mysync ), 'tests_subfolder2_with_delete2folders: only --delete2foldersonly /QQQ/ => undef' ) ; + + $mysync->{ subfolder2 } = 'SUB' ; + is( undef, subfolder2_with_delete2folders( $mysync ), 'tests_subfolder2_with_delete2folders: --delete2foldersonly /QQQ/ --subfolder2 SUB => undef' ) ; + + $mysync->{ delete2folders } = 1 ; + is( '/QQQ/', subfolder2_with_delete2folders( $mysync ), 'tests_subfolder2_with_delete2folders: --delete2foldersonly /QQQ/ --subfolder2 SUB --delete2folders => /QQQ/' ) ; + + $mysync->{ delete2foldersonly } = undef ; + is( 'm{SUB}', subfolder2_with_delete2folders( $mysync ), 'tests_subfolder2_with_delete2folders: --subfolder2 --delete2folders => m{SUB}' ) ; + is( 'm{SUB}', $mysync->{ delete2foldersonly }, 'tests_subfolder2_with_delete2folders: --subfolder2 --delete2folders => --delete2foldersonly m{SUB}' ) ; + + + note( 'Leaving tests_subfolder2_with_delete2folders()' ) ; + return ; +} + + + +sub subfolder2_with_delete2folders +{ + my $mysync = shift ; + + if ( $mysync->{ subfolder2 } and $mysync->{ delete2folders } ) + { + myprint( "Detected --subfolder2 $mysync->{ subfolder2 } --delete2folders\n" ) ; + if ( ! $mysync->{ delete2foldersonly } ) + { + myprint( "Adding --delete2foldersonly " . "m{" . $mysync->{ subfolder2 } . "}\n" ) ; + $mysync->{ delete2foldersonly } = "m{" . $mysync->{ subfolder2 } . "}" ; } - if ( defined $delete2foldersbutnot and eval "\$folder =~ $delete2foldersbutnot" ) { - myprint( "Not deleting $folder because of --delete2foldersbutnot $delete2foldersbutnot\n" ) ; - next ; - } - my $res = $sync->{dry} ; # always success in dry mode! - $sync->{imap2}->unsubscribe( $folder ) if ( ! $sync->{dry} ) ; - $res = $sync->{imap2}->delete( $folder ) if ( ! $sync->{dry} ) ; - if ( $res ) { - myprint( "Deleted $folder", "$sync->{dry_message}", "\n" ) ; - }else{ - myprint( "Deleting $folder failed", "\n" ) ; + else + { + myprint( "Detected also a --delete2foldersonly $mysync->{ delete2foldersonly } so you are on your own about this value.\n" ) ; } } + else + { + return ; + } + + return $mysync->{ delete2foldersonly } ; +} + + + +sub tests_delete_folders_in_2_not_in_1 +{ + note( 'Entering tests_delete_folders_in_2_not_in_1()' ) ; + + + is( undef, delete_folders_in_2_not_in_1( ), q{tests_delete_folders_in_2_not_in_1: undef} ) ; + my $syncT ; + is( undef, delete_folders_in_2_not_in_1( $syncT ), q{tests_delete_folders_in_2_not_in_1: undef 2} ) ; + my $imapT ; + $syncT->{ imap1 } = $imapT ; + is( undef, delete_folders_in_2_not_in_1( $syncT ), q{tests_delete_folders_in_2_not_in_1: undef imap} ) ; + + require_ok( "Test::MockObject" ) ; + $imapT = Test::MockObject->new( ) ; + $syncT->{ imap2 } = $imapT ; + + $imapT->set_true( 'IsUnconnected' ) ; + is( undef, delete_folders_in_2_not_in_1( $syncT ), q{tests_delete_folders_in_2_not_in_1: Unconnected imap} ) ; + + # Now connected tests + $imapT->set_false( 'IsUnconnected' ) ; + $imapT->mock( 'LastError', sub { q{LastError mocked} } ) ; + + $syncT->{ delete2folders } = 0 ; + is( undef, delete_folders_in_2_not_in_1( $syncT, qw( INBOX DELME1 DELME2 ) ), q{tests_delete_folders_in_2_not_in_1: --delete2folders OFF} ) ; + + $syncT->{ delete2folders } = 1 ; + $imapT->set_true( 'unsubscribe' ) ; + $imapT->set_true( 'delete' ) ; + $syncT->{ dry_message } = '' ; + + is_deeply( [ qw( DELME1 DELME2 ) ], [ delete_folders_in_2_not_in_1( $syncT, qw( DELME1 DELME2 ) ) ], q{tests_delete_folders_in_2_not_in_1: DELME1 DELME2 --delete2folders ON } ) ; + is_deeply( [ qw( DELME1 DELME2 ) ], [ delete_folders_in_2_not_in_1( $syncT, qw( INBOX DELME1 DELME2 Inbox ) ) ], q{tests_delete_folders_in_2_not_in_1: skip INBOX Inbox } ) ; + + $syncT->{ delete2foldersbutnot } = 'm{NOTDELME2}' ; + is_deeply( [ qw( DELME1 ) ], [ delete_folders_in_2_not_in_1( $syncT, qw( DELME1 NOTDELME2 ) ) ], q{tests_delete_folders_in_2_not_in_1: DELME1 --delete2foldersbutnot NOTDELME2} ) ; + + $syncT->{ delete2foldersonly } = 'm{DELME}' ; + is_deeply( [ qw( DELME1 DELME2 YESDELMETOO ) ], [ delete_folders_in_2_not_in_1( $syncT, qw( DELME1 NOTME DELME2 YESDELMETOO ) ) ], q{tests_delete_folders_in_2_not_in_1: --delete2foldersonly DELME } ) ; + + + + + + note( 'Leaving tests_delete_folders_in_2_not_in_1()' ) ; return ; } + + +sub delete_folders_in_2_not_in_1 +{ + myprint( "Entering delete_folders_in_2_not_in_1()\n" ) ; + my ( $mysync, @h2_folders_to_delete ) = @ARG ; + + if ( ! $mysync->{ delete2folders } ) { return ; } ; + + + my @folders_deleted = () ; + + foreach my $folder ( @h2_folders_to_delete ) + { + # INBOX is RFC mandatory + if ( uc $folder eq 'INBOX' ) + { + myprint( "Host2: Not deleting $folder, since it is RFC mandatory to exist.\n" ) ; + next ; + } + + if ( defined( $mysync->{ delete2foldersonly } ) and eval "\$folder !~ $mysync->{ delete2foldersonly }" ) + { + myprint( "Not deleting $folder because of --delete2foldersonly $mysync->{ delete2foldersonly }\n" ) ; + next ; + } + + if ( defined( $mysync->{ delete2foldersbutnot } ) and eval "\$folder =~ $mysync->{ delete2foldersbutnot }" ) + { + myprint( "Not deleting $folder because of --delete2foldersbutnot $mysync->{ delete2foldersbutnot }\n" ) ; + next ; + } + + my $result ; + + if ( ! $mysync->{ dry } ) + { + $mysync->{ imap2 }->unsubscribe( $folder ) ; + $result = $mysync->{ imap2 }->delete( $folder ) ; + } + + if ( $result || $mysync->{ dry } ) # always success in dry mode. + { + myprint( "Deleted $folder", "$mysync->{ dry_message }", "\n" ) ; + $mysync->{ deleted_folders_host2 }++ ; + push @folders_deleted, $folder ; + + }else{ + myprint( "Deleting $folder failed", "\n" ) ; + $mysync->{ deleted_folders_host2_failures }++ ; + } + } + myprint( "Leaving delete_folders_in_2_not_in_1()\n" ) ; + return @folders_deleted ; +} + sub delete_folder { - my ( $mysync, $imap, $folder, $Side ) = @_ ; + my ( $mysync, $imap, $folder, $Side ) = @ARG ; if ( ! $mysync ) { return ; } if ( ! $imap ) { return ; } if ( ! $folder ) { return ; } $Side ||= 'HostX' ; - my $res = $mysync->{dry} ; # always success in dry mode! - if ( ! $mysync->{dry} ) { + my $res = $mysync->{ dry } ; # always success in dry mode! + if ( ! $mysync->{ dry } ) { $imap->unsubscribe( $folder ) ; $res = $imap->delete( $folder ) ; } if ( $res ) { - myprint( "$Side deleted $folder", $mysync->{dry_message}, "\n" ) ; + myprint( "$Side deleted $folder", $mysync->{ dry_message }, "\n" ) ; return 1 ; }else{ myprint( "$Side deleting $folder failed", "\n" ) ; @@ -17255,18 +20039,21 @@ sub delete_folder sub delete1emptyfolders { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! $mysync ) { return ; } # abort if no parameter - if ( ! $mysync->{delete1emptyfolders} ) { return ; } # abort if --delete1emptyfolders off - my $imap = $mysync->{imap1} ; + if ( ! $mysync->{ delete1emptyfolders } ) { return ; } # abort if --delete1emptyfolders off + + my $imap = $mysync->{ imap1 } ; if ( ! $imap ) { return ; } # abort if no imap if ( $imap->IsUnconnected( ) ) { return ; } # abort if disconnected my %folders_kept ; myprint( qq{Host1 deleting empty folders\n} ) ; - foreach my $folder ( reverse sort @{ $mysync->{h1_folders_wanted} } ) { + foreach my $folder ( reverse sort @{ $mysync->{ h1_folders_wanted } } ) + { my $parenthood = $imap->is_parent( $folder ) ; - if ( defined $parenthood and $parenthood ) { + if ( defined $parenthood and $parenthood ) + { myprint( "Host1: folder $folder has subfolders\n" ) ; $folders_kept{ $folder }++ ; next ; @@ -17274,19 +20061,24 @@ sub delete1emptyfolders my $nb_messages_select = examine_folder_and_count( $mysync, $imap, $folder, 'Host1' ) ; if ( ! defined $nb_messages_select ) { next ; } # Select failed => Neither continue nor keep this folder } my $nb_messages_search = scalar( @{ $imap->messages( ) } ) ; - if ( 0 != $nb_messages_select and 0 != $nb_messages_search ) { + if ( 0 != $nb_messages_select and 0 != $nb_messages_search ) + { myprint( "Host1: folder $folder has messages: $nb_messages_search (search) $nb_messages_select (select)\n" ) ; $folders_kept{ $folder }++ ; next ; } - if ( 0 != $nb_messages_select + $nb_messages_search ) { + if ( 0 != $nb_messages_select + $nb_messages_search ) + { myprint( "Host1: folder $folder odd messages count: $nb_messages_search (search) $nb_messages_select (select)\n" ) ; $folders_kept{ $folder }++ ; next ; } - # Here we must have 0 messages by messages() aka "SEARCH ALL" and also "EXAMINE" - if ( uc $folder eq 'INBOX' ) { - myprint( "Host1: Not deleting $folder\n" ) ; + # Now, here we must have 0 messages by messages() aka "SEARCH ALL" and also "EXAMINE" + + # INBOX is RFC mandatory + if ( uc $folder eq 'INBOX' ) + { + myprint( "Host1: Not deleting $folder, since it is RFC mandatory to exist.\n" ) ; $folders_kept{ $folder }++ ; next ; } @@ -17294,9 +20086,12 @@ sub delete1emptyfolders # can not delete a SELECTed or EXAMINEd folder so closing it # could changed be SELECT INBOX $imap->close( ) ; # close after examine does not expunge; anyway expunging an empty folder... - if ( delete_folder( $mysync, $imap, $folder, 'Host1' ) ) { + if ( delete_folder( $mysync, $imap, $folder, 'Host1' ) ) + { next ; # Deleted, good! - }else{ + } + else + { $folders_kept{ $folder }++ ; next ; # Not deleted, bad! } @@ -17304,7 +20099,7 @@ sub delete1emptyfolders remove_deleted_folders_from_wanted_list( $mysync, %folders_kept ) ; myprint( qq{Host1 ended deleting empty folders\n} ) ; return ; -} +} sub remove_deleted_folders_from_wanted_list { @@ -17324,7 +20119,7 @@ sub remove_deleted_folders_from_wanted_list sub examine_folder_and_count { - my ( $mysync, $imap, $folder, $Side ) = @_ ; + my ( $mysync, $imap, $folder, $Side ) = @ARG ; $Side ||= 'HostX' ; if ( ! examine_folder( $mysync, $imap, $folder, $Side ) ) { @@ -17344,12 +20139,12 @@ sub tests_delete1emptyfolders my $syncT ; is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef 2} ) ; my $imapT ; - $syncT->{imap1} = $imapT ; + $syncT->{ imap1 } = $imapT ; is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef imap} ) ; require_ok( "Test::MockObject" ) ; $imapT = Test::MockObject->new( ) ; - $syncT->{imap1} = $imapT ; + $syncT->{ imap1 } = $imapT ; $imapT->set_true( 'IsUnconnected' ) ; is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: Unconnected imap} ) ; @@ -17430,7 +20225,7 @@ sub tests_delete1emptyfolders $imapT->mock( 'History', sub { ( q{* 0 EXISTS} ) } ) ; $imapT->mock( 'messages', sub { [ ] } ) ; $imapT->set_true( qw{ delete close unsubscribe } ) ; - $syncT->{dry_message} = q{ (not really since in a mocked test)} ; + $syncT->{ dry_message } = q{ (not really since in a mocked test)} ; tests_delete1emptyfolders_unit( $syncT, [ qw{ INBOX DELME1 DELME2 } ], @@ -17446,9 +20241,9 @@ sub tests_delete1emptyfolders_unit { note( 'Entering tests_delete1emptyfolders_unit()' ) ; - my $syncT = shift ; - my $folders1wanted_init_ref = shift ; - my $folders1wanted_after_ref = shift ; + my $syncT = shift @ARG ; + my $folders1wanted_init_ref = shift @ARG ; + my $folders1wanted_after_ref = shift @ARG ; my $comment = shift || q{delete1emptyfolders:} ; my @folders1wanted_init = @{ $folders1wanted_init_ref } ; @@ -17466,7 +20261,7 @@ sub tests_delete1emptyfolders_unit sub extract_header { - my $string = shift ; + my $string = shift @ARG ; my ( $header ) = split /\n\n/x, $string ; if ( ! $header ) { return( q{} ) ; } @@ -17501,8 +20296,9 @@ EOM return ; } -sub decompose_header{ - my $string = shift ; +sub decompose_header +{ + my $string = shift @ARG ; # a hash, for a keyword header KEY value are list of strings [VAL1, VAL1_other, etc] # Think of multiple "Received:" header lines. @@ -17518,12 +20314,12 @@ sub decompose_header{ if ( $line =~ m/(^[^:]+):\s(.*)/xo ) { $key = $1 ; $val = $2 ; - $debugdev and myprint( "DDD KV [$key] [$val]\n" ) ; + #$debug and myprint( "DDD KV [$key] [$val]\n" ) ; push @{ $header->{ $key } }, $val ; # blanc and value => value from previous line continues }elsif( $line =~ m/^(\s+)(.*)/xo ) { $val = $2 ; - $debugdev and myprint( "DDD V [$val]\n" ) ; + #$debug and myprint( "DDD V [$val]\n" ) ; @{ $header->{ $key } }[ $LAST ] .= " $val" if $key ; # dirty line? }else{ @@ -17534,7 +20330,7 @@ sub decompose_header{ #myprint( Data::Dumper->Dump( [ $header ] ) ) ; return( $header ) ; -} +} sub tests_decompose_header{ @@ -17676,7 +20472,7 @@ sub epoch # outgoing format: epoch - my $d = shift ; + my $d = shift @ARG ; return(q{}) if not defined $d; my ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) ; @@ -17749,7 +20545,7 @@ sub tests_max_line_length sub max_line_length { - my $string = shift ; + my $string = shift @ARG ; my $max = 0 ; while ( $string =~ m/([^\n]*\n?)/msxg ) { @@ -17777,15 +20573,14 @@ sub set_checknoabletosearch } -sub tests_setlogfile +sub tests_setlogfile { note( 'Entering tests_setlogfile()' ) ; my $mysync = {} ; - $mysync->{logdir} = 'vallogdir' ; - $mysync->{logfile} = 'vallogfile.txt' ; - is( 'vallogdir/vallogfile.txt', setlogfile( $mysync ), - 'setlogfile: logdir vallogdir, logfile vallogfile.txt, vallogdir/vallogfile.txt' ) ; + $mysync->{ logdir } = 'vallogdir' ; + is( 'vallogdir/vallogfile.txt', setlogfile( $mysync, 'vallogfile.txt' ), + 'setlogfile: logdir vallogdir, vallogfile.txt => vallogdir/vallogfile.txt' ) ; SKIP: { skip( 'Too hard to have a well known timezone on Windows', 9 ) if ( 'MSWin32' eq $OSNAME ) ; @@ -17796,8 +20591,8 @@ sub tests_setlogfile timestart => 2, } ; - is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000__.txt", setlogfile( $mysync ), - "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000__.txt" ) ; + is( '1970_01_01_00_00_02_000__.txt', setlogfile( $mysync ), + 'setlogfile: default is like 1970_01_01_00_00_02_000__.txt' ) ; $mysync = { timestart => 2, @@ -17806,29 +20601,27 @@ sub tests_setlogfile abort => 1, } ; - is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_abort.txt", setlogfile( $mysync ), - "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_abort.txt" ) ; + is( '1970_01_01_00_00_02_000_user1_user2_abort.txt', setlogfile( $mysync ), + 'setlogfile: default abort is like 1970_01_01_00_00_02_000_user1_user2_abort.txt' ) ; $mysync = { timestart => 2, user1 => 'user1', user2 => 'user2', - remote => 'zzz', } ; - is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote.txt", setlogfile( $mysync ), - "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote.txt" ) ; + is( '1970_01_01_00_00_02_000_user1_user2_remote.txt', setlogfile( $mysync, undef, '_remote' ), + 'setlogfile: default with _remote is like 1970_01_01_00_00_02_000_user1_user2_remote.txt' ) ; $mysync = { timestart => 2, user1 => 'user1', user2 => 'user2', - remote => 'zzz', abort => 1, } ; - is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote_abort.txt", setlogfile( $mysync ), - "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote_abort.txt" ) ; + is( '1970_01_01_00_00_02_000_user1_user2_remote_abort.txt', setlogfile( $mysync, undef, '_remote' ), + 'setlogfile: default abort with _remote is like 1970_01_01_00_00_02_000_user1_user2_remote_abort.txt' ) ; $mysync = { @@ -17837,13 +20630,13 @@ sub tests_setlogfile user2 => 'user2', } ; - is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt", setlogfile( $mysync ), - "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt" ) ; + is( '1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ), + 'setlogfile: default is like 1970_01_01_00_00_02_000_user1_user2.txt' ) ; $mysync->{logdir} = undef ; $mysync->{logfile} = undef ; - is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt", setlogfile( $mysync ), - "setlogfile: logdir undef, $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt" ) ; + is( '1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ), + 'setlogfile: logdir undef, 1970_01_01_00_00_02_000_user1_user2.txt' ) ; $mysync->{logdir} = q{} ; $mysync->{logfile} = undef ; @@ -17860,43 +20653,117 @@ sub tests_setlogfile user2 => 'u/ser2a*|?:"<>b', } ; - is( "$DEFAULT_LOGDIR/1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt", setlogfile( $mysync ), - "setlogfile: logdir undef, $DEFAULT_LOGDIR/1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt" ) ; - - + is( '1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt', setlogfile( $mysync ), + 'setlogfile: logdir undef, 1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt' ) ; } ; note( 'Leaving tests_setlogfile()' ) ; return ; -} +} -sub setlogfile + +sub setlogfile { - my( $mysync ) = shift ; + my $mysync = shift @ARG ; + my $given = shift @ARG ; + my $supplement = shift @ARG || '' ; # When aborting another process the log file name finishes with "_abort.txt" my $abort_suffix = ( $mysync->{ abort } ) ? '_abort' : q{} ; + + my $suffix = logfilesuffix( $mysync, $supplement . $abort_suffix ) ; - # When acting as a proxy the log file name finishes with "_remote.txt" - # proxy mode is not done in imapsync, it is done by proximapsync - my $remote_suffix = ( $mysync->{ remote } ) ? '_remote' : q{} ; + my $logdir = $mysync->{ logdir } || '' ; - my $suffix = ( - filter_forbidden_characters( slash_to_underscore( $mysync->{ user1 } ) ) || q{} ) - . '_' - . ( filter_forbidden_characters( slash_to_underscore( $mysync->{ user2 } ) ) || q{} ) - . $remote_suffix . $abort_suffix ; + my $logfile ; + if ( defined $given ) + { + if ( $logdir ) + { + $logfile = "$logdir/$given" ; + } + else + { + $logfile = "$given" ; + } + } + else + { + $logfile = logfile( $mysync->{ timestart }, $suffix, $logdir ) ; + } - $mysync->{ logdir } = defined $mysync->{ logdir } ? $mysync->{ logdir } : $DEFAULT_LOGDIR ; + return( $logfile ) ; +} - $mysync->{ logfile } = defined $mysync->{ logfile } - ? "$mysync->{ logdir }/$mysync->{ logfile }" - : logfile( $mysync->{ timestart }, $suffix, $mysync->{ logdir } ) ; - return( $mysync->{ logfile } ) ; +sub tests_logfilesuffix +{ + note( 'Entering tests_logfilesuffix()' ) ; + + is( '_', logfilesuffix( ), 'tests_logfilesuffix: no args => _' ) ; + my $mysync = { } ; + is( '_', logfilesuffix( $mysync ), 'tests_logfilesuffix: undef => _' ) ; + $mysync->{ user1 } = 'valuser1' ; + $mysync->{ user2 } = 'valuser2' ; + is( 'valuser1_valuser2', logfilesuffix( $mysync ), 'tests_logfilesuffix: valuser1 valuser2 => valuser1_valuser2' ) ; + is( 'valuser1_valuser2_suppl', logfilesuffix( $mysync, '_suppl' ), 'tests_logfilesuffix: valuser1 valuser2 _suppl => valuser1_valuser2_suppl' ) ; + + note( 'Leaving tests_logfilesuffix()' ) ; + return ; } +sub logfilesuffix +{ + my $mysync = shift @ARG ; + my $supplement = shift @ARG || '' ; + + my $suffix = ( + filter_forbidden_characters_cgi_context( slash_to_underscore( $mysync->{ user1 } ) ) || q{} ) + . '_' + . ( filter_forbidden_characters_cgi_context( slash_to_underscore( $mysync->{ user2 } ) ) || q{} ) + . $supplement ; + + return $suffix ; +} + + + +sub tests_setlogdir +{ + note( 'Entering tests_setlogdir()' ) ; + + is( $DEFAULT_LOGDIR, setlogdir( ), "setlogdir: no args => $DEFAULT_LOGDIR" ) ; + + my $mysync = { } ; + is( $DEFAULT_LOGDIR, setlogdir( $mysync ), "setlogdir: no args => $DEFAULT_LOGDIR" ) ; + + $mysync->{ logdir } = '' ; + is( '', setlogdir( $mysync ), "setlogdir: logdir empty string => empty string" ) ; + is( '', $mysync->{ logdir }, "setlogdir: logdir empty string unchanged" ) ; + + $mysync->{ logdir } = 'vallogdir' ; + is( 'vallogdir', setlogdir( $mysync ), "setlogdir: logdir vallogdir => vallogdir" ) ; + is( 'vallogdir', $mysync->{ logdir }, "setlogdir: logdir vallogdir unchanged" ) ; + # Does a second call hurt? + is( 'vallogdir', setlogdir( $mysync ), "setlogdir: logdir vallogdir => vallogdir" ) ; + is( 'vallogdir', $mysync->{ logdir }, "setlogdir: logdir vallogdir unchanged" ) ; + + note( 'Leaving tests_setlogdir()' ) ; + return ; +} + + +sub setlogdir +{ + my $mysync = shift @ARG ; + + my $logdir = defined $mysync->{ logdir } ? $mysync->{ logdir } : $DEFAULT_LOGDIR ; + + return $logdir ; +} + + sub tests_logfile { note( 'Entering tests_logfile()' ) ; @@ -17908,14 +20775,14 @@ sub tests_logfile local $ENV{TZ} = 'GMT' ; { 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' ) ; - is( '1970_01_01_00_01_01_234.txt', logfile( 61.234 ), 'logfile: 0 => 1970_01_01_00_01_01.txt' ) ; - is( '2010_08_24_14_00_00_000.txt', logfile( 1_282_658_400 ), 'logfile: 1_282_658_400 => 2010_08_24_14_00_00.txt' ) ; - is( '2010_08_24_14_01_01_000.txt', logfile( 1_282_658_461 ), 'logfile: 1_282_658_461 => 2010_08_24_14_01_01.txt' ) ; - is( '2010_08_24_14_01_01_000_poupinette.txt', logfile( 1_282_658_461, 'poupinette' ), 'logfile: 1_282_658_461 poupinette => 2010_08_24_14_01_01_poupinette.txt' ) ; - is( '2010_08_24_14_01_01_000_removeblanks.txt', logfile( 1_282_658_461, ' remove blanks ' ), 'logfile: 1_282_658_461 remove blanks => 2010_08_24_14_01_01_000_removeblanks' ) ; + is( '1970_01_01_00_00_00_000.txt', logfile( ), 'logfile: no args => 1970_01_01_00_00_00_000.txt' ) ; + is( '1970_01_01_00_00_00_000.txt', logfile( 0 ), 'logfile: 0 => 1970_01_01_00_00_00_000.txt' ) ; + is( '1970_01_01_00_01_01_000.txt', logfile( 61 ), 'logfile: 0 => 1970_01_01_00_01_01_000.txt' ) ; + is( '1970_01_01_00_01_01_234.txt', logfile( 61.234 ), 'logfile: 0 => 1970_01_01_00_01_01_234.txt' ) ; + is( '2010_08_24_14_00_00_000.txt', logfile( 1_282_658_400 ), 'logfile: 1_282_658_400 => 2010_08_24_14_00_00_000.txt' ) ; + is( '2010_08_24_14_01_01_000.txt', logfile( 1_282_658_461 ), 'logfile: 1_282_658_461 => 2010_08_24_14_01_01_000.txt' ) ; + is( '2010_08_24_14_01_01_000_poupinette.txt', logfile( 1_282_658_461, 'poupinette' ), 'logfile: 1_282_658_461 poupinette => 2010_08_24_14_01_01_000_poupinette.txt' ) ; + is( '2010_08_24_14_01_01_000_removeblanks.txt', logfile( 1_282_658_461, ' remove blanks ' ), 'logfile: 1_282_658_461 remove blanks => 2010_08_24_14_01_01_000_removeblanks.txt' ) ; is( '2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup' ), 'logfile: 1_282_658_461.2347 poup => 2010_08_24_14_01_01_234_poup.txt' ) ; @@ -17923,8 +20790,6 @@ sub tests_logfile is( 'dirdir/2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup', 'dirdir' ), 'logfile: 1_282_658_461.2347 poup dirdir => dirdir/2010_08_24_14_01_01_234_poup.txt' ) ; - - } POSIX::tzset unless ('MSWin32' eq $OSNAME) ; } ; @@ -17934,9 +20799,9 @@ sub tests_logfile } -sub logfile +sub logfile { - my ( $time, $suffix, $dir ) = @_ ; + my ( $time, $suffix, $dir ) = @ARG ; $time ||= 0 ; $suffix ||= q{} ; @@ -17945,47 +20810,148 @@ sub logfile $dir ||= q{} ; my $sep_dir = ( $dir ) ? '/' : q{} ; - my $date_str = POSIX::strftime( '%Y_%m_%d_%H_%M_%S', localtime $time ) ; - # Because of ab tests or web accesses, more than one sync withing one second is possible - # so we add also milliseconds - $date_str .= sprintf "_%03d", ($time - int( $time ) ) * 1000 ; # without rounding + my $date_str = year_month_day_hour_min_sec_ms( $time ) ; + my $logfile = "${dir}${sep_dir}${date_str}${sep_suffix}${suffix}.txt" ; return( $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' ) ; +sub tests_year_month_day_hour_min_sec_ms +{ + note( 'Entering tests_date_year_month_day_hour_min_sec_ms()' ) ; + + if ( 'MSWin32' eq $OSNAME ) + { + # Can not use $ENV{TZ} nor POSIX::tzset + like( year_month_day_hour_min_sec_ms( ), qr'1970_01_01_\d\d_00_00_000', 'year_month_day_hour_min_sec_ms: no args => match 1970_01_01_\d\d_00_00_000' ) ; + like( year_month_day_hour_min_sec_ms( 0 ), qr'1970_01_01_\d\d_00_00_000', 'year_month_day_hour_min_sec_ms: 0 => match 1970_01_01_\d\d_00_00_000' ) ; + like( year_month_day_hour_min_sec_ms( 1671706800.123 ), qr'2022_12_22_\d\d_00_00_122', 'year_month_day_hour_min_sec_ms: 123456789.123 => match 2022_12_22_\d\d_00_00_122' ) ; + + like( year_month_day_hour_min_sec_ms( -1 ), qr'19\d\d_\d\d_\d\d_\d\d_59_59_000', 'year_month_day_hour_min_sec_ms: -1 => 19\d\d_\d\d_\d\d_\d\d_59_59_000' ) ; + like( year_month_day_hour_min_sec_ms( -0.246 ), qr'19\d\d_\d\d_\d\d_\d\d_59_59_754', 'year_month_day_hour_min_sec_ms: -1 => 19\d\d_\d\d_\d\d_\d\d_59_59_754' ) ; + + like( year_month_day_hour_min_sec_ms( -32360400.135 ), qr'1968_12_22_\d\d_59_59_864', 'year_month_day_hour_min_sec_ms: -1 => 1968_12_22_\d\d_59_59_864' ) ; } + else + { + local $ENV{TZ} = 'GMT' ; + { + POSIX::tzset unless ('MSWin32' eq $OSNAME) ; + is( '1970_01_01_00_00_00_000', year_month_day_hour_min_sec_ms( ), + 'year_month_day_hour_min_sec_ms: no args => 1970_01_01_00_00_00_000 GMT' ) ; + is( '1970_01_01_00_00_00_000', year_month_day_hour_min_sec_ms( 0 ), + 'year_month_day_hour_min_sec_ms: 0 => 1970_01_01_00_00_00_000 GMT' ) ; + is( '1973_11_29_21_33_09_122', year_month_day_hour_min_sec_ms( 123456789.123 ), + 'year_month_day_hour_min_sec_ms: 123456789.123 => 1973_11_29_21_33_09_122 GMT' ) ; + is( '1969_12_31_23_59_59_000', year_month_day_hour_min_sec_ms( -1 ), + 'year_month_day_hour_min_sec_ms: -1 => 1969_12_31_23_59_59_000 GMT' ) ; + is( '1969_12_31_23_59_59_754', year_month_day_hour_min_sec_ms( -0.246 ), + 'year_month_day_hour_min_sec_ms: -0.246 => 1969_12_31_23_59_59_754 GMT' ) ; + is( '1966_02_02_02_26_50_864', year_month_day_hour_min_sec_ms( -123456789.135 ), + 'year_month_day_hour_min_sec_ms: -123456789.135 => 1966_02_02_02_26_50_864 GMT' ) ; + } + POSIX::tzset unless ('MSWin32' eq $OSNAME) ; + } + note( 'Leaving tests_year_month_day_hour_min_sec_ms()' ) ; + return ; +} - is( localtimez( ), localtimez( time ), 'localtimez: undef => equals currrent' ) ; - note( 'Leaving tests_localtimez()' ) ; +sub year_month_day_hour_min_sec_ms +{ + my $time = shift @ARG || 0 ; + + my $date_str = POSIX::strftime( '%Y_%m_%d_%H_%M_%S', localtime $time ) ; + # Because of ab tests or web accesses, more than one sync withing one second is possible + # so we add also milliseconds + $date_str .= sprintf "_%03d", fractional_of_floor( $time ) * 1000 ; + + return $date_str ; +} + + + +sub tests_fractional_of_floor +{ + note( 'Entering tests_fractional_of_floor()' ) ; + + is( 0, fractional_of_floor( ), 'fractional_of_floor: no args => 0' ) ; + is( 0, fractional_of_floor( 0 ), 'fractional_of_floor: 0 => 0' ) ; + is( 0, fractional_of_floor( '0' ), 'fractional_of_floor: 0 => 0' ) ; + is( 0, fractional_of_floor( 1 ), 'fractional_of_floor: 1 => 0' ) ; + is( 0, fractional_of_floor( '1' ), 'fractional_of_floor: 1 => 0' ) ; + is( 0, fractional_of_floor( -1 ), 'fractional_of_floor: -1 => 0' ) ; + is( 0, fractional_of_floor( '-1' ), 'fractional_of_floor: -1 => 0' ) ; + is( 0.234, fractional_of_floor( 1.234 ), 'fractional_of_floor: 1.234 => 0.234' ) ; + is( 0.234, fractional_of_floor( '1.234' ), 'fractional_of_floor: 1.234 => 0.234' ) ; + is( 0.766, fractional_of_floor( -1.234 ), 'fractional_of_floor: -1.234 => 0.766' ) ; + is( 0.766, fractional_of_floor( '-1.234' ), 'fractional_of_floor: -1.234 => 0.766' ) ; + is( 0.234, fractional_of_floor( 10.234 ), 'fractional_of_floor: 10.234 => 0.234' ) ; + is( 0.766, fractional_of_floor( -10.234 ), 'fractional_of_floor: -10.234 => 0.766' ) ; + + note( 'Leaving tests_fractional_of_floor()' ) ; return ; } -sub localtimez + +sub fractional_of_floor { - 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 ; + my $float = shift @ARG || 0 ; + + if ( $float - int( $float ) >= 0 ) + { + return( $float - int( $float ) ) ; + } + else + { + return( 1 - ( int( $float ) - $float ) ) ; + } } +sub tests_localtimez +{ + note( 'Entering tests_localtimez()' ) ; + note( "localtimez: " . localtimez( ) ) ; + if ( 'MSWin32' eq $OSNAME ) + { + like( localtimez( 0 ), qr'1970-01-01 \d\d:\d\d:\d\d', 'localtimez: 0 => match 1970-01-01 \d\d:\d\d:\d\d' ) ; + } + else + { + 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 or UTC' ) ; + } + is( localtimez( ), localtimez( time ), 'localtimez: undef => equals currrent' ) ; + note( 'Leaving tests_localtimez()' ) ; + return ; +} + +sub localtimez +{ + my $time = shift @ARG ; + + $time = defined( $time ) ? $time : time ; + + my $datetimestr ; + + if ( 'MSWin32' eq $OSNAME ) + { + $datetimestr = POSIX::strftime( '%A %d %B %Y-%m-%d %H:%M:%S %z', localtime( $time ) ) ; + } + else + { + $datetimestr = POSIX::strftime( '%A %d %B %Y-%m-%d %H:%M:%S %z %Z', localtime( $time ) ) ; + } + #myprint( "$datetimestr\n" ) ; + return $datetimestr ; +} + + sub tests_slash_to_underscore { @@ -18000,7 +20966,7 @@ sub tests_slash_to_underscore sub slash_to_underscore { - my $string = shift ; + my $string = shift @ARG ; if ( ! defined $string ) { return ; } @@ -18035,155 +21001,156 @@ sub tests_million_folders_baby_2 -sub tests_always_fail -{ - note( 'Entering tests_always_fail()' ) ; - - is( 0, 1, 'always_fail: 0 is 1' ) ; - - note( 'Leaving tests_always_fail()' ) ; - return ; -} - - -sub tests_logfileprepa -{ +sub tests_logfileprepa +{ note( 'Entering tests_logfileprepa()' ) ; is( undef, logfileprepa( ), 'logfileprepa: no args => undef' ) ; + + my $mysync = {} ; + is( undef, logfileprepa( $mysync ), 'logfileprepa: no logfile => undef' ) ; + my $logfile = 'W/tmp/tests/tests_logfileprepa.txt' ; - is( 1, logfileprepa( $logfile ), 'logfileprepa: W/tmp/tests/tests_logfileprepa.txt => 1' ) ; + is( 1, logfileprepa( $mysync, $logfile ), 'logfileprepa: W/tmp/tests/tests_logfileprepa.txt => 1' ) ; note( 'Leaving tests_logfileprepa()' ) ; return ; -} +} sub logfileprepa { - my $logfile = shift ; + my $mysync = shift @ARG ; + my $logfile = shift @ARG ; - if ( ! defined( $logfile ) ) + if ( ! defined( $mysync ) ) { return ; - }else + } + elsif ( ! defined( $logfile ) ) + { + return ; + } + else { - #myprint( "[$logfile]\n" ) ; my $dirname = dirname( $logfile ) ; - do_valid_directory( $dirname ) || return( 0 ) ; - return( 1 ) ; + return( make_valid_directory( $mysync, $dirname ) ) ; } } -sub tests_teelaunch -{ +sub tests_teelaunch +{ note( 'Entering tests_teelaunch()' ) ; - is( undef, teelaunch( ), 'teelaunch: no args => undef' ) ; + is( undef, teelaunch( ), 'tests_teelaunch: no args => undef' ) ; my $mysync = {} ; - is( undef, teelaunch( $mysync ), 'teelaunch: arg empty {} => undef' ) ; - $mysync->{logfile} = q{} ; - is( undef, teelaunch( $mysync ), 'teelaunch: logfile empty string => undef' ) ; + is( undef, teelaunch( $mysync ), 'tests_teelaunch: arg empty {} => undef' ) ; + is( undef, teelaunch( $mysync, '' ), 'tests_teelaunch: 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!') ; - is( "Hi!\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\n' ) ; - 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' ) ; + my $tee = teelaunch( $mysync, 'W/tmp/tests/tests_teelaunch.txt' ) ; + isa_ok( $tee, 'IO::Tee', 'tests_teelaunch: logfile W/tmp/tests/tests_teelaunch.txt' ) ; + is( 1, print( $tee "Hi!\n" ), 'tests_teelaunch: write Hi!') ; + is( "Hi!\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'tests_teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\n' ) ; + is( 1, print( $tee "Hoo\n" ), 'tests_teelaunch: write Hoo') ; + is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'tests_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') ; + # closing file handle so tee won't be happy + ($tee->handles)[0]->close ; + is( undef, print( $tee "Argh1\n" ), 'tests_teelaunch: write Argh1') ; + is( undef, print( $tee "Argh2\n" ), 'tests_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' ) ; + is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'tests_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') ; + is( 2, scalar $tee->handles, 'tests_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') ; + is( 1, scalar $tee->handles, 'tests_teelaunch: 1 handle') ; + is( 1, print( $tee "Argh3\n" ), 'tests_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') ; + is( 0, scalar $tee->handles, 'tests_teelaunch: 0 handle') ; + is( 1, print( $tee "Argh 4\n" ), 'tests_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' ) ; + $tee = teelaunch( $mysync, 'W/tmp/tests/tests_teelaunch2.txt' ) ; + isa_ok( $tee, 'IO::Tee' , 'tests_teelaunch: W/tmp/tests/tests_teelaunch2.txt' ) ; + is( 1, print( $tee "Hi!\n" ), 'tests_teelaunch: write Hi!') ; + is( "Hi!\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'tests_teelaunch: reading W/tmp/tests/tests_teelaunch2.txt is Hi!\n' ) ; + is( 1, print( $tee "Hoo\n" ), 'tests_teelaunch: write Hoo') ; + is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'tests_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') ; + is( 1, teefinish( $tee ), 'tests_teelaunch: teefinish return 1') ; + is( 1, print( $tee "Argh1\n" ), 'tests_teelaunch: write Argh1') ; + is( 1, print( $tee "Argh2\n" ), 'tests_teelaunch: write Argh2') ; + is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'tests_teelaunch: reading W/tmp/tests/tests_teelaunch2.txt is still Hi!\nHoo\n' ) ; + is( 1, teefinish( $tee ), 'tests_teelaunch: teefinish still return 1') ; note( 'Leaving tests_teelaunch()' ) ; return ; -} +} -sub teelaunch +sub teelaunch { - my $mysync = shift ; + my $mysync = shift @ARG ; + my $logfile = shift @ARG ; if ( ! defined( $mysync ) ) { return ; } - my $logfile = $mysync->{logfile} ; - if ( ! $logfile ) { return ; } - logfileprepa( $logfile ) || croak "Error no valid directory to write log file $logfile : $OS_ERROR" ; - + if ( not logfileprepa( $mysync, $logfile ) ) + { + carp( "Error no valid directory to write log file $logfile : $OS_ERROR" ) ; + } + + # To honor -T tainted mode. Could do better... + ( $logfile ) = $logfile =~ m{(.*)}x ; # This is a log file opened during the whole sync ## no critic (InputOutput::RequireBriefOpen) - open my $logfile_handle, '>', $logfile - or croak( "Can not open $logfile for write: $OS_ERROR" ) ; - binmode $logfile_handle, ":encoding(UTF-8)" ; - my $tee = IO::Tee->new( $logfile_handle, \*STDOUT ) ; - $tee->autoflush( 1 ) ; - $mysync->{logfile_handle} = $logfile_handle ; - $mysync->{tee} = $tee ; - return $tee ; + if ( ! open my $logfile_handle, '>', $logfile ) + { + carp( "Can not open $logfile for write: $OS_ERROR" ) ; + return ; + } + else + { + binmode $logfile_handle, ":encoding(UTF-8)" ; + my $tee = IO::Tee->new( $logfile_handle, \*STDOUT ) ; + $tee->autoflush( 1 ) ; + return $tee ; + } } -sub teefinish +sub teefinish { - my $mysync = shift ; - - if ( ! defined( $mysync ) ) { return ; } - - my $tee = $mysync->{tee} ; + my $tee = shift @ARG ; if ( ! defined( $tee ) ) { return ; } if ( 2 == scalar $tee->handles ) { - shift @{*{$tee}}; + my $handle = shift @{*{$tee}} ; + $handle->close ; } else { # nothing } return scalar $tee->handles ; -} +} sub getpwuid_any_os { - my $uid = shift ; + my $uid = shift @ARG ; return( scalar getlogin ) if ( 'MSWin32' eq $OSNAME ) ; # Windows system return( scalar getpwuid $uid ) ; # Unix system @@ -18195,7 +21162,7 @@ sub getpwuid_any_os sub abortifneeded { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( -e $mysync->{ abortfile } ) { myprint( "Asked to terminate by file $mysync->{ abortfile }\n" ) ; @@ -18212,9 +21179,11 @@ sub abortifneeded } } + + sub simulong { - my $mysync = shift ; + my $mysync = shift @ARG ; my $max_seconds = $mysync->{ simulong } ; @@ -18247,7 +21216,7 @@ sub printenv sub unittestssuite { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! ( $mysync->{ tests } or $mysync->{ testsdebug } or $mysync->{ testsunit } ) ) { return ; } @@ -18257,6 +21226,8 @@ sub unittestssuite testsdebug( $mysync ) ; testunitsession( $mysync ) ; + cleanup_mess_from_tests( ) ; + my @summary = $test_builder->summary() ; my @details = $test_builder->details() ; my $nb_tests_run = scalar( @summary ) ; @@ -18269,34 +21240,44 @@ sub unittestssuite "List of failed tests:\n", $tests_failed ) ; return $EXIT_TESTS_FAILED ; } - - cleanup_mess_from_tests( ) ; - return 0 ; } sub cleanup_mess_from_tests { undef @pipemess ; + undef @include ; + undef @exclude ; + undef @folderfirst ; + undef @folderlast ; + undef @h1_folders_all ; + undef %h1_folders_all ; + undef @h2_folders_all ; + undef %h2_folders_all ; + undef @h2_folders_from_1_wanted ; + undef %h2_folders_from_1_all ; + undef %requested_folder ; + return ; } -sub after_get_options +sub after_get_options { - my $mysync = shift ; - my $numopt = shift ; + my $mysync = shift @ARG ; + my $numopt = shift @ARG ; # exit with --help option or no option at all $mysync->{ debug } and myprint( "numopt:$numopt\n" ) ; - if ( $help or not $numopt ) { + if ( $mysync->{ help } or not $numopt ) + { myprint( usage( $mysync ) ) ; exit ; } return ; -} +} sub tests_remove_edging_blanks { @@ -18314,7 +21295,7 @@ sub tests_remove_edging_blanks sub remove_edging_blanks { - my $string = shift ; + my $string = shift @ARG ; if ( ! defined $string ) { return ; @@ -18345,7 +21326,7 @@ sub tests_sanitize sub sanitize { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! defined $mysync ) { return ; @@ -18360,47 +21341,56 @@ sub sanitize sub easyany { - my $mysync = shift ; + my $mysync = shift @ARG ; # Gmail - if ( $mysync->{gmail1} and $mysync->{gmail2} ) { + if ( $mysync->{gmail1} and $mysync->{gmail2} ) + { $mysync->{ debug } and myprint( "gmail1 gmail2\n") ; gmail12( $mysync ) ; return ; } - if ( $mysync->{gmail1} ) { + if ( $mysync->{gmail1} ) + { $mysync->{ debug } and myprint( "gmail1\n" ) ; gmail1( $mysync ) ; } - if ( $mysync->{gmail2} ) { + if ( $mysync->{gmail2} ) + { $mysync->{ debug } and myprint( "gmail2\n" ) ; gmail2( $mysync ) ; } # Office 365 - if ( $mysync->{office1} ) { + if ( $mysync->{office1} ) + { office1( $mysync ) ; } - if ( $mysync->{office2} ) { + if ( $mysync->{office2} ) + { office2( $mysync ) ; } # Exchange - if ( $mysync->{exchange1} ) { + if ( $mysync->{exchange1} ) + { exchange1( $mysync ) ; } - if ( $mysync->{exchange2} ) { + if ( $mysync->{exchange2} ) + { exchange2( $mysync ) ; } # Domino - if ( $mysync->{domino1} ) { + if ( $mysync->{domino1} ) + { domino1( $mysync ) ; } - if ( $mysync->{domino2} ) { + if ( $mysync->{domino2} ) + { domino2( $mysync ) ; } @@ -18408,67 +21398,70 @@ sub easyany } # From and for https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt -sub gmail12 +# globals @exclude @folderlast +sub gmail12 { - my $mysync = shift ; + my $mysync = shift @ARG ; # Gmail at host1 and host2 $mysync->{host1} ||= 'imap.gmail.com' ; $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 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->{ maxbytespersecond } ||= 300_000 ; # should be less than 10_000 when computed from Gmail documentation + $mysync->{ maxbytesafter } ||= 3_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 ; + $mysync->{ skipcrossduplicates } = ( defined $mysync->{ skipcrossduplicates } ) ? $mysync->{ skipcrossduplicates } : 0 ; $mysync->{ synclabels } = ( defined $mysync->{ synclabels } ) ? $mysync->{ synclabels } : 1 ; $mysync->{ resynclabels } = ( defined $mysync->{ resynclabels } ) ? $mysync->{ resynclabels } : 1 ; - push @useheader, 'X-Gmail-Received', 'Message-Id' ; + $mysync->{ idatefromheader } = ( defined $mysync->{ idatefromheader } ) ? $mysync->{ idatefromheader } : 1 ; + push @{ $mysync->{ useheader } } , 'X-Gmail-Received', 'Message-Id' ; push @exclude, '\[Gmail\]$' ; - push @folderlast, '[Gmail]/All Mail' ; + push @folderlast, '[Gmail]/Sent Mail', '[Gmail]/Important', '[Gmail]/Starred', '[Gmail]/Drafts', '[Gmail]/Trash', '[Gmail]/Spam', '[Gmail]/Chats', '[Gmail]/All Mail' ; return ; -} - +} +# globals @folderlast sub gmail1 { - my $mysync = shift ; + my $mysync = shift @ARG ; # Gmail at host2 $mysync->{host1} ||= 'imap.gmail.com' ; $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; - $mysync->{maxbytespersecond} ||= 40_000 ; # should be 30_000 computed from by Gmail documentation - $mysync->{maxbytesafter} ||= 3_000_000_000 ; # + $mysync->{ maxbytespersecond } ||= 300_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 ; + $mysync->{ skipcrossduplicates } = ( defined $mysync->{ skipcrossduplicates } ) ? $mysync->{ skipcrossduplicates } : 1 ; - push @useheader, 'X-Gmail-Received', 'Message-Id' ; + push @{ $mysync->{ useheader } }, 'X-Gmail-Received', 'Message-Id' ; push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ; - push @folderlast, '[Gmail]/All Mail' ; + push @folderlast, '[Gmail]/Sent Mail', '[Gmail]/Important', '[Gmail]/Starred', '[Gmail]/Drafts', '[Gmail]/Trash', '[Gmail]/Spam', '[Gmail]/Chats', '[Gmail]/All Mail' ; return ; } +# globals @exclude @folderlast sub gmail2 { - my $mysync = shift ; + my $mysync = shift @ARG ; # Gmail at host2 $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->{ maxbytespersecond } ||= 300_000 ; # should be less than 10_000 computed from by Gmail documentation + $mysync->{ maxbytesafter } ||= 3_000_000_000 ; # In fact it is documented as half: 500_000_000 $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->{ maxsleep } = ( defined $mysync->{ maxsleep } ) ? $mysync->{ maxsleep } : $MAX_SLEEP ; + $mysync->{ idatefromheader } = ( defined $mysync->{ idatefromheader } ) ? $mysync->{ idatefromheader } : 1 ; #$mysync->{ maxsize } = ( defined $mysync->{ maxsize } ) ? $mysync->{ maxsize } : $GMAIL_MAXSIZE ; - if ( ! $mysync->{ noexclude } ) { + if ( ! $mysync->{ noexclude } ) + { push @exclude, '\[Gmail\]$' ; } - push @useheader, 'Message-Id' ; + push @{ $mysync->{ useheader } } , 'Message-Id' ; push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ; # push @{ $mysync->{ regextrans2 } }, 's/[ ]+/_/g' ; # is now replaced @@ -18478,16 +21471,16 @@ sub gmail2 push @{ $mysync->{ regextrans2 } }, 's,/ +| +/,/,g' ; # push @{ $mysync->{ regextrans2 } }, q{s/['\\^"]/_/g} ; # Verified this - push @folderlast, '[Gmail]/All Mail' ; + push @folderlast, '[Gmail]/Sent Mail', '[Gmail]/Important', '[Gmail]/Starred', '[Gmail]/Drafts', '[Gmail]/Trash', '[Gmail]/Spam', '[Gmail]/Chats', '[Gmail]/All Mail' ; return ; -} +} # From https://imapsync.lamiral.info/FAQ.d/FAQ.Exchange.txt sub office1 { # Office 365 at host1 - my $mysync = shift ; + my $mysync = shift @ARG ; output( $mysync, q{Option --office1 is like: --host1 outlook.office365.com --ssl1 --exclude "^Files$"} . "\n" ) ; output( $mysync, "Option --office1 (cont) : unless overrided with --host1 otherhost --nossl1 --noexclude\n" ) ; @@ -18503,7 +21496,7 @@ sub office1 sub office2 { # Office 365 at host2 - my $mysync = shift ; + my $mysync = shift @ARG ; output( $mysync, qq{Option --office2 is like: --host2 outlook.office365.com --ssl2 --maxsize 45_000_000 --maxmessagespersecond 4\n} ) ; output( $mysync, qq{Option --office2 (cont) : --disarmreadreceipts --regexmess "wrap 10500" --f1f2 "Files=Files_renamed_by_imapsync"\n} ) ; output( $mysync, qq{Option --office2 (cont) : unless overrided with --host2 otherhost --nossl2 ... --nodisarmreadreceipts --noregexmess\n} ) ; @@ -18513,7 +21506,7 @@ sub office2 $mysync->{ maxsize } ||= 45_000_000 ; $mysync->{maxmessagespersecond} ||= 4 ; #push @{ $mysync->{ regexflag } }, 's/\\\\Flagged//g' ; # No problem without! tested 2018_09_10 - $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ; + $mysync->{ disarmreadreceipts } = ( defined $mysync->{ disarmreadreceipts } ) ? $mysync->{ disarmreadreceipts } : 1 ; # I dislike double negation but here is one if ( ! $mysync->{noregexmess} ) { @@ -18530,7 +21523,7 @@ sub office2 sub exchange1 { # Exchange 2010/2013 at host1 - my $mysync = shift ; + my $mysync = shift @ARG ; output( $mysync, "Option --exchange1 does nothing (except printing this line...)\n" ) ; # Well nothing to do so far return ; @@ -18539,13 +21532,13 @@ sub exchange1 sub exchange2 { # Exchange 2010/2013 at host2 - my $mysync = shift ; + my $mysync = shift @ARG ; output( $mysync, "Option --exchange2 is like: --maxsize 10_000_000 --maxmessagespersecond 4 --disarmreadreceipts\n" ) ; output( $mysync, "Option --exchange2 (cont) : --regexflag del Flagged --regexmess wrap 10500\n" ) ; output( $mysync, "Option --exchange2 (cont) : unless overrided with --maxsize xxx --nodisarmreadreceipts --noregexflag --noregexmess\n" ) ; $mysync->{ maxsize } ||= 10_000_000 ; $mysync->{maxmessagespersecond} ||= 4 ; - $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ; + $mysync->{ disarmreadreceipts } = ( defined $mysync->{ disarmreadreceipts } ) ? $mysync->{ disarmreadreceipts } : 1 ; # I dislike double negation but here are two if ( ! $mysync->{noregexflag} ) { push @{ $mysync->{ regexflag } }, 's/\\\\Flagged//g' ; @@ -18556,28 +21549,28 @@ sub exchange2 return ; } -sub domino1 +sub domino1 { # Domino at host1 - my $mysync = shift ; + my $mysync = shift @ARG ; $mysync->{ sep1 } = q{\\} ; - $prefix1 = q{} ; + $mysync->{ prefix1 } = q{} ; $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ; return ; -} +} -sub domino2 +sub domino2 { # Domino at host1 - my $mysync = shift ; + my $mysync = shift @ARG ; $mysync->{ sep2 } = q{\\} ; - $prefix2 = q{} ; + $mysync->{ prefix2 } = q{} ; $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ; push @{ $mysync->{ regextrans2 } }, 's,^Inbox\\\\(.*),$1,i' ; return ; -} +} sub tests_resolv @@ -18618,7 +21611,8 @@ sub resolv if ( ! $host ) { return ; } my $addr ; - if ( defined &Socket::getaddrinfo ) { + if ( defined &Socket::getaddrinfo ) + { $addr = resolv_with_getaddrinfo( $host ) ; return( $addr ) ; } @@ -18640,7 +21634,8 @@ sub resolv_with_getaddrinfo if ( ! $host ) { return ; } my ( $err_getaddrinfo, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ; - if ( $err_getaddrinfo ) { + if ( $err_getaddrinfo ) + { myprint( "Cannot getaddrinfo of $host: $err_getaddrinfo\n" ) ; return ; } @@ -18648,10 +21643,13 @@ sub resolv_with_getaddrinfo my @addr ; while( my $ai = shift @res ) { my ( $err_getnameinfo, $ipaddr ) = Socket::getnameinfo( $ai->{addr}, Socket::NI_NUMERICHOST(), Socket::NIx_NOSERV() ) ; - if ( $err_getnameinfo ) { + if ( $err_getnameinfo ) + { myprint( "Cannot getnameinfo of $host: $err_getnameinfo\n" ) ; return ; - }else{ + } + else + { $sync->{ debug } and myprint( "$host => $ipaddr\n" ) ; push @addr, $ipaddr ; my $reverse ; @@ -18698,7 +21696,8 @@ sub resolvrev if ( ! $host ) { return ; } - if ( defined &Socket::getaddrinfo ) { + if ( defined &Socket::getaddrinfo ) + { my $name = resolvrev_with_getaddrinfo( $host ) ; return( $name ) ; } @@ -18713,7 +21712,8 @@ sub resolvrev_with_getaddrinfo if ( ! $host ) { return ; } my ( $err, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ; - if ( $err ) { + if ( $err ) + { myprint( "Cannot getaddrinfo of $host: $err\n" ) ; return ; } @@ -18721,7 +21721,8 @@ sub resolvrev_with_getaddrinfo my @name ; while( my $ai = shift @res ) { my ( $err, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ; - if ( $err ) { + if ( $err ) + { myprint( "Cannot getnameinfo of $host: $err\n" ) ; return ; } @@ -18748,7 +21749,7 @@ sub tests_imapsping sub imapsping { - my $host = shift ; + my $host = shift @ARG ; return tcpping( $host, $IMAP_SSL_PORT ) ; } @@ -18779,7 +21780,8 @@ sub tests_tcpping sub tcpping { - if ( 2 != scalar( @ARG ) ) { + if ( 2 != scalar( @ARG ) ) + { return ; } my ( $host, $port ) = @ARG ; @@ -18798,7 +21800,8 @@ sub tcpping my $rtt_approx = sprintf( "%.3f", $rtt ) ; $sync->{ debug } and myprint( "Host $host timeout $mytimeout port $port ok $ping_ok ip $ip acked in $rtt_approx s\n" ) ; $p->close( ) ; - if( $ping_ok ) { + if( $ping_ok ) + { return 1 ; }else{ return 0 ; @@ -18860,77 +21863,195 @@ sub tests_sslcheck return ; } + + sub sslcheck { - my $mysync = shift ; + my $mysync = shift @ARG ; - if ( ! $mysync->{sslcheck} ) { + if ( ! $mysync->{ sslcheck } ) + { return ; } my $nb_on = 0 ; - $mysync->{ debug } and myprint( "sslcheck\n" ) ; + $mysync->{ debug } and myprint( "Doing sslcheck\n" ) ; if ( - ( ! defined $mysync->{port1} ) + ( ! defined $mysync->{ tls1 } ) and - ( ! defined $mysync->{tls1} ) + ( ! defined $mysync->{ ssl1 } ) and - ( ! defined $mysync->{ssl1} ) - and - ( defined $mysync->{host1} ) - ) { - myprint( "Host1: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ; - if ( probe_imapssl( $mysync->{host1} ) ) { - $mysync->{ssl1} = 1 ; - myprint( "Host1: sslcheck detected open ssl port $IMAP_SSL_PORT so turning ssl on (use --nossl1 --notls1 to turn off SSL and TLS wizardry)\n" ) ; + ( defined $mysync->{ host1 } ) + ) + { + my $port = $mysync->{ port1 } || $IMAP_SSL_PORT ; + myprint( "Host1: probing ssl on port $port ( use --nosslcheck to avoid this ssl probe ) \n" ) ; + if ( probe_imapssl( $mysync->{ host1 }, $port ) ) + { + $mysync->{ ssl1 } = 1 ; + myprint( "Host1: sslcheck detected open ssl port $port so turning ssl on (use --nossl1 --notls1 to turn off SSL and TLS wizardry)\n" ) ; $nb_on++ ; }else{ - myprint( "Host1: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ; + myprint( "Host1: sslcheck did not detected open ssl port $port. Will use standard connection.\n" ) ; } } if ( - ( ! defined $mysync->{port2} ) + ( ! defined $mysync->{ tls2 } ) and - ( ! defined $mysync->{tls2} ) + ( ! defined $mysync->{ ssl2 } ) and - ( ! defined $mysync->{ssl2} ) - and - ( defined $mysync->{host2} ) - ) { - myprint( "Host2: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ; - if ( probe_imapssl( $mysync->{host2} ) ) { - $mysync->{ssl2} = 1 ; - myprint( "Host2: sslcheck detected open ssl port $IMAP_SSL_PORT so turning ssl on (use --nossl2 --notls2 to turn off SSL and TLS wizardry)\n" ) ; + ( defined $mysync->{ host2 } ) + ) + { + my $port = $mysync->{ port2 } || $IMAP_SSL_PORT ; + myprint( "Host2: probing ssl on port $port ( use --nosslcheck to avoid this ssl probe ) \n" ) ; + if ( probe_imapssl( $mysync->{ host2 }, $port ) ) { + $mysync->{ ssl2 } = 1 ; + myprint( "Host2: sslcheck detected open ssl port $port so turning ssl on (use --nossl2 --notls2 to turn off SSL and TLS wizardry)\n" ) ; $nb_on++ ; }else{ - myprint( "Host2: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ; + myprint( "Host2: sslcheck did not detected open ssl port $port. Will use standard connection.\n" ) ; } } return $nb_on ; } + +sub tests_setlog +{ + note( 'Entering tests_setlog()' ) ; + + is( undef, setlog( ), 'tests_setlog: no args => undef' ) ; + + do { + # Not in cgi context + delete local $ENV{ SERVER_SOFTWARE } ; + delete local $ENV{ NET_SERVER_SOFTWARE } ; + my $mysync = { } ; + $mysync->{ dockercontext } = 0 ; + is( 1, setlog( $mysync ), 'tests_setlog: default => log is on' ) ; + myprint( output( $mysync ) ) ; + } ; + do { + # In Docker+CGI context + local $ENV{ SERVER_SOFTWARE } = 'under imapsync' ; + my $mysync = { } ; + $mysync->{ dockercontext } = 1 ; + is( 1, setlog( $mysync ), 'tests_setlog: SERVER_SOFTWARE set + Docker => log is on' ) ; + myprint( output( $mysync ) ) ; + } ; + do { + # In Docker+CGI context + local $ENV{ NET_SERVER_SOFTWARE } = 'Net::Server::HTTP' ; + my $mysync = { } ; + $mysync->{ dockercontext } = 1 ; + is( 1, setlog( $mysync ), 'tests_setlog: NET_SERVER_SOFTWARE set + Docker => log is on' ) ; + myprint( output( $mysync ) ) ; + } ; + do { + # Not in cgi context + Docker context + delete local $ENV{ SERVER_SOFTWARE } ; + delete local $ENV{ NET_SERVER_SOFTWARE } ; + my $mysync = { } ; + $mysync->{ dockercontext } = 1 ; + is( 0, setlog( $mysync ), 'tests_setlog: Docker context, not CGI => log is off' ) ; + myprint( output( $mysync ) ) ; + } ; + do { + # In cgi context + local $ENV{ SERVER_SOFTWARE } = 'under imapsync' ; + my $mysync = { } ; + is( 1, setlog( $mysync ), 'tests_setlog: CGI context => log is on' ) ; + myprint( output( $mysync ) ) ; + } ; + note( 'Leaving tests_setlog()' ) ; + return ; +} + + + +sub setlog +{ + my $mysync = shift @ARG ; + + if ( ! defined( $mysync ) ) { return ; } + + if ( defined $mysync->{ log } ) + { + if ( $mysync->{ log } ) + { + if ( under_docker_context( $mysync ) ) + { + output( $mysync, "Logging in Docker context. Be sure you added access to the logfile with a mount or similar. See https://docs.docker.com/storage/volumes/\n" ) ; + } + else + { + output( $mysync, "Logging is on. To turn off logging, use --nolog\n" ) ; + } + } + else + { + output( $mysync, "Logging is off. To turn on logging, use --log\n" ) ; + } + } + elsif ( under_docker_context( $mysync ) and ( under_Net_Server_HTTP( $mysync ) or under_cgi_context( $mysync ) ) ) + { + $mysync->{ log } = 1 ; + output( $mysync, "Logging to a logfile in Docker+CGI context, by default. To turn off logging, use --nolog\n" ) ; + } + elsif ( under_docker_context( $mysync ) ) + { + $mysync->{ log } = 0 ; + output( $mysync, "No log to a logfile in basic Docker context, by default. To turn on logging, use --log\n" ) ; + } + else + { + output( $mysync, "Logging to a logfile by default. To turn off logging, use --nolog\n" ) ; + $mysync->{ log } = 1 ; + } + return $mysync->{ log } ; +} + + + sub testslive_init { - my $mysync = shift ; - $mysync->{host1} ||= 'test1.lamiral.info' ; - $mysync->{user1} ||= 'test1' ; - $mysync->{password1} ||= 'secret1' ; - $mysync->{host2} ||= 'test2.lamiral.info' ; - $mysync->{user2} ||= 'test2' ; - $mysync->{password2} ||= 'secret2' ; + my $mysync = shift @ARG ; + $mysync->{ host1 } ||= 'test1.lamiral.info' ; + $mysync->{ user1 } ||= 'test1' ; + $mysync->{ password1 } ||= 'secret1' ; + $mysync->{ host2 } ||= 'test2.lamiral.info' ; + $mysync->{ user2 } ||= 'test2' ; + $mysync->{ password2 } ||= 'secret2' ; return ; } +sub testslive2_init +{ + my $mysync = shift @ARG ; + $mysync->{ host1 } ||= 'test2.lamiral.info' ; + $mysync->{ user1 } ||= 'test2' ; + $mysync->{ password1 } ||= 'secret2' ; + $mysync->{ host2 } ||= 'test1.lamiral.info' ; + $mysync->{ user2 } ||= 'test1' ; + $mysync->{ password2 } ||= 'secret1' ; + return ; +} + + + + + sub testslive6_init { - my $mysync = shift ; - $mysync->{host1} ||= 'ks6ipv6.lamiral.info' ; - $mysync->{user1} ||= 'test1' ; - $mysync->{password1} ||= 'secret1' ; - $mysync->{host2} ||= 'ks6ipv6.lamiral.info' ; - $mysync->{user2} ||= 'test2' ; - $mysync->{password2} ||= 'secret2' ; + my $mysync = shift @ARG ; + $mysync->{ host1 } ||= 'test1ipv6.lamiral.info' ; + $mysync->{ user1 } ||= 'test1' ; + $mysync->{ password1 } ||= 'secret1' ; + $mysync->{ host2 } ||= 'test2ipv6.lamiral.info' ; + $mysync->{ user2 } ||= 'test2' ; + $mysync->{ password2 } ||= 'secret2' ; return ; } @@ -18956,7 +22077,7 @@ sub tests_backslash_caret sub backslash_caret { - my $string = shift ; + my $string = shift @ARG ; $string =~ s{\\ $ }{^}gxms ; @@ -18968,20 +22089,24 @@ sub tests_split_around_equal note( 'Entering tests_split_around_equal()' ) ; is( undef, split_around_equal( ), 'split_around_equal: no args => undef' ) ; - is_deeply( { toto => 'titi' }, { split_around_equal( 'toto=titi' ) }, 'split_around_equal: toto=titi => toto => titi' ) ; - is_deeply( { A => 'B', C => 'D' }, { split_around_equal( 'A=B=C=D' ) }, 'split_around_equal: toto=titi => toto => titi' ) ; + is_deeply( { toto => 'titi' }, { split_around_equal( 'toto=titi' ) }, 'split_around_equal: toto=titi => toto => titi' ) ; + is_deeply( { toto => undef }, { split_around_equal( 'toto' ) }, 'split_around_equal: tototiti => toto => undef' ) ; + is_deeply( { toto => '' }, { split_around_equal( 'toto=' ) }, 'split_around_equal: tototiti => toto= => empty' ) ; is_deeply( { A => 'B', C => 'D' }, { split_around_equal( 'A=B', 'C=D' ) }, 'split_around_equal: A=B C=D => A => B, C=>D' ) ; + is_deeply( { A => 'B', C => 'D', E => 'F' }, { split_around_equal( 'A=B', 'C=D', 'E=F' ) }, 'split_around_equal: A=B C=D => A => B, C=>D' ) ; + is_deeply( { A => 'B=C' }, { split_around_equal( 'A=B=C' ) }, 'split_around_equal: A=B=C => A => B=C' ) ; + is_deeply( { A => 'B=C=D' }, { split_around_equal( 'A=B=C=D' ) }, 'split_around_equal: A=B=C=D => A => B=C=D' ) ; note( 'Leaving tests_split_around_equal()' ) ; return ; } -sub split_around_equal -{ +sub split_around_equal +{ if ( ! @ARG ) { return ; } ; - return map { split /=/mxs, $_ } @ARG ; + return map { split( /=/mxs, $_, 2 ) } @ARG ; -} +} @@ -19043,9 +22168,9 @@ sub tests_sig_install # sub sig_install { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! $mysync ) { return ; } - my $mysubname = shift ; + my $mysubname = shift @ARG ; if ( ! $mysubname ) { return ; } if ( ! @ARG ) { return ; } @@ -19057,7 +22182,7 @@ sub sig_install $mysync->{ debugsig } and myprint( "In sig_install with sub $mysubname and signal @ARG\n" ) ; my $subsignal = sub { - my $signame = shift ; + my $signame = shift @ARG ; $mysync->{ debugsig } and myprint( "In subsignal with $signame and $mysubname\n" ) ; &$mysub( $mysync, $signame ) ; } ; @@ -19074,7 +22199,7 @@ sub sig_install sub tototo { - my $mysync = shift ; + my $mysync = shift @ARG ; myprint("In tototo with @ARG\n" ) ; $mysync->{ tototo_calls } += 1 ; return ; @@ -19142,7 +22267,7 @@ sub tests_toggle_sleep sub toggle_sleep { - my $mysync = shift ; + my $mysync = shift @ARG ; myprint("In toggle_sleep with @ARG\n" ) ; @@ -19156,7 +22281,7 @@ sub toggle_sleep sub mypod2usage { - my $fh_pod2usage = shift ; + my $fh_pod2usage = shift @ARG ; pod2usage( -exitval => 'NOEXIT', @@ -19173,7 +22298,7 @@ sub mypod2usage sub usage { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! defined $mysync ) { return ; } @@ -19215,7 +22340,7 @@ sub tests_usage sub usage_footer { - my $mysync = shift ; + my $mysync = shift @ARG ; my $footer = q{} ; @@ -19273,8 +22398,8 @@ sub setvalfromcgikey my ( $mysync, $mycgi, $key, $val ) = @ARG ; my $badthings = 0 ; - - + + my ( $name, $type, $struct ) ; if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/mxs ) { @@ -19287,7 +22412,7 @@ sub setvalfromcgikey $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 @@ -19301,7 +22426,7 @@ sub setvalfromcgikey { setvalfromhash( $val, $type, @values ) ; } - else + else { setvalfromlist( $mysync, $val, $name, $type, $struct, @values ) ; } @@ -19310,7 +22435,7 @@ sub setvalfromcgikey { setvalfromcheckbox( $mysync, $mycgi, $key, $name, $val ) ; } - + return $badthings ; } @@ -19344,7 +22469,7 @@ sub setvalfromlist else { } - + return ; } sub setvalfromhash @@ -19371,11 +22496,11 @@ sub setvalfromhash { %{ ${$val} } = %values ; } - else + else { %{$val} = %values ; } - + return ; } @@ -19383,7 +22508,7 @@ sub setvalfromhash sub setvalfromcheckbox { my ( $mysync, $mycgi, $key, $name, $val ) = @ARG ; - + # Checkbox # --noname is set by name=0 or name= my $value = $mycgi->param( $name ) ; @@ -19413,7 +22538,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. + # It also applies for the sub setvalfromcgikey called from this one. my $mysync = shift @ARG ; my $arguments_ref = shift @ARG ; @@ -19437,7 +22562,7 @@ sub myGetOptions $badthings += setvalfromcgikey( $mysync, $mycgi, $key, $val ) ; } - + if ( $badthings ) { return ; # undef or () } @@ -19448,51 +22573,56 @@ sub myGetOptions -sub tests_get_options_extra +sub tests_get_options_extra_from_file { - note( 'Entering tests_get_options_extra()' ) ; - - is( undef, get_options_extra( ), 'get_options_extra: no args => undef' ) ; + note( 'Entering tests_get_options_extra_from_file()' ) ; + is( undef, get_options_extra_from_file( ), 'tests_get_options_extra_from_file: no args => undef' ) ; + my $mysync = { } ; - is( undef, get_options_extra( $mysync ), 'get_options_extra: undef => undef' ) ; - + is( undef, get_options_extra_from_file( $mysync ), 'tests_get_options_extra_from_file: undef => undef' ) ; + my $cwd_save = getcwd( ) ; - - ok( (-d 'W/tmp/tests/options_extra/' or mkpath( 'W/tmp/tests/options_extra/' )), 'get_options_extra: mkpath W/tmp/tests/options_extra/' ) ; - + + ok( (-d 'W/tmp/tests/options_extra/' or mkpath( 'W/tmp/tests/options_extra/' )), 'tests_get_options_extra_from_file: mkpath W/tmp/tests/options_extra/' ) ; + chdir 'W/tmp/tests/options_extra/' ; + + is( '--debugimap1', string_to_file( '--debugimap1', 'options_extra.txt' ), 'tests_get_options_extra_from_file: string_to_file filling options_extra.txt with --debugimap1' ) ; + is( '--debugimap1', file_to_string( 'options_extra.txt' ), 'tests_get_options_extra_from_file: reading options_extra.txt is --debugimap1' ) ; + is( '', get_options_extra_from_file( $mysync ), 'tests_get_options_extra_from_file: --debugimap1 in options_extra.txt => nothing left, empty string return' ) ; + is( 1, $mysync->{ acc1 }->{ debugimap }, 'tests_get_options_extra_from_file: --debugimap1 in options_extra.txt => ok, acc1->debugimap = 1' ) ; + + is( '--tls1 proutcaca', string_to_file( '--tls1 proutcaca', 'options_extra.txt' ), 'tests_get_options_extra_from_file: string_to_file filling options_extra.txt with --tls1 proutcaca' ) ; + is( 'proutcaca', get_options_extra_from_file( $mysync ), 'tests_get_options_extra_from_file: --tls1 proutcaca in options_extra.txt => proutcaca left, proutcaca return' ) ; + is( 1, $mysync->{ tls1 }, 'tests_get_options_extra_from_file: --tls1 proutcaca" => tls1 = 1' ) ; - is( '--debugimap1', string_to_file( '--debugimap1', 'options_extra.txt' ), 'get_options_extra: string_to_file filling options_extra.txt with --debugimap1' ) ; - - is( '--debugimap1', file_to_string( 'options_extra.txt' ), 'get_options_extra: reading options_extra.txt is --debugimap1' ) ; - - is( '', get_options_extra( $mysync ), 'get_options_extra: --debugimap1 in options_extra.txt => nothing left, empty string return' ) ; - - is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_extra: --debugimap1 in options_extra.txt => ok, acc1->debugimap = 1' ) ; - - is( '--tls1 proutcaca', string_to_file( '--tls1 proutcaca', 'options_extra.txt' ), 'get_options_extra: string_to_file filling options_extra.txt with --tls1 proutcaca' ) ; - - is( 'proutcaca', get_options_extra( $mysync ), 'get_options_extra: --tls1 proutcaca in options_extra.txt => proutcaca left, proutcaca return' ) ; + is( '--tls2 --proutcaca pipi', string_to_file( '--tls2 --proutcaca pipi', 'options_extra.txt' ), 'tests_get_options_extra_from_file: string_to_file filling options_extra.txt with --tls2 --proutcaca pipi' ) ; + is( '--proutcaca pipi', get_options_extra_from_file( $mysync ), 'tests_get_options_extra_from_file: --tls2 --proutcaca pipi in options_extra.txt => --proutcaca pipi return' ) ; + is( 1, $mysync->{ tls2 }, 'tests_get_options_extra_from_file: --tls2 proutcaca" => tls2 = 1' ) ; chdir $cwd_save ; - - note( 'Leaving tests_get_options_extra()' ) ; + + note( 'Leaving tests_get_options_extra_from_file()' ) ; return ; } -sub get_options_extra +sub get_options_extra_from_file { my $mysync = shift @ARG ; - + if ( ! defined $mysync ) { return ; } - + if ( -f -r 'options_extra.txt' ) { my $cwd = getcwd( ) ; my $string = firstline( 'options_extra.txt' ) ; my $rest = get_options_from_string( $mysync, $string ) ; - output( $mysync, "Reading extra options from file options_extra.txt (cwd: $cwd) : $string\n" ) ; + output( $mysync, "Reading extra options from file options_extra.txt (cwd: $cwd): $string\n" ) ; + if ( $rest ) + { + output( $mysync, "The following options were ignored from file options_extra.txt: $rest\n" ) ; + } return $rest ; } else @@ -19502,62 +22632,143 @@ sub get_options_extra } + +sub tests_get_options_extra_from_param +{ + note( 'Entering tests_get_options_extra_from_param()' ) ; + + is( undef, get_options_extra_from_param( ), 'tests_get_options_extra_from_param: no args => undef' ) ; + + my $mysync = { } ; + is( undef, get_options_extra_from_param( $mysync ), 'tests_get_options_extra_from_param: undef => undef' ) ; + + + $mysync->{ extra } = [ '--debugimap1' ] ; + is( '', get_options_extra_from_param( $mysync ), 'tests_get_options_extra_from_param: --extra --debugimap1 => nothing left, empty string return' ) ; + is( 1, $mysync->{ acc1 }->{ debugimap }, 'tests_get_options_extra_from_param: --debugimap1 in options_extra.txt => ok, acc1->debugimap = 1' ) ; + + $mysync->{ extra } = [ '--tls1 proutcaca' ] ; + is( 'proutcaca', get_options_extra_from_param( $mysync ), 'tests_get_options_extra_from_param: --extra "--tls1 proutcaca" => proutcaca left, proutcaca return' ) ; + is( 1, $mysync->{ tls1 }, 'tests_get_options_extra_from_param: --extra "--tls1 proutcaca" => tls1 = 1' ) ; + + $mysync->{ extra } = [ '--tls1 --proutcaca' ] ; + is( '--proutcaca', get_options_extra_from_param( $mysync ), 'tests_get_options_extra_from_param: --extra "--tls1 --proutcaca" => --proutcaca left, --proutcaca return' ) ; + is( 1, $mysync->{ tls1 }, 'tests_get_options_extra_from_param: --extra "--tls1 --proutcaca" => tls1 = 1' ) ; + + $mysync->{ extra } = [ '--oauthaccesstoken1 proutcaca' ] ; + is( '', get_options_extra_from_param( $mysync ), 'tests_get_options_extra_from_param: --extra "--oauthaccesstoken1 proutcaca" => nothing left, empty string return' ) ; + is( 'proutcaca', $mysync->{ acc1 }->{ oauthaccesstoken }, 'tests_get_options_extra_from_param: --extra "--oauthaccesstoken1 proutcaca" => ->{ acc1 }->{ oauthaccesstoken } = proutcaca' ) ; + + $mysync->{ extra } = [ '--folder "IN BOX" --folder JOE' ] ; + is( '', get_options_extra_from_param( $mysync ), 'tests_get_options_extra_from_param: --folder "IN BOX" --folder JOE => ok, empty string return' ) ; + is_deeply( [ 'IN BOX', 'JOE' ], [@{$mysync->{ folder }}], 'tests_get_options_extra_from_param: "IN BOX" "JOE"' ) ; + note( 'Leaving tests_get_options_extra_from_param()' ) ; + return ; +} + + +sub get_options_extra_from_param +{ + my $mysync = shift @ARG ; + + if ( ! defined $mysync ) { return ; } + + if ( $mysync->{ extra } ) + { + my $string = join( '', @{$mysync->{ extra }} ) ; + my $rest = get_options_from_string( $mysync, $string ) ; + output( $mysync, "Reading or overwriting options from parameter --extra: $string\n" ) ; + if ( $rest ) + { + output( $mysync, "The following options were ignored from parameter --extra: $rest\n" ) ; + } + return $rest ; + } + else + { + return ; + } +} + + + + sub tests_get_options_from_string { note( 'Entering tests_get_options_from_string()' ) ; - is( undef, get_options_from_string( ), 'get_options_from_string: no args => undef' ) ; + is( undef, get_options_from_string( ), 'tests_get_options_from_string: no args => undef' ) ; my $mysync = { } ; - is( undef, get_options_from_string( $mysync ), 'get_options_from_string: undef => undef' ) ; - - is( '', get_options_from_string( $mysync, '--debugimap1' ), - 'get_options_from_string: --debugimap1 => ok, nothing left, empty string return' ) ; - is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: --debugimap1 => ok, acc1->debugimap = 1' ) ; - + is( undef, get_options_from_string( $mysync ), 'tests_get_options_from_string: undef => undef' ) ; + + is( '', get_options_from_string( $mysync, '--debugimap1' ), + 'tests_get_options_from_string: --debugimap1 => ok, nothing left, empty string return' ) ; + is( 1, $mysync->{ acc1 }->{ debugimap }, 'tests_get_options_from_string: --debugimap1 => ok, acc1->debugimap = 1' ) ; + $mysync = { } ; # reset - is( 'caca', get_options_from_string( $mysync, '--debugimap1 caca' ), - 'get_options_from_string: --debugimap1 caca => ok, caca left, caca return' ) ; - is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: --debugimap1 => ok, acc1->debugimap = 1' ) ; - - is( 'popo roro', get_options_from_string( $mysync, '--debugimap2 popo roro' ), - 'get_options_from_string: --debugimap1 popo roro => ok, popo roro left, popo roro return' ) ; - is( 1, $mysync->{ acc2 }->{ debugimap }, 'get_options_from_string: --debugimap2 popo roro => ok, acc2->debugimap = 1' ) ; - is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: acc1->debugimap = 1 still' ) ; - - is( '', get_options_from_string( $mysync, '--nodebugimap1 --debugflags --errorsmax 2' ), - 'get_options_from_string: --nodebugimap1 --debugflags --errorsmax 2 => ok, empty string return' ) ; - - is( 0, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: acc1->debugimap = 0 now' ) ; - is( 1, $debugflags, 'get_options_from_string: debugflags = 1 now' ) ; - is( 2, $mysync->{ errorsmax }, 'get_options_from_string: mysync->errorsmax = 2 now' ) ; - - is( '', get_options_from_string( $mysync, '--folder "IN BOX" --folder JOE' ), - 'get_options_from_string: --folder "IN BOX" --folder JOE => ok, empty string return' ) ; - - is_deeply( [ 'IN BOX', 'JOE' ], [@{$mysync->{ folder }}], 'get_options_from_string: "IN BOX" "JOE"' ) ; - - is( '', get_options_from_string( $mysync, '--debugflags --koko' ), - 'get_options_from_string: --debugflags --koko => ok, empty string return, with "Unknown option: koko" on STDERR' ) ; + is( 'caca', get_options_from_string( $mysync, '--debugimap1 caca' ), + 'tests_get_options_from_string: --debugimap1 caca => ok, caca left, caca return' ) ; + is( 1, $mysync->{ acc1 }->{ debugimap }, 'tests_get_options_from_string: --debugimap1 => ok, acc1->debugimap = 1' ) ; + + is( 'popo roro', get_options_from_string( $mysync, '--debugimap2 popo roro' ), + 'tests_get_options_from_string: --debugimap1 popo roro => ok, popo roro left, popo roro return' ) ; + is( 1, $mysync->{ acc2 }->{ debugimap }, 'tests_get_options_from_string: --debugimap2 popo roro => ok, acc2->debugimap = 1' ) ; + is( 1, $mysync->{ acc1 }->{ debugimap }, 'tests_get_options_from_string: acc1->debugimap = 1 still' ) ; + is( '', get_options_from_string( $mysync, '--nodebugimap1 --debugflags --errorsmax 2' ), + 'tests_get_options_from_string: --nodebugimap1 --debugflags --errorsmax 2 => ok, empty string return' ) ; + + is( 0, $mysync->{ acc1 }->{ debugimap }, 'tests_get_options_from_string: acc1->debugimap = 0 now' ) ; + is( 1, $mysync->{ debugflags }, 'tests_get_options_from_string: debugflags = 1 now' ) ; + is( 2, $mysync->{ errorsmax }, 'tests_get_options_from_string: mysync->errorsmax = 2 now' ) ; + + is( '', get_options_from_string( $mysync, '--folder "IN BOX" --folder JOE' ), + 'tests_get_options_from_string: --folder "IN BOX" --folder JOE => ok, empty string return' ) ; + is_deeply( [ 'IN BOX', 'JOE' ], [@{$mysync->{ folder }}], 'tests_get_options_from_string: "IN BOX" "JOE"' ) ; + + is( '--koko', get_options_from_string( $mysync, '--debugflags --koko' ), + 'tests_get_options_from_string: --debugflags --koko => --koko' ) ; + + # string on multi-lines is ok, thanks Getopt::Long! + is( '', get_options_from_string( $mysync, '--folder "IN BOX ONE" + --folder JOE' ), + 'tests_get_options_from_string: --folder "IN BOX" --folder JOE => ok, empty string return' ) ; + is_deeply( [ 'IN BOX ONE', 'JOE' ], [@{$mysync->{ folder }}], 'tests_get_options_from_string: "IN BOX" "JOE"' ) ; + note( 'Leaving tests_get_options_from_string()' ) ; return ; } -sub get_options_from_string +# Be carefull that options here come after the cgi cleanup with get_options_extra_from_param() +# so do not add back dangerous options here. +sub get_options_from_string { my $mysync = shift @ARG ; my $mystring = shift @ARG ; - + if ( ! defined $mystring ) { return ; } - + my ( $ret, $args ) = Getopt::Long::GetOptionsFromString( $mystring, + '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 }, + 'dry1!' => \$mysync->{ dry1 }, + 'version' => \$mysync->{ version }, 'debugimap!' => \$mysync->{ debugimap }, 'debugimap1!' => \$mysync->{ acc1 }->{ debugimap }, 'debugimap2!' => \$mysync->{ acc2 }->{ debugimap }, - 'debugflags!' => \$debugflags, + 'debugflags!' => \$mysync->{ debugflags }, 'debugsleep=f' => \$mysync->{ debugsleep }, 'errorsmax=i' => \$mysync->{ errorsmax }, 'folder=s@' => \$mysync->{ folder }, + 'f1f2=s@' => \$mysync->{ f1f2 }, + 'folderrec=s@' => \$mysync->{ folderrec }, 'timeout=f' => \$mysync->{ timeout }, 'timeout1=f' => \$mysync->{ acc1 }->{ timeout }, 'timeout2=f' => \$mysync->{ acc2 }->{ timeout }, @@ -19565,16 +22776,85 @@ sub get_options_from_string 'keepalive2!' => \$mysync->{ acc2 }->{ keepalive }, 'reconnectretry1=i' => \$mysync->{ acc1 }->{ reconnectretry }, 'reconnectretry2=i' => \$mysync->{ acc2 }->{ reconnectretry }, + 'sslcheck!' => \$mysync->{ sslcheck }, 'ssl1!' => \$mysync->{ ssl1 }, 'ssl2!' => \$mysync->{ ssl2 }, 'tls1!' => \$mysync->{ tls1 }, 'tls2!' => \$mysync->{ tls2 }, + '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 }, + '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 }, 'compress1!' => \$mysync->{ acc1 }->{ compress }, 'compress2!' => \$mysync->{ acc2 }->{ compress }, + 'oauthaccesstoken1=s' => \$mysync->{ acc1 }->{ oauthaccesstoken }, + 'oauthaccesstoken2=s' => \$mysync->{ acc2 }->{ oauthaccesstoken }, + 'syncduplicates!' => \$mysync->{ syncduplicates }, + 'skipcrossduplicates!' => \$mysync->{ skipcrossduplicates }, + 'debugcrossduplicates!' => \$mysync->{ debugcrossduplicates }, + 'useheader=s@' => \$mysync->{ useheader }, + + 'testslive!' => \$mysync->{ testslive }, + 'testslive2!' => \$mysync->{ testslive2 }, + '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 }, + 'justfoldersizes!' => \$mysync->{ justfoldersizes }, + + + 'tail!' => \$mysync->{ tail }, + 'exitwhenover=i' => \$mysync->{ exitwhenover }, + 'exitonload!' => \$mysync->{ exitonload }, + 'syncduplicates!' => \$mysync->{ syncduplicates }, + 'skipcrossduplicates!' => \$mysync->{ skipcrossduplicates }, + 'debugcrossduplicates!'=> \$mysync->{ debugcrossduplicates }, + 'log!' => \$mysync->{ log }, + 'loglogfile!' => \$mysync->{ loglogfile }, + 'emailreportfrom=s' => \$mysync->{ email_report_from }, + 'emailreport1!' => \$mysync->{ emailreport1 }, + 'emailreport2!' => \$mysync->{ emailreport2 }, + + + + 'delete1!' => \$mysync->{ delete1 }, + 'expunge1!' => \$mysync->{ expunge1 }, + 'delete2!' => \$mysync->{ delete2 }, + 'expunge2!' => \$mysync->{ expunge2 }, + 'uidexpunge2!' => \$mysync->{ uidexpunge2 }, + 'delete2duplicates!' => \$mysync->{ delete2duplicates }, + 'delete1emptyfolders' => \$mysync->{ delete1emptyfolders }, + 'delete2folders!' => \$mysync->{ delete2folders }, + + 'minsize=i' => \$mysync->{ minsize }, + 'maxsize=i' => \$mysync->{ maxsize }, + 'maxage=f' => \$mysync->{ maxage }, + 'minage=f' => \$mysync->{ minage }, + 'search=s' => \$mysync->{ search }, + 'search1=s' => \$mysync->{ search1 }, + 'search2=s' => \$mysync->{ search2 }, + ) ; my $left = join( ' ', @$args ) ; return $left ; -} +} @@ -19586,7 +22866,7 @@ sub tests_get_options_cgi_context note( 'Entering tests_get_options_cgi_context()' ) ; -# Temporary, have to think harder about testing CGI context in command line --tests + # Temporary, have to think harder about testing CGI context in command line --tests # API: # * input arguments: two ways, command line or CGI # * the program arguments @@ -19605,92 +22885,88 @@ sub tests_get_options_cgi_context # skip all next tests if the CGI module is not available SKIP: { - if ( ! eval { require CGI ; } ) { + 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( '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' ) ; + 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( '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' ) ; - # QUERY_STRING in this test is only for return value of get_options - # Have to think harder, GET/POST context, is this return value a good thing? - local $ENV{'QUERY_STRING'} = 'host1=test1.lamiral.info&user1=test1' ; - $mysync->{cgi} = CGI->new( 'host1=test1.lamiral.info&user1=test1' ) ; - is( 36, get_options( $mysync, ), 'get_options cgi context: QUERY_STRING => 36' ) ; - is( 'test1', $mysync->{user1}, 'get_options cgi context: $mysync->{user1} => test1' ) ; - #local $ENV{'QUERY_STRING'} = undef ; + # QUERY_STRING in this test is only for return value of get_options + # Have to think harder, GET/POST context, is this return value a good thing? + local $ENV{'QUERY_STRING'} = 'host1=test1.lamiral.info&user1=test1' ; + $mysync->{cgi} = CGI->new( 'host1=test1.lamiral.info&user1=test1' ) ; + is( 36, get_options( $mysync, ), 'get_options cgi context: QUERY_STRING => 36' ) ; + is( 'test1', $mysync->{user1}, 'get_options cgi context: $mysync->{user1} => test1' ) ; + #local $ENV{'QUERY_STRING'} = undef ; - # Testing s@ as ref - $mysync->{cgi} = CGI->new( 'folder=fd1' ) ; - get_options( $mysync ) ; - is_deeply( [ 'fd1' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1' ) ; - $mysync->{cgi} = CGI->new( 'folder=fd1&folder=fd2' ) ; - get_options( $mysync ) ; - is_deeply( [ 'fd1', 'fd2' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1, fd2' ) ; + # Testing s@ as ref + $mysync->{cgi} = CGI->new( 'folder=fd1' ) ; + get_options( $mysync ) ; + is_deeply( [ 'fd1' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1' ) ; + $mysync->{cgi} = CGI->new( 'folder=fd1&folder=fd2' ) ; + get_options( $mysync ) ; + is_deeply( [ 'fd1', 'fd2' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1, fd2' ) ; - # Testing % - $mysync->{cgi} = CGI->new( 'f1f2h=s1=d1&f1f2h=s2=d2&f1f2h=s3=d3' ) ; - get_options( $mysync ) ; + # Testing % + $mysync->{cgi} = CGI->new( 'f1f2h=s1=d1&f1f2h=s2=d2&f1f2h=s3=d3' ) ; + get_options( $mysync ) ; - is_deeply( { 's1' => 'd1', 's2' => 'd2', 's3' => 'd3' }, - $mysync->{f1f2h}, 'get_options cgi context: f1f2h => s1=d1 s2=d2 s3=d3' ) ; + is_deeply( { 's1' => 'd1', 's2' => 'd2', 's3' => 'd3' }, + $mysync->{f1f2h}, 'get_options cgi context: f1f2h => s1=d1 s2=d2 s3=d3' ) ; - # Testing boolean ! with --noxxx, doesnot work - $mysync->{cgi} = CGI->new( 'nodry=on' ) ; - get_options( $mysync ) ; - is( undef, $mysync->{dry}, 'get_options cgi context: --nodry => $mysync->{dry} => undef' ) ; + # Testing boolean ! with --noxxx, doesnot work + $mysync->{cgi} = CGI->new( 'nodry=on' ) ; + get_options( $mysync ) ; + is( undef, $mysync->{ dry }, 'get_options cgi context: --nodry => $mysync->{ dry } => undef' ) ; - $mysync->{cgi} = CGI->new( 'host1=example.com' ) ; - get_options( $mysync ) ; - is( 'example.com', $mysync->{host1}, 'get_options cgi context: --host1=example.com => $mysync->{host1} => example.com' ) ; + $mysync->{cgi} = CGI->new( 'host1=example.com' ) ; + get_options( $mysync ) ; + is( 'example.com', $mysync->{host1}, 'get_options cgi context: --host1=example.com => $mysync->{host1} => example.com' ) ; - #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; - $mysync->{cgi} = CGI->new( 'simulong=' ) ; - get_options( $mysync ) ; - is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong= => $mysync->{simulong} => undef' ) ; + #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + $mysync->{cgi} = CGI->new( 'simulong=' ) ; + get_options( $mysync ) ; + is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong= => $mysync->{simulong} => undef' ) ; - $mysync->{cgi} = CGI->new( 'simulong' ) ; - get_options( $mysync ) ; - is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong => $mysync->{simulong} => undef' ) ; + $mysync->{cgi} = CGI->new( 'simulong' ) ; + get_options( $mysync ) ; + is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong => $mysync->{simulong} => undef' ) ; - $mysync->{cgi} = CGI->new( 'simulong=4' ) ; - get_options( $mysync ) ; - is( 4, $mysync->{simulong}, 'get_options cgi context: --simulong=4 => $mysync->{simulong} => 4' ) ; - is( undef, $mysync->{ folder }, 'get_options cgi context: --simulong=4 => $mysync->{ folder } => undef' ) ; - #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + $mysync->{cgi} = CGI->new( 'simulong=4' ) ; + get_options( $mysync ) ; + is( 4, $mysync->{simulong}, 'get_options cgi context: --simulong=4 => $mysync->{simulong} => 4' ) ; + is( undef, $mysync->{ folder }, 'get_options cgi context: --simulong=4 => $mysync->{ folder } => undef' ) ; + #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; - $mysync ={} ; - $mysync->{cgi} = CGI->new( 'testslive=on' ) ; - get_options( $mysync ) ; - is( 'on', $mysync->{ testslive }, 'get_options cgi context: --testslive=on => testslive => on' ) ; - #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + $mysync ={} ; + $mysync->{cgi} = CGI->new( 'testslive=on' ) ; + get_options( $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 ; } -sub get_options_cgi +sub get_options_cgi { # In CGI context arguments are not in @ARGV but in QUERY_STRING variable (with GET). my $mysync = shift @ARG ; @@ -19736,7 +23012,9 @@ sub get_options_cgi 'f1f2=s@' => \$mysync->{ f1f2 }, 'f1f2h=s%' => \$mysync->{ f1f2h }, 'folder=s@' => \$mysync->{ folder }, + 'folderrec=s@' => \$mysync->{ folderrec }, 'testslive!' => \$mysync->{ testslive }, + 'testslive2!' => \$mysync->{ testslive2 }, 'testslive6!' => \$mysync->{ testslive6 }, 'releasecheck!' => \$mysync->{ releasecheck }, 'simulong=f' => \$mysync->{ simulong }, @@ -19745,15 +23023,38 @@ sub get_options_cgi 'subfolder2=s' => \$mysync->{ subfolder2 }, 'justfolders!' => \$mysync->{ justfolders }, 'justfoldersizes!' => \$mysync->{ justfoldersizes }, - 'delete1!' => \$mysync->{ delete1 }, - 'delete2!' => \$mysync->{ delete2 }, + + 'delete1!' => \$mysync->{ delete1 }, + 'expunge1!' => \$mysync->{ expunge1 }, + 'delete2!' => \$mysync->{ delete2 }, + 'expunge2!' => \$mysync->{ expunge2 }, + 'uidexpunge2!' => \$mysync->{ uidexpunge2 }, 'delete2duplicates!' => \$mysync->{ delete2duplicates }, - 'tail!' => \$mysync->{ tail }, - 'tmphash=s' => \$mysync->{ tmphash }, - 'exitwhenover=i' => \$mysync->{ exitwhenover }, - 'syncduplicates!' => \$mysync->{ syncduplicates }, - 'log!' => \$mysync->{ log }, - 'loglogfile!' => \$mysync->{ loglogfile }, + 'delete1emptyfolders' => \$mysync->{ delete1emptyfolders }, + 'delete2folders!' => \$mysync->{ delete2folders }, + + 'tail!' => \$mysync->{ tail }, + 'exitwhenover=i' => \$mysync->{ exitwhenover }, + 'exitonload!' => \$mysync->{ exitonload }, + 'syncduplicates!' => \$mysync->{ syncduplicates }, + 'skipcrossduplicates!' => \$mysync->{ skipcrossduplicates }, + 'debugcrossduplicates!'=> \$mysync->{ debugcrossduplicates }, + 'log!' => \$mysync->{ log }, + 'loglogfile!' => \$mysync->{ loglogfile }, + 'emailreportfrom=s' => \$mysync->{ email_report_from }, + 'emailreport1!' => \$mysync->{ emailreport1 }, + 'emailreport2!' => \$mysync->{ emailreport2 }, + 'var=s@' => \$mysync->{ var }, + 'extra=s@' => \$mysync->{ extra }, + 'useheader=s@' => \$mysync->{ useheader }, + + 'minsize=i' => \$mysync->{ minsize }, + 'maxsize=i' => \$mysync->{ maxsize }, + 'maxage=f' => \$mysync->{ maxage }, + 'minage=f' => \$mysync->{ minage }, + 'search=s' => \$mysync->{ search }, + 'search1=s' => \$mysync->{ search1 }, + 'search2=s' => \$mysync->{ search2 }, # f1f2h=s% could be removed but @@ -19763,13 +23064,16 @@ sub get_options_cgi $mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ; - if ( ! $opt_ret ) { + if ( ! $opt_ret ) + { return ; } return $numopt ; -} +} -sub get_options_cmd + + +sub get_options_cmd { my $mysync = shift @ARG ; my @arguments = @ARG ; @@ -19787,25 +23091,23 @@ sub get_options_cmd $mysync, \@arguments, 'debug!' => \$mysync->{ debug }, - 'debuglist!' => \$debuglist, + 'debuglist!' => \$mysync->{ debuglist }, 'debugcontent!' => \$mysync->{ debugcontent }, 'debugsleep=f' => \$mysync->{ debugsleep }, - 'debugflags!' => \$debugflags, + 'debugflags!' => \$mysync->{ debugflags }, 'debugimap!' => \$mysync->{ debugimap }, 'debugimap1!' => \$mysync->{ acc1 }->{ debugimap }, 'debugimap2!' => \$mysync->{ acc2 }->{ debugimap }, - 'debugdev!' => \$debugdev, - 'debugmemory!' => \$mysync->{debugmemory}, - 'debugfolders!' => \$mysync->{debugfolders}, - 'debugssl=i' => \$mysync->{debugssl}, - 'debugcgi!' => \$debugcgi, - 'debugenv!' => \$mysync->{debugenv}, - 'debugsig!' => \$mysync->{debugsig}, - 'debuglabels!' => \$mysync->{debuglabels}, + 'debugmemory!' => \$mysync->{ debugmemory }, + 'debugfolders!' => \$mysync->{ debugfolders }, + 'debugssl=i' => \$mysync->{ debugssl }, + 'debugenv!' => \$mysync->{ debugenv }, + 'debugsig!' => \$mysync->{ debugsig }, + 'debuglabels!' => \$mysync->{ debuglabels }, - 'simulong=f' => \$mysync->{simulong}, - 'abort' => \$mysync->{abort}, - 'abortbyfile' => \$mysync->{abortbyfile}, + 'simulong=f' => \$mysync->{ simulong }, + 'abort' => \$mysync->{ abort }, + 'abortbyfile' => \$mysync->{ abortbyfile }, 'host1=s' => \$mysync->{ host1 }, 'host2=s' => \$mysync->{ host2 }, @@ -19815,119 +23117,118 @@ sub get_options_cmd 'inet6|ipv6' => \$mysync->{ inet6 }, 'user1=s' => \$mysync->{ user1 }, 'user2=s' => \$mysync->{ user2 }, - 'gmail1' => \$mysync->{gmail1}, - 'gmail2' => \$mysync->{gmail2}, - 'office1' => \$mysync->{office1}, - 'office2' => \$mysync->{office2}, - 'exchange1' => \$mysync->{exchange1}, - 'exchange2' => \$mysync->{exchange2}, - 'domino1' => \$mysync->{domino1}, - 'domino2' => \$mysync->{domino2}, + 'gmail1' => \$mysync->{ gmail1 }, + 'gmail2' => \$mysync->{ gmail2 }, + 'office1' => \$mysync->{ office1 }, + 'office2' => \$mysync->{ office2 }, + 'exchange1' => \$mysync->{ exchange1 }, + 'exchange2' => \$mysync->{ exchange2 }, + 'domino1' => \$mysync->{ domino1 }, + 'domino2' => \$mysync->{ domino2 }, 'domain1=s' => \$mysync->{ acc1 }->{ domain }, 'domain2=s' => \$mysync->{ acc2 }->{ domain }, - 'password1=s' => \$mysync->{password1}, - 'password2=s' => \$mysync->{password2}, + 'password1=s' => \$mysync->{ password1 }, + 'password2=s' => \$mysync->{ password2 }, 'passfile1=s' => \$mysync->{ passfile1 }, 'passfile2=s' => \$mysync->{ passfile2 }, '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 }, + 'oauthrefreshcmd1=s' => \$mysync->{ acc1 }->{ oauthrefreshcmd }, + 'oauthrefreshcmd2=s' => \$mysync->{ acc2 }->{ oauthrefreshcmd }, + 'sep1=s' => \$mysync->{ sep1 }, + 'sep2=s' => \$mysync->{ sep2 }, 'sanitize!' => \$mysync->{ sanitize }, 'folder=s@' => \$mysync->{ folder }, - 'folderrec=s' => \@folderrec, + 'folderrec=s@' => \$mysync->{ folderrec }, 'include=s' => \@include, 'exclude=s' => \@exclude, - 'noexclude' => \$mysync->{noexclude}, + 'noexclude' => \$mysync->{ noexclude }, 'folderfirst=s' => \@folderfirst, 'folderlast=s' => \@folderlast, - 'prefix1=s' => \$prefix1, - 'prefix2=s' => \$prefix2, + 'prefix1=s' => \$mysync->{ prefix1 }, + 'prefix2=s' => \$mysync->{ prefix2 }, 'subfolder1=s' => \$mysync->{ subfolder1 }, 'subfolder2=s' => \$mysync->{ subfolder2 }, 'fixslash2!' => \$mysync->{ fixslash2 }, - 'fixInboxINBOX!' => \$fixInboxINBOX, + 'fixInboxINBOX!' => \$mysync->{ fixInboxINBOX }, 'regextrans2=s@' => \$mysync->{ regextrans2 }, 'mixfolders!' => \$mixfolders, 'skipemptyfolders!' => \$mysync->{ skipemptyfolders }, 'regexmess=s' => \@regexmess, - 'noregexmess' => \$mysync->{noregexmess}, + 'noregexmess' => \$mysync->{ noregexmess }, 'skipmess=s' => \@skipmess, 'pipemess=s' => \@pipemess, - 'pipemesscheck!' => \$pipemesscheck, - 'disarmreadreceipts!' => \$disarmreadreceipts, + 'pipemesscheck!' => \$mysync->{ pipemesscheck }, + 'disarmreadreceipts!' => \$mysync->{ disarmreadreceipts }, 'regexflag=s@' => \$mysync->{ regexflag }, 'noregexflag' => \$mysync->{ noregexflag }, 'filterflags!' => \$mysync->{ filterflags }, 'filterbuggyflags!' => \$mysync->{ filterbuggyflags }, 'flagscase!' => \$mysync->{ flagscase }, - 'syncflagsaftercopy!' => \$syncflagsaftercopy, + 'syncflagsaftercopy!' => \$mysync->{ syncflagsaftercopy }, 'resyncflags!' => \$mysync->{ resyncflags }, 'synclabels!' => \$mysync->{ synclabels }, 'resynclabels!' => \$mysync->{ resynclabels }, - 'delete|delete1!' => \$mysync->{ delete1 }, + 'delete1!' => \$mysync->{ delete1 }, + 'expunge1|expunge!' => \$mysync->{ expunge1 }, 'delete2!' => \$mysync->{ delete2 }, + 'expunge2!' => \$mysync->{ expunge2 }, + 'uidexpunge2!' => \$mysync->{ uidexpunge2 }, 'delete2duplicates!' => \$mysync->{ delete2duplicates }, - 'delete2folders!' => \$delete2folders, - 'delete2foldersonly=s' => \$delete2foldersonly, - 'delete2foldersbutnot=s' => \$delete2foldersbutnot, - 'syncinternaldates!' => \$syncinternaldates, - 'idatefromheader!' => \$idatefromheader, + 'delete1emptyfolders' => \$mysync->{ delete1emptyfolders }, + 'delete2folders!' => \$mysync->{ delete2folders }, + 'delete2foldersonly=s' => \$mysync->{ delete2foldersonly }, + 'delete2foldersbutnot=s' => \$mysync->{ delete2foldersbutnot }, + 'syncinternaldates!' => \$mysync->{ syncinternaldates }, + 'idatefromheader!' => \$mysync->{ idatefromheader }, 'syncacls!' => \$mysync->{ syncacls }, - 'maxsize=i' => \$mysync->{ maxsize }, 'appendlimit=i' => \$mysync->{ appendlimit }, 'truncmess=i' => \$mysync->{ truncmess }, - 'minsize=i' => \$minsize, - 'maxage=f' => \$maxage, - 'minage=f' => \$minage, - 'search=s' => \$search, + 'minsize=i' => \$mysync->{ minsize }, + 'maxsize=i' => \$mysync->{ maxsize }, + 'maxage=f' => \$mysync->{ maxage }, + 'minage=f' => \$mysync->{ minage }, + 'search=s' => \$mysync->{ search }, 'search1=s' => \$mysync->{ search1 }, 'search2=s' => \$mysync->{ search2 }, 'foldersizes!' => \$mysync->{ foldersizes }, 'foldersizesatend!' => \$mysync->{ foldersizesatend }, - 'dry!' => \$mysync->{dry}, - 'dry1!' => \$mysync->{dry1}, - 'expunge1|expunge!' => \$mysync->{ expunge1 }, - 'expunge2!' => \$mysync->{ expunge2 }, - 'uidexpunge2!' => \$mysync->{ uidexpunge2 }, + 'dry!' => \$mysync->{ dry }, + 'dry1!' => \$mysync->{ dry1 }, 'subscribed' => \$subscribed, 'subscribe!' => \$subscribe, 'subscribeall|subscribe_all!' => \$subscribeall, 'justbanner!' => \$mysync->{ justbanner }, 'justfolders!'=> \$mysync->{ justfolders }, 'justfoldersizes!' => \$mysync->{ justfoldersizes }, - 'version' => \$mysync->{version}, - 'help' => \$help, - 'timeout=f' => \$mysync->{timeout}, + 'version' => \$mysync->{ version }, + 'help' => \$mysync->{ help }, + 'timeout=f' => \$mysync->{ timeout }, 'timeout1=f' => \$mysync->{ acc1 }->{timeout}, 'timeout2=f' => \$mysync->{ acc2 }->{timeout}, 'skipheader=s' => \$mysync->{ skipheader }, - 'useheader=s' => \@useheader, + 'useheader=s@' => \$mysync->{ useheader }, 'wholeheaderifneeded!' => \$wholeheaderifneeded, 'messageidnodomain!' => \$messageidnodomain, 'skipsize!' => \$skipsize, 'allowsizemismatch!' => \$allowsizemismatch, 'fastio1!' => \$mysync->{ acc1 }->{ fastio }, 'fastio2!' => \$mysync->{ acc2 }->{ fastio }, - 'sslcheck!' => \$mysync->{sslcheck}, - 'ssl1!' => \$mysync->{ssl1}, - 'ssl2!' => \$mysync->{ssl2}, - '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}, + 'sslcheck!' => \$mysync->{ sslcheck }, + 'ssl1!' => \$mysync->{ ssl1 }, + 'ssl2!' => \$mysync->{ ssl2 }, + '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' => \$mysync->{ acc1 }->{ authmech }, @@ -19946,96 +23247,100 @@ sub get_options_cmd 'reconnectretry1=i' => \$mysync->{ acc1 }->{ reconnectretry }, 'reconnectretry2=i' => \$mysync->{ acc2 }->{ reconnectretry }, 'tests!' => \$mysync->{ tests }, - 'testsdebug|tests_debug!' => \$mysync->{ testsdebug }, - 'testsunit=s@' => \$mysync->{testsunit}, - 'testslive!' => \$mysync->{testslive}, - 'testslive6!' => \$mysync->{testslive6}, - 'justlogin!' => \$mysync->{justlogin}, - 'justconnect!' => \$mysync->{justconnect}, + 'testsdebug!' => \$mysync->{ testsdebug }, + 'testsunit=s@' => \$mysync->{ testsunit }, + 'testslive!' => \$mysync->{ testslive }, + 'testslive2!' => \$mysync->{ testslive2 }, + 'testslive6!' => \$mysync->{ testslive6 }, + 'justlogin!' => \$mysync->{ justlogin }, + 'justconnect!' => \$mysync->{ justconnect }, 'tmpdir=s' => \$mysync->{ tmpdir }, - 'pidfile=s' => \$mysync->{pidfile}, - 'pidfilelocking!' => \$mysync->{pidfilelocking}, + 'pidfile=s' => \$mysync->{ pidfile }, + 'pidfilelocking!' => \$mysync->{ pidfilelocking }, 'sigexit=s@' => \$mysync->{ sigexit }, 'sigreconnect=s@' => \$mysync->{ sigreconnect }, 'sigignore=s@' => \$mysync->{ sigignore }, 'releasecheck!' => \$mysync->{releasecheck}, - 'modulesversion|modules_version!' => \$modulesversion, - 'usecache!' => \$usecache, - 'cacheaftercopy!' => \$cacheaftercopy, - 'debugcache!' => \$debugcache, - 'useuid!' => \$useuid, - 'addheader!' => \$mysync->{addheader}, - 'exitwhenover=i' => \$mysync->{ exitwhenover }, + 'modulesversion!' => \$mysync->{ modulesversion }, + 'usecache!' => \$mysync->{ usecache }, + 'cacheaftercopy!' => \$mysync->{ cacheaftercopy }, + 'debugcache!' => \$mysync->{ debugcache }, + 'useuid!' => \$mysync->{ useuid }, + 'addheader!' => \$mysync->{ addheader }, + 'exitwhenover=i' => \$mysync->{ exitwhenover }, + 'exitonload!' => \$mysync->{ exitonload }, 'checkselectable!' => \$mysync->{ checkselectable }, 'checkfoldersexist!' => \$mysync->{ checkfoldersexist }, - 'checkmessageexists!' => \$checkmessageexists, + 'checkmessageexists!' => \$mysync->{ checkmessageexists }, 'expungeaftereach!' => \$mysync->{ expungeaftereach }, - 'abletosearch!' => \$mysync->{abletosearch}, - 'abletosearch1!' => \$mysync->{abletosearch1}, - 'abletosearch2!' => \$mysync->{abletosearch2}, - 'showpasswords!' => \$mysync->{showpasswords}, + 'abletosearch!' => \$mysync->{ abletosearch }, + 'abletosearch1!' => \$mysync->{ abletosearch1 }, + 'abletosearch2!' => \$mysync->{ abletosearch2 }, + 'showpasswords!' => \$mysync->{ showpasswords }, 'maxlinelength=i' => \$maxlinelength, - 'maxlinelengthcmd=s' => \$maxlinelengthcmd, - 'minmaxlinelength=i' => \$minmaxlinelength, - 'debugmaxlinelength!' => \$debugmaxlinelength, - 'fixcolonbug!' => \$fixcolonbug, - 'create_folder_old!' => \$create_folder_old, - 'maxmessagespersecond=f' => \$mysync->{maxmessagespersecond}, - 'maxbytespersecond=i' => \$mysync->{maxbytespersecond}, - 'maxbytesafter=i' => \$mysync->{maxbytesafter}, - 'maxsleep=f' => \$mysync->{maxsleep}, - 'skipcrossduplicates!' => \$skipcrossduplicates, - 'debugcrossduplicates!' => \$debugcrossduplicates, - 'log!' => \$mysync->{log}, - 'tail!' => \$mysync->{tail}, - 'logfile=s' => \$mysync->{logfile}, - 'logdir=s' => \$mysync->{logdir}, - 'errorsmax=i' => \$mysync->{errorsmax}, + 'fixcolonbug!' => \$mysync->{ fixcolonbug }, + 'create_folder_old!' => \$mysync->{ create_folder_old }, + 'maxmessagespersecond=f' => \$mysync->{ maxmessagespersecond }, + 'maxbytespersecond=i' => \$mysync->{ maxbytespersecond }, + 'maxbytesafter=i' => \$mysync->{ maxbytesafter }, + 'maxsleep=f' => \$mysync->{ maxsleep }, + 'syncduplicates!' => \$mysync->{ syncduplicates }, + 'skipcrossduplicates!' => \$mysync->{ skipcrossduplicates }, + 'debugcrossduplicates!' => \$mysync->{ debugcrossduplicates }, + 'log!' => \$mysync->{ log }, + 'tail!' => \$mysync->{ tail }, + 'logfile=s' => \$mysync->{ logfile }, + 'logdir=s' => \$mysync->{ logdir }, + 'errorsmax=i' => \$mysync->{ errorsmax }, 'errorsdump!' => \$mysync->{ errorsdump }, - 'fetch_hash_set=s' => \$fetch_hash_set, - 'automap!' => \$mysync->{automap}, - 'justautomap!' => \$mysync->{justautomap}, - 'id!' => \$mysync->{id}, - 'f1f2=s@' => \$mysync->{f1f2}, - 'nof1f2' => \$mysync->{nof1f2}, - 'f1f2h=s%' => \$mysync->{f1f2h}, - 'justfolderlists!' => \$mysync->{justfolderlists}, - 'delete1emptyfolders' => \$mysync->{delete1emptyfolders}, - 'checknoabletosearch!' => \$mysync->{checknoabletosearch}, - 'syncduplicates!' => \$mysync->{ syncduplicates }, + 'fetch_hash_set=s' => \$mysync->{ fetch_hash_set }, + 'automap!' => \$mysync->{ automap }, + 'justautomap!' => \$mysync->{ justautomap }, + 'id!' => \$mysync->{ id }, + 'f1f2=s@' => \$mysync->{ f1f2 }, + 'nof1f2' => \$mysync->{ nof1f2 }, + 'f1f2h=s%' => \$mysync->{ f1f2h }, + 'justfolderlists!' => \$mysync->{ justfolderlists }, + 'checknoabletosearch!' => \$mysync->{ checknoabletosearch }, 'dockercontext!' => \$mysync->{ dockercontext }, - - + 'emailreportfrom=s' => \$mysync->{ email_report_from }, + 'emailreport1!' => \$mysync->{ emailreport1 }, + 'emailreport2!' => \$mysync->{ emailreport2 }, + 'var=s@' => \$mysync->{ var }, + 'memorystress!' => \$mysync->{ memorystress }, + 'extra=s@' => \$mysync->{ extra }, ) ; - #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" ) ; + $mysync->{ debug } and output( $mysync, "get options: opt_ret[$opt_ret] numopt[$numopt] numopt_after[$numopt_after]\n" ) ; # 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] ) { + if ( $numopt_after and $arguments[0] ) + { myprint( - "Found ", scalar( @arguments ), " extra arguments : [@arguments]\n", + "Found $numopt_after supplementary arguments: [@arguments]\n", "It usually means a quoting issue in the command line ", - "or some misspelling options.\n", + "or some misspelled or unknown options.\n", ) ; return ; } + if ( ! $opt_ret ) { return ; } return $numopt ; -} +} -sub tests_get_options + +sub tests_get_options { note( 'Entering tests_get_options()' ) ; # CAVEAT: still setting global variables, be careful - # with tests, the context increases! $debug stays on for example. + # with tests, the context increases! $debug used to stay on for example. # API: # * input arguments: two ways, command line or CGI # * the program arguments @@ -20066,27 +23371,28 @@ sub tests_get_options is( undef, get_options( $mysync, qw( --noexist --version ) ), 'get_options: --debug --noexist --version => undef' ) ; is( 1, get_options( $mysync, qw( --version ) ), 'get_options: --version => 1' ) ; - is( undef, get_options( $mysync, qw( extra ) ), 'get_options: extra => undef' ) ; - is( undef, get_options( $mysync, qw( extra1 --version extra2 ) ), 'get_options: extra1 --version extra2 => undef' ) ; + is( undef, get_options( $mysync, qw( kaka ) ), 'get_options: kaka => undef' ) ; + is( undef, get_options( $mysync, qw( kaka1 --version kaka2 ) ), 'get_options: extra1 --version extra2 => undef' ) ; $mysync = { } ; - is( 2, get_options( $mysync, qw( --host1 HOST_01) ), 'get_options: --host1 HOST_01 => 1' ) ; - is( 'HOST_01', $mysync->{ host1 }, 'get_options: --host1 HOST_01 => HOST_01' ) ; + is( 2, get_options( $mysync, qw( --host1 HOST_01) ), 'get_options: --host1 HOST_01 => 2' ) ; + is( 'HOST_01', $mysync->{ host1 }, 'get_options: --host1 HOST_01 => host1 = HOST_01' ) ; #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; note( 'Leaving tests_get_options()' ) ; return ; -} +} -sub get_options +sub get_options { my $mysync = shift @ARG ; my @arguments = @ARG ; #myprint( "1 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ; my $ret ; - if ( under_cgi_context( ) ) { + if ( under_cgi_context( ) ) + { # CGI context $ret = get_options_cgi( $mysync, @arguments ) ; }else{ @@ -20094,7 +23400,7 @@ sub get_options $ret = get_options_cmd( $mysync, @arguments ) ; } ; #myprint( "2 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ; - + foreach my $key ( sort keys %{ $mysync } ) { if ( ! defined $mysync->{$key} ) { delete $mysync->{$key} ; @@ -20109,42 +23415,40 @@ sub get_options } -sub tests_infos +sub tests_infos { note( 'Entering tests_infos()' ) ; note( "OSNAME=$OSNAME" ) ; - note( "hostname=". hostname() ) ; + note( "hostname=". hostname( ) ) ; note( "cwd=" . getcwd( ) ) ; note( "PROGRAM_NAME=$PROGRAM_NAME" ) ; - my $stat = stat("$PROGRAM_NAME") ; - my $perms = sprintf( "%04o\n", $stat->mode & oct($PERMISSION_FILTER) ) ; + my $stat = stat( "$PROGRAM_NAME" ) ; + my $perms = sprintf( "%04o\n", $stat->mode & oct( $PERMISSION_FILTER ) ) ; note( "permissions=$perms" ) ; note( "PROCESS_ID=$PROCESS_ID" ) ; note( "REAL_USER_ID=$REAL_USER_ID" ) ; note( "EFFECTIVE_USER_ID=$EFFECTIVE_USER_ID" ) ; note( "context: " . imapsync_context( $sync ) ) ; - note( "memory_consumption: " . memory_consumption() . " bytes aka " . bytes_display_string_dec( memory_consumption() ) ) ; - cpu_number - note( "cpu_number: " . cpu_number() ) ; - note( $sync->{rcs} ) ; - + note( "memory_consumption_of_myself: " . memory_consumption_of_myself( ) . " bytes aka " . bytes_display_string_dec( memory_consumption_of_myself( ) ) ) ; + note( "cpu_number: " . cpu_number( ) ) ; + note( $sync->{ rcs } ) ; note( 'Leaving tests_infos()' ) ; return ; -} +} sub condition_to_leave_after_tests { - my $mysync = shift ; - if ( $mysync->{ testslive } or $mysync->{ testslive6 } ) + my $mysync = shift @ARG ; + if ( $mysync->{ testslive } or $mysync->{ testslive6 } or $mysync->{ testslive2 } ) { return 0 ; } - if ( $mysync->{ tests } - or $mysync->{ testsdebug } - or $mysync->{ testsunit } + if ( $mysync->{ tests } + or $mysync->{ testsdebug } + or $mysync->{ testsunit } ) { return 1 ; @@ -20154,7 +23458,7 @@ sub condition_to_leave_after_tests sub testunitsession { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! $mysync ) { return ; } if ( ! $mysync->{ testsunit } ) { return ; } @@ -20214,7 +23518,8 @@ sub report_failures my $counter = 1 ; my $report = q{} ; foreach my $details ( @details ) { - if ( ! $details->{ 'ok' } ) { + if ( ! $details->{ 'ok' } ) + { my $name = $details->{ 'name' } || 'NONAME' ; $report .= "nb $counter - $name\n" ; } @@ -20228,11 +23533,25 @@ sub tests_true { note( 'Entering tests_true()' ) ; - is( 1, 1, 'true: 1 is 1' ) ; + is( 1, 1, 'true: 1 is 1' ) ; + is( 'A', 'A', 'true: A is A' ) ; note( 'Leaving tests_true()' ) ; return ; } + +sub tests_always_fail +{ + note( 'Entering tests_always_fail()' ) ; + + is( 0, 1, 'always_fail: 0 is 1' ) ; + isnt( 'A', 'A', 'always_fail: A is A' ) ; + + note( 'Leaving tests_always_fail()' ) ; + return ; +} + + sub tests_testsunit { note( 'Entering tests_testunit()' ) ; @@ -20250,21 +23569,25 @@ sub testsunit { my @functions = @ARG ; - if ( ! @functions ) { # + if ( ! @functions ) + { # myprint( "testsunit warning: no argument given\n" ) ; return ; } foreach my $function ( @functions ) { - if ( ! $function ) { + if ( ! $function ) + { myprint( "testsunit warning: argument is empty\n" ) ; next ; } - if ( ! exists &$function ) { + if ( ! exists &$function ) + { myprint( "testsunit warning: function $function does not exist\n" ) ; next ; } - if ( ! defined &$function ) { + if ( ! defined &$function ) + { myprint( "testsunit warning: function $function is not defined\n" ) ; next ; } @@ -20278,9 +23601,10 @@ sub testsdebug { # Now a little obsolete since there is # imapsync ... --testsunit "anyfunction" - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! $mysync->{ testsdebug } ) { return ; } - SKIP: { + SKIP: + { if ( ! $mysync->{ testsdebug } ) { skip 'No test in normal run' ; } @@ -20293,11 +23617,35 @@ sub testsdebug #tests_kill_zero( ) ; #tests_connect_socket( ) ; #tests_probe_imapssl( ) ; - #tests_cpu_number( ) ; #tests_mailimapclient_connect( ) ; - tests_loadavg( ) ; #tests_always_fail( ) ; - + #tests_localtimez( ) ; + #tests_year_month_day_hour_min_sec_ms( ) ; + #tests_date_rfc822( ) ; + #tests_email_report_message_id( ) ; + #tests_all_pids( ) ; + #tests_memory_consumption_of_myself( ) ; + #tests_ram_memory_info( ) ; + #tests_memory_consumption_of_all_pids( ) ; + #tests_memory_consumption_all_pids_percent( ) ; + + #tests_memory_stress( ) ; + + #tests_memory_consumption_of_pids_win32( ) ; + + #tests_load_and_delay( ) ; + #tests_cpu_number( ) ; + #tests_loadavg( ) ; + #tests_load_per_cpu( ) ; + #tests_all_pids( ) ; + #tests_remove_qq( ) ; + #tests_remove_not_num( ) ; + + #tests_compress_starttls( ) ; + #tests_diskspace_available( ) ; + tests_tmpdir( ) ; + tests_infos( ) ; + note( 'Leaving testsdebug()' ) ; done_testing( ) ; } @@ -20305,14 +23653,15 @@ sub testsdebug } -sub tests +sub tests { - my $mysync = shift ; + my $mysync = shift @ARG ; if ( ! $mysync->{ tests } ) { return ; } SKIP: { skip 'No test in normal run' if ( ! $mysync->{ tests } ) ; note( 'Entering tests()' ) ; + printenv( $mysync ) ; tests_folder_routines( ) ; tests_compare_lists( ) ; tests_regexmess( ) ; @@ -20327,7 +23676,7 @@ sub tests tests_good_date( ) ; tests_max( ) ; tests_remove_not_num(); - tests_memory_consumption( ) ; + tests_memory_consumption_of_myself( ) ; tests_is_a_release_number(); tests_imapsync_basename(); tests_list_keys_in_2_not_in_1(); @@ -20375,7 +23724,7 @@ sub tests tests_quota_extract_storage_limit_in_bytes( ) ; tests_quota_extract_storage_current_in_bytes( ) ; tests_guess_special( ) ; - tests_do_valid_directory( ) ; + tests_make_valid_directory( ) ; tests_delete1emptyfolders( ) ; tests_message_for_host2( ) ; tests_length_ref( ) ; @@ -20388,7 +23737,6 @@ sub tests tests_match( ) ; tests_get_options( ) ; tests_get_options_cgi_context( ) ; - tests_rand32( ) ; tests_hashsynclocal( ) ; tests_hashsync( ) ; tests_output( ) ; @@ -20468,7 +23816,6 @@ sub tests tests_eta( ) ; tests_timesince( ) ; tests_timenext( ) ; - tests_foldersize( ) ; tests_imapsync_context( ) ; tests_abort( ) ; tests_probe_imapssl( ) ; @@ -20484,7 +23831,9 @@ sub tests tests_total_bytes_max_reached( ) ; tests_header_construct( ) ; tests_remove_doublequotes_if_any( ) ; - tests_login_imap( ) ; + tests_login_imap_ssl_993( ) ; + tests_login_imap_starttls( ) ; + tests_login_imap_notls_nossl( ) ; tests_login_imap_oauth( ) ; tests_skipmess_neg( ) ; tests_localtimez( ) ; @@ -20498,9 +23847,52 @@ sub tests tests_comment_of_error_type( ) ; tests_debugcontent( ) ; tests_compress_ssl( ) ; + tests_compress_starttls( ) ; tests_compress( ) ; - tests_get_options_extra( ) ; + tests_get_options_extra_from_file( ) ; tests_get_options_from_string( ) ; + tests_email_report_message_id( ) ; + tests_year_month_day_hour_min_sec_ms( ) ; + tests_fractional_of_floor( ) ; + tests_date_rfc822( ) ; + tests_email_report_from( ) ; + tests_email_report_to( ) ; + tests_email_report_body_base( ) ; + tests_email_report( ) ; + tests_setlogdir( ) ; + tests_logfilesuffix( ) ; + tests_cgienvcontext( ) ; + tests_usecache_and_skipcrossduplicates( ) ; + tests_loglogfile( ) ; + tests_heavy_load_reached( ) ; + tests_heavy_load_percent_threshold( ) ; + tests_pctmem_available( ) ; + tests_filterbuggyflags( ) ; + tests_heavy_load_reached_by_memory( ) ; + tests_heavy_load_reached_by_cpu( ) ; + tests_load_per_cpu( ) ; + tests_memory_consumption_surface( ) ; + tests_add( ) ; + tests_all_pids( ) ; + tests_memory_consumption_of_all_pids( ) ; + tests_remove_qq( ) ; + tests_memory_consumption_all_pids_percent( ) ; + tests_ram_memory_info( ) ; + tests_firstline_or_string( ) ; + tests_oauth2_bearer_string( ) ; + tests_diskspace_available( ) ; + tests_generate_a_random_string( ) ; + tests_filter_forbidden_characters_cgi_context( ) ; + tests_trigger_justconnect1( ) ; + tests_trigger_justconnect2( ) ; + tests_tmpdir( ) ; + tests_cgidir( ) ; + tests_separate_host_port_folder( ) ; + tests_host1_port1_folderrec_from_host1( ) ; + tests_get_options_extra_from_param( ) ; + tests_setlog( ) ; + tests_delete_folders_in_2_not_in_1( ) ; + tests_subfolder2_with_delete2folders( ) ; tests_infos( ) ; #tests_resolv( ) ; @@ -20511,21 +23903,23 @@ sub tests #tests_kill_zero( ) ; #tests_always_fail( ) ; - done_testing( 1860 ) ; + + done_testing( 2189 ) ; note( 'Leaving tests()' ) ; } return ; } + sub tests_template { note( 'Entering tests_template()' ) ; - is( undef, template( ), 'template: no args => undef' ) ; + is( undef, template( ), 'tests_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' ) ; + is( undef, template( $mysync ), 'tests_template: { } => undef' ) ; + is_deeply( {}, {}, 'tests_template: a hash is a hash' ) ; + is_deeply( [], [], 'tests_template: an array is an array' ) ; note( 'Leaving tests_template()' ) ; return ; @@ -20534,6 +23928,7 @@ sub tests_template sub template { my $mysync = shift @ARG ; - + return ; } + diff --git a/data/Dockerfiles/dovecot/imapsync_runner.py b/data/Dockerfiles/dovecot/imapsync_runner.py index b74e1d845..09fa1eda6 100755 --- a/data/Dockerfiles/dovecot/imapsync_runner.py +++ b/data/Dockerfiles/dovecot/imapsync_runner.py @@ -16,29 +16,41 @@ run_dir = '/tmp' # Max size of imapsync output stored in returned_text (the tail holds the summary) max_output = 16 * 1024 * 1024 lock_file = run_dir + '/imapsync_busy.lock' +# An OAuth run needs a token valid this long at start (half the lifetime for short-lived tokens) +token_min_valid = 900 +# Refreshed tokens are written to the token files of running jobs this often, imapsync re-reads them on reconnect +token_sync_interval = 60 # Next due job: higher prio first, never-run jobs first, then oldest run next_sql = """SELECT i.id, i.user1, i.user2, i.password1, i.exclude, i.delete2duplicates, i.maxage, i.subfolder2, i.delete1, i.delete2, i.automap, i.skipcrossduplicates, i.maxbytespersecond, i.custom_params, i.subscribeall, i.timeout1, i.timeout2, i.dry, i.source_id, - s.host1, s.port1, s.enc1, s.auth_type, s.oauth_flow, s.oauth_access_token, s.oauth_token_expires + s.host1, s.port1, s.enc1, s.auth_type, s.oauth_flow FROM imapsync i JOIN imapsync_source s ON i.source_id = s.id WHERE i.active = 1 AND s.active = 1 AND i.is_running = 0 AND (UNIX_TIMESTAMP(NOW()) - UNIX_TIMESTAMP(i.last_run) > i.mins_interval * 60 OR i.last_run IS NULL) + {skip} ORDER BY i.prio DESC, i.last_run IS NOT NULL, i.last_run ASC, i.id ASC LIMIT 1""" # Atomic claim, a job is only started when this flips is_running 0 -> 1 claim_sql = """UPDATE imapsync SET is_running = 1, success = NULL, exit_status = NULL WHERE id = %s AND is_running = 0 AND active = 1""" -# Token of authorization_code sources: source + local mailbox (user2) + remote user (user1) -token_sql = """SELECT access_token, token_expires FROM imapsync_source_oauth_token +# Access token: client_credentials share the source token, authorization_code use the token of +# source + local mailbox (user2) + remote user (user1). issued/error describe the last refresh. +source_token_sql = """SELECT oauth_access_token AS access_token, oauth_token_expires AS token_expires, + UNIX_TIMESTAMP(oauth_last_refresh_attempt) AS issued, oauth_last_refresh_error AS error + FROM imapsync_source WHERE id = %s""" +user_token_sql = """SELECT access_token, token_expires, UNIX_TIMESTAMP(oauth_last_refresh_attempt) AS issued, + last_refresh_error AS error FROM imapsync_source_oauth_token WHERE source_id = %s AND owner = %s AND username = %s""" conn = None # Popen => job of running workers running = {} +# Jobs released without a run (token not ready), skipped for the rest of this runner round +deferred = set() stopping = False def num(value): @@ -88,6 +100,41 @@ def finish_job(job_id, text, success, exit_status): except MySQLdb.Error: query("UPDATE imapsync SET success = 0, last_run = NOW(), is_running = 0 WHERE id = %s", (job_id,)) +# Release a job without a run; last_run stays, so the next runner round retries it +def defer_job(job_id, text, exit_status): + query("UPDATE imapsync SET returned_text = %s, success = 0, exit_status = %s, is_running = 0 WHERE id = %s", + (text, exit_status, job_id)) + deferred.add(job_id) + +def oauth_token(j): + if j['oauth_flow'] == 'authorization_code': + return query(user_token_sql, (j['source_id'], j['user2'], j['user1'])).fetchone() or {} + return query(source_token_sql, (j['source_id'],)).fetchone() or {} + +# Valid for token_min_valid, or half the lifetime of a short-lived token (known when its last refresh succeeded) +def token_ready(row): + token, expires, issued = row.get('access_token'), row.get('token_expires'), row.get('issued') + if not token or expires is None: + return False + need = token_min_valid + if issued and not row.get('error') and expires > int(issued): + need = min(need, (expires - int(issued)) // 2) + return expires - time.time() >= need + +# Write a refreshed token over the token file of a running job (atomic, same path) +def sync_token_file(oauth): + token = oauth_token(oauth['job']).get('access_token') + if not token or token == oauth['token']: + return + fd, tmp = tempfile.mkstemp(prefix='imapsync.', dir=run_dir) + try: + with os.fdopen(fd, 'w', encoding='utf-8') as f: + f.write(token + '\n') + os.replace(tmp, oauth['file']) + oauth['token'] = token + except OSError: + unlink([tmp]) + # Max concurrent imapsync processes and global per-process bandwidth cap in bytes/s (0 = off), # re-read before every claim round so changes apply to long runs def read_settings(): @@ -104,18 +151,15 @@ def prepare_job(j, global_bw, files): return path auth_type = j['auth_type'] or 'PLAIN' + oauth = None if auth_type == 'XOAUTH2': - # authorization_code: token of this local mailbox + remote user, client_credentials: shared source token - token, expires = j['oauth_access_token'], j['oauth_token_expires'] - if j['oauth_flow'] == 'authorization_code': - row = query(token_sql, (j['source_id'], j['user2'], j['user1'])).fetchone() or {} - token, expires = row.get('access_token'), row.get('token_expires') - # Skip sync if the cached token is missing or about to expire (<2 min) - if not token or expires is None or expires - time.time() < 120: - finish_job(j['id'], "OAuth access token for the configured source is missing or expires too soon; refresh cron will retry.", - 0, 'OAUTH_TOKEN_NOT_READY') + row = oauth_token(j) + if not token_ready(row): + defer_job(j['id'], "OAuth access token for the configured source is missing or expires too soon; refresh cron will retry.", + 'OAUTH_TOKEN_NOT_READY') return None - auth_args = ['--authmech1', 'XOAUTH2', '--oauthaccesstoken1', tmpfile(token + '\n')] + oauth = {'job': j, 'token': row['access_token'], 'file': tmpfile(row['access_token'] + '\n')} + auth_args = ['--authmech1', 'XOAUTH2', '--oauthaccesstoken1', oauth['file']] else: auth_args = ['--passfile1', tmpfile(j['password1'] + '\n')] # imapsync auto-picks PLAIN, only pass --authmech1 for LOGIN/CRAM-MD5 @@ -140,7 +184,8 @@ def prepare_job(j, global_bw, files): if global_bw > 0 and (eff_bw <= 0 or eff_bw > global_bw): eff_bw = global_bw - cmd = ['/usr/local/bin/imapsync', '--tmpdir', '/tmp', '--nofoldersizes', '--addheader'] + # --nolog: the output is stored in returned_text, imapsync's own log dir would be the (read-only) cwd + cmd = ['/usr/local/bin/imapsync', '--tmpdir', '/tmp', '--nolog', '--nofoldersizes', '--addheader'] if num(j['timeout1']) > 0: cmd += ['--timeout1', str(j['timeout1'])] if num(j['timeout2']) > 0: @@ -154,7 +199,7 @@ def prepare_job(j, global_bw, files): if eff_bw > 0: cmd += ['--maxbytespersecond', str(eff_bw)] for col, opt in (('delete2duplicates', '--delete2duplicates'), ('subscribeall', '--subscribeall'), - ('delete1', '--delete'), ('delete2', '--delete2'), ('automap', '--automap'), + ('delete1', '--delete1'), ('delete2', '--delete2'), ('automap', '--automap'), ('skipcrossduplicates', '--skipcrossduplicates')): if j[col] == 1: cmd.append(opt) @@ -167,7 +212,7 @@ def prepare_job(j, global_bw, files): cmd.append('--dry') cmd += ['--no-modulesversion', '--noreleasecheck'] + custom_params - return {'id': j['id'], 'files': files, 'outfile': tmpfile(''), 'cmd': cmd} + return {'id': j['id'], 'files': files, 'outfile': tmpfile(''), 'cmd': cmd, 'oauth': oauth} # Worker: imapsync with output to a file, no inherited fds (DB socket, lock) def start_job(job): @@ -225,6 +270,7 @@ with open('/etc/sogo/sieve.creds') as f: # Worker pool: keep up to max_parallel workers busy, claim the next due job whenever a slot is free # (after every worker exit and at least every 10 seconds while workers run) +last_token_sync = time.monotonic() try: while True: for proc, job in list(running.items()): @@ -232,14 +278,25 @@ try: del running[proc] reap_job(job) + if time.monotonic() - last_token_sync >= token_sync_interval: + last_token_sync = time.monotonic() + for job in running.values(): + if job['oauth']: + try: + sync_token_file(job['oauth']) + except MySQLdb.Error as e: + print('imapsync job %d: %s' % (job['id'], e), file=sys.stderr) + max_parallel, global_bw = read_settings() - attempts = 0 - while not stopping and len(running) < max_parallel and attempts < 100: - attempts += 1 - j = query(next_sql).fetchone() + # Deferred and finished jobs drop out of next_sql, only failed claims are capped + failed_claims = 0 + while not stopping and len(running) < max_parallel and failed_claims < 100: + skip = ('AND i.id NOT IN (%s)' % ', '.join(['%s'] * len(deferred))) if deferred else '' + j = query(next_sql.format(skip=skip), tuple(deferred) or None).fetchone() if not j: break if query(claim_sql, (j['id'],)).rowcount != 1: + failed_claims += 1 continue files = [] diff --git a/data/web/inc/lib/mailcow/Imapsync/Controller/ImapsyncApiController.php b/data/web/inc/lib/mailcow/Imapsync/Controller/ImapsyncApiController.php index 721e0e0b3..0a68ed73e 100644 --- a/data/web/inc/lib/mailcow/Imapsync/Controller/ImapsyncApiController.php +++ b/data/web/inc/lib/mailcow/Imapsync/Controller/ImapsyncApiController.php @@ -7,6 +7,7 @@ namespace Mailcow\Imapsync\Controller; use Mailcow\Core\AccessDenied; use Mailcow\Core\ApiResponse; use Mailcow\Core\UserError; +use Mailcow\Imapsync\Model\Source; use Mailcow\Imapsync\Service\JobService; use Mailcow\Imapsync\Service\SourceService; use PDOException; @@ -37,8 +38,11 @@ class ImapsyncApiController /** POST add/syncjob_source */ public function addSource(array $attr): bool { - return $this->handle('add', 'source', $attr, - fn(array $log): bool => $this->response->success(['imapsync_source_added', $this->sources->create($attr)->name], $log)); + return $this->handle('add', 'source', $attr, function (array $log) use ($attr): bool { + $source = $this->sources->create($attr); + $this->tokenFailure($source, $log); + return $this->response->success(['imapsync_source_added', $source->name], $log); + }); } /** POST edit/syncjob: one message per id; `id` in $attr wins over $items (array_merge like before) */ @@ -70,8 +74,11 @@ class ImapsyncApiController $data = array_merge(['id' => $items], $attr); return $this->handle('edit', 'source', $data, function (array $log) use ($data): bool { $this->sources->requireEditor(); - return $this->batch(array_filter((array)($data['id'] ?? []), 'is_numeric'), $log, - fn(int $id): array => ['imapsync_source_modified', $this->sources->update($id, $data)->name]); + return $this->batch(array_filter((array)($data['id'] ?? []), 'is_numeric'), $log, function (int $id) use ($data, $log): array { + $source = $this->sources->update($id, $data); + $this->tokenFailure($source, $log); + return ['imapsync_source_modified', $source->name]; + }); }); } @@ -201,6 +208,14 @@ class ImapsyncApiController $this->response->flush(); } + /** The token fetched when saving a client_credentials source failed: the source is saved, report the error */ + private function tokenFailure(Source $source, array $log): void + { + if ($source->usesClientCredentials() && $source->active === 1 && $source->lastRefreshError !== null) { + $this->response->danger(['imapsync_source_token_refresh_failed', $source->name . ' (' . $source->lastRefreshError . ')'], $log); + } + } + /** * Runs one write call: $work gets the log entry and returns the result for process_*_return(). * A UserError becomes a danger message, a database error stops the call with one `mysql_error` message. diff --git a/data/web/inc/lib/mailcow/Imapsync/Model/Source.php b/data/web/inc/lib/mailcow/Imapsync/Model/Source.php index a76e73c5f..5ea55d054 100644 --- a/data/web/inc/lib/mailcow/Imapsync/Model/Source.php +++ b/data/web/inc/lib/mailcow/Imapsync/Model/Source.php @@ -37,7 +37,7 @@ class Source public ?string $clientId = null; public ?string $clientSecret = null; public ?string $oauthScope = null; - /** Extra token request parameters, JSON object text */ + /** Extra OAuth parameters (sign-in or token request, see OAuthService), JSON object text */ public ?string $extraParams = null; /** Shared token of a client_credentials source */ public ?string $accessToken = null; diff --git a/data/web/inc/lib/mailcow/Imapsync/Service/OAuthService.php b/data/web/inc/lib/mailcow/Imapsync/Service/OAuthService.php index aea2a2dbd..5f28fa277 100644 --- a/data/web/inc/lib/mailcow/Imapsync/Service/OAuthService.php +++ b/data/web/inc/lib/mailcow/Imapsync/Service/OAuthService.php @@ -22,10 +22,12 @@ use PDOException; */ class OAuthService { - /** Tokens expiring within this many seconds are refreshed */ - private const REFRESH_AHEAD = 300; + /** Tokens expiring within this many seconds are refreshed (the runner starts jobs with >= 15 min left) */ + private const REFRESH_AHEAD = 1200; /** A token whose last refresh failed is retried after this many seconds */ - private const RETRY_AFTER = 900; + private const RETRY_AFTER = 180; + /** Extra params that belong to the browser sign-in; all others go to the token request */ + private const AUTHORIZE_PARAMS = ['prompt', 'access_type', 'login_hint', 'domain_hint', 'hd']; /** Per-user tokens that no job uses are kept this long (time to save the job after signing in) */ private const UNUSED_TOKEN_GRACE = 86400; @@ -106,9 +108,11 @@ class OAuthService if (!$this->endpointAllowed($endpoint, $source->createdBy)) { return null; } - return $endpoint . (str_contains($endpoint, '?') ? '&' : '?') . http_build_query(['client_id' => $source->clientId, + // select_account: never sign in silently with the account the browser already uses (often the admin's) + $params = array_merge(['prompt' => 'select_account'], $this->extraParamsFor($source, true), ['client_id' => $source->clientId, 'response_type' => 'code', 'redirect_uri' => $this->redirectUri(), 'response_mode' => 'query', 'scope' => $source->oauthScope, 'state' => $state]); + return $endpoint . (str_contains($endpoint, '?') ? '&' : '?') . http_build_query($params); } /** @@ -248,9 +252,17 @@ class OAuthService return $value ?? throw new UserError('imapsync_source_oauth_invalid'); } + /** Stored extra params of the browser sign-in ($authorize) or of the token request */ + private function extraParamsFor(Source $source, bool $authorize): array + { + $extra = json_decode((string)$source->extraParams, true); + return array_filter(is_array($extra) ? $extra : [], + fn($key): bool => in_array($key, self::AUTHORIZE_PARAMS, true) === $authorize, ARRAY_FILTER_USE_KEY); + } + /** - * Extra token request parameters: a JSON object with scalar values, as string or as array - * (after 011-api.js auto-parsing). Returns the JSON to store, null for none. + * Extra parameters: a JSON object with scalar values, as string or as array (after 011-api.js + * auto-parsing). Returns the JSON to store, null for none. */ private function extraParams(mixed $extra): ?string { @@ -277,8 +289,7 @@ class OAuthService */ private function requestToken(Source $source, array $grant): array { - $extra = json_decode((string)$source->extraParams, true); - $post = array_merge(is_array($extra) ? $extra : [], + $post = array_merge($this->extraParamsFor($source, false), ['client_id' => $source->clientId, 'client_secret' => $source->clientSecret, 'scope' => $source->oauthScope], $grant); $token = $this->client->request((string)$source->tokenEndpoint, $this->isStrict($source->createdBy), $post); if (empty($token['access_token']) || !is_string($token['access_token'])) { diff --git a/data/web/inc/lib/mailcow/Imapsync/Service/SourceService.php b/data/web/inc/lib/mailcow/Imapsync/Service/SourceService.php index 22f80f63a..b3b70a8b0 100644 --- a/data/web/inc/lib/mailcow/Imapsync/Service/SourceService.php +++ b/data/web/inc/lib/mailcow/Imapsync/Service/SourceService.php @@ -97,6 +97,7 @@ class SourceService throw new UserError('object_exists', [htmlspecialchars($source->name)]); } $this->repo->insert($source); + $this->fetchToken($source); return $source; } @@ -121,6 +122,7 @@ class SourceService $this->applyScope($source, $input['scope'] ?? $current->scope, $input['domains'] ?? [], $input['users'] ?? []); } $this->repo->update($source, $writeTargets, self::connection($current) !== self::connection($source)); + $this->fetchToken($source); return $source; } @@ -338,6 +340,14 @@ class SourceService return array_values(array_unique($clean)); } + /** A saved, active client_credentials source gets its token now instead of at the next cron run (error in lastRefreshError) */ + private function fetchToken(Source $source): void + { + if ($source->usesClientCredentials() && $source->active === 1) { + $source->lastRefreshError = $this->oauth->refreshSourceToken($source); + } + } + /** Tokens never follow a source to another OAuth client or IMAP server, so these values reset them */ private static function connection(Source $source): array { diff --git a/data/web/inc/vars.inc.php b/data/web/inc/vars.inc.php index bdf0d3a34..451704565 100644 --- a/data/web/inc/vars.inc.php +++ b/data/web/inc/vars.inc.php @@ -294,7 +294,7 @@ $RSPAMD_MAPS = array( // Anything not listed here is rejected when a job is saved (the runner passes stored options as they are). // Override in vars.local.inc.php per option, e.g. $IMAPSYNC_OPTIONS['someoption'] = true; or unset($IMAPSYNC_OPTIONS['debug']); // The old format $IMAPSYNC_OPTIONS['whitelist'] (list of names) is no longer supported and ignored (logged). -// NEVER add (RCE): 'delete2foldersonly', 'delete2foldersbutnot', 'regexflag', 'regexmess', 'pipemess', 'regextrans2', 'maxlinelengthcmd' +// NEVER add (RCE): 'delete2foldersonly', 'delete2foldersbutnot', 'regexflag', 'regexmess', 'pipemess', 'regextrans2', 'maxlinelengthcmd', 'oauthrefreshcmd1', 'oauthrefreshcmd2' // NEVER add options taking local file paths (e.g. 'logfile', 'logdir', 'pidfile', 'passfile1', 'sslargs1' with SSL_ca_file) $IMAPSYNC_OPTIONS_DEFAULT = array( 'abort' => false, diff --git a/data/web/js/site/imapsync.js b/data/web/js/site/imapsync.js index bcf321e00..70284b392 100644 --- a/data/web/js/site/imapsync.js +++ b/data/web/js/site/imapsync.js @@ -588,6 +588,74 @@ var mailcowImapsync = (function($) { } } + // ===== Provider presets (add source modal) ===== + + // Server and OAuth settings of well-known providers; fields a preset leaves out get the defaults of applyPreset + var m365 = 'https://login.microsoftonline.com/{tenant}/oauth2/v2.0/'; + var presets = { + m365_app: {host: 'outlook.office365.com', auth_type: 'XOAUTH2', oauth_token_endpoint: m365 + 'token', + oauth_scope: 'https://outlook.office365.com/.default'}, + m365_user: {host: 'outlook.office365.com', auth_type: 'XOAUTH2', oauth_flow: 'authorization_code', + oauth_authorize_endpoint: m365 + 'authorize', oauth_token_endpoint: m365 + 'token', + oauth_scope: 'https://outlook.office.com/IMAP.AccessAsUser.All offline_access openid email profile'}, + // Google issues a refresh token only for offline access, and again only after consent + google_user: {host: 'imap.gmail.com', auth_type: 'XOAUTH2', oauth_flow: 'authorization_code', + oauth_authorize_endpoint: 'https://accounts.google.com/o/oauth2/v2/auth', oauth_token_endpoint: 'https://oauth2.googleapis.com/token', + oauth_scope: 'https://mail.google.com/ openid email', oauth_extra_params: '{"access_type":"offline","prompt":"consent select_account"}'}, + gmail: {host: 'imap.gmail.com'}, + gmx: {host: 'imap.gmx.net'}, + webde: {host: 'imap.web.de'}, + tonline: {host: 'secureimap.t-online.de'}, + icloud: {host: 'imap.mail.me.com'}, + yahoo: {host: 'imap.mail.yahoo.com'}, + ionos: {host: 'imap.ionos.de'}, + strato: {host: 'imap.strato.de'} + }; + + // The name follows the preset until it is changed by hand; client ID and secret are kept + function applyPreset($link) { + var $form = $link.closest('form'); + var preset = $.extend({port: 993, enc: 'SSL', auth_type: 'PLAIN', oauth_flow: 'client_credentials', oauth_authorize_endpoint: '', + oauth_token_endpoint: '', oauth_userinfo_endpoint: '', oauth_scope: '', oauth_extra_params: ''}, presets[$link.data('preset')]); + var $name = $form.find('input[name="name"]'); + var names = $form.find('.imapsync-source-preset').map(function() { return $.trim($(this).text()); }).get(); + if (!$name.val() || names.indexOf($name.val()) !== -1) $name.val($.trim($link.text())); + // bootstrap-select 1.14 duplicates the button label on refresh after .val(), use its own setter + $.each(preset, function(field, value) { + var $f = $form.find('[name="' + field + '"]'); + if ($f.data('selectpicker')) { + $f.selectpicker('val', value); + } else { + $f.val(value); + } + }); + var needsTenant = preset.oauth_token_endpoint.indexOf('{tenant}') !== -1; + $form.find('.imapsync-source-tenant-row').toggle(needsTenant); + applyTenant($form); + sourceFormToggle($form); + if (needsTenant) $form.find('.imapsync-source-tenant').trigger('focus'); + } + + // M365: the tenant (ID or domain) is part of the endpoint URLs + function applyTenant($form) { + var tenant = encodeURIComponent($.trim($form.find('.imapsync-source-tenant').val() || '')) || '{tenant}'; + $form.find('input[name="oauth_authorize_endpoint"], input[name="oauth_token_endpoint"]').val(function(_, url) { + return url.replace(/^(https:\/\/login\.microsoftonline\.com\/)[^\/]*/, function(_, base) { return base + tenant; }); + }); + } + + // A visible endpoint must not keep the {tenant} placeholder; checked before the form is posted + function tenantValid($form) { + var missing = $form.find('input[name="oauth_authorize_endpoint"]:visible, input[name="oauth_token_endpoint"]:visible') + .filter(function() { return this.value.indexOf('{tenant}') !== -1; }).length > 0; + $form.find('.imapsync-source-tenant').toggleClass('inputMissingAttr', missing); + if (missing) { + $form.find('.imapsync-source-tenant-row').show(); + mailcow_alert_box(lang_danger.imapsync_source_tenant_missing, 'danger'); + } + return !missing; + } + // ===== Wiring ===== function bind() { @@ -659,12 +727,20 @@ var mailcowImapsync = (function($) { sourceScopeToggle($(this).closest('form')); }); $('[data-action="add_item"][data-id="add_imapsync_source"], [data-action="edit_selected"][data-id="edit_imapsync_source"]').on('click', function(e) { - if (!extraParamsValid($(this).closest('form'))) { + var $form = $(this).closest('form'); + if (!extraParamsValid($form) || !tenantValid($form)) { e.preventDefault(); e.stopImmediatePropagation(); return false; } }); + $(document).on('click', '.imapsync-source-preset', function(e) { + e.preventDefault(); + applyPreset($(this)); + }); + $(document).on('input', '.imapsync-source-tenant', function() { + applyTenant($(this).closest('form')); + }); $(document).on('click', '.imapsync-copy-btn', function(e) { e.preventDefault(); copyField($(this).data('copy-target')); diff --git a/data/web/lang/lang.de-de.json b/data/web/lang/lang.de-de.json index 3865447d4..29919b71b 100644 --- a/data/web/lang/lang.de-de.json +++ b/data/web/lang/lang.de-de.json @@ -572,6 +572,7 @@ "imapsync_source_oauth_required": "OAuth2 erfordert Token-Endpunkt, Client-ID, Client-Secret und Scope", "imapsync_source_oauth_endpoint_invalid": "Ungültiger OAuth2-Endpunkt: Erforderlich ist eine https://-URL mit gültigem Hostnamen (Quellen, die nicht von einem Administrator angelegt wurden, brauchen einen öffentlich erreichbaren Host)", "imapsync_source_oauth_extra_invalid": "OAuth2-Extra-Parameter müssen ein JSON-Objekt mit einfachen Werten sein, z. B. {\"resource\": \"https://example.com\"}", + "imapsync_source_tenant_missing": "Bitte den Microsoft-365-Tenant angeben", "imapsync_source_oauth_invalid": "Ungültige OAuth2-Konfiguration", "imapsync_max_parallel_invalid": "Die Anzahl paralleler Prozesse muss zwischen 1 und 32 liegen", "imapsync_source_description_invalid": "Die Beschreibung darf höchstens 255 Zeichen lang sein", @@ -1356,7 +1357,11 @@ "source_oauth_client_secret": "Client-Secret", "source_oauth_scope": "Scope", "source_oauth_extra_params": "Zusätzliche Parameter (JSON)", - "source_oauth_extra_params_hint": "Optionales JSON-Objekt mit zusätzlichen Parametern für die Token-Anfrage, z. B. {\"resource\": \"https://provider.example.com\"}", + "source_oauth_extra_params_hint": "Optionales JSON-Objekt. prompt, access_type, login_hint, domain_hint und hd gehen an die Anmeldung beim Provider, alle anderen an die Token-Anfrage, z. B. {\"resource\": \"https://provider.example.com\"}", + "source_presets": "Vorlagen", + "source_presets_hint": "Füllt die Serverdaten des Anbieters aus. Viele Anbieter (z. B. Gmail, iCloud, Yahoo) verlangen für IMAP ein App-Passwort oder die Freischaltung von IMAP in den Postfach-Einstellungen.", + "source_tenant": "Microsoft-365-Tenant", + "source_tenant_hint": "Verzeichnis-ID (Mandant) oder eine Domain des Tenants, z. B. contoso.onmicrosoft.com. Wird in die Endpunkte eingesetzt.", "source_scope_cc_hint": "Quellen mit Client-Credentials-Flow sind immer nur für ihren Ersteller sichtbar.", "source_readonly_hint": "Diese Sync-Quelle ist freigegeben und kann nur angesehen werden.", "copy": "Kopieren", diff --git a/data/web/lang/lang.en-gb.json b/data/web/lang/lang.en-gb.json index 1849caf40..16fc055eb 100644 --- a/data/web/lang/lang.en-gb.json +++ b/data/web/lang/lang.en-gb.json @@ -572,6 +572,7 @@ "imapsync_source_oauth_required": "OAuth2 requires token endpoint, client ID, client secret and scope", "imapsync_source_oauth_endpoint_invalid": "Invalid OAuth2 endpoint: an https:// URL with a valid host name is required (sources not created by an administrator need a publicly reachable host)", "imapsync_source_oauth_extra_invalid": "OAuth2 extra parameters must be a JSON object with simple values, e.g. {\"resource\": \"https://example.com\"}", + "imapsync_source_tenant_missing": "Please enter the Microsoft 365 tenant", "imapsync_source_oauth_invalid": "Invalid OAuth2 configuration", "imapsync_max_parallel_invalid": "Parallel process count must be between 1 and 32", "imapsync_source_description_invalid": "The description must not exceed 255 characters", @@ -1363,7 +1364,11 @@ "source_oauth_client_secret": "Client secret", "source_oauth_scope": "Scope", "source_oauth_extra_params": "Extra parameters (JSON)", - "source_oauth_extra_params_hint": "Optional JSON object with additional parameters for the token request, e.g. {\"resource\": \"https://provider.example.com\"}", + "source_oauth_extra_params_hint": "Optional JSON object. prompt, access_type, login_hint, domain_hint and hd are sent with the provider sign-in, all others with the token request, e.g. {\"resource\": \"https://provider.example.com\"}", + "source_presets": "Presets", + "source_presets_hint": "Fills in the provider's server settings. Many providers (e.g. Gmail, iCloud, Yahoo) require an app password or IMAP access to be enabled in the mailbox settings.", + "source_tenant": "Microsoft 365 tenant", + "source_tenant_hint": "Directory (tenant) ID or a domain of the tenant, e.g. contoso.onmicrosoft.com. It is inserted into the endpoints.", "source_scope_cc_hint": "Sources using the client credentials flow are always private to their creator.", "source_readonly_hint": "This sync source is shared with you and can only be viewed.", "copy": "Copy", diff --git a/data/web/templates/modals/imapsync_source.twig b/data/web/templates/modals/imapsync_source.twig index 650d2141e..43254eb8a 100644 --- a/data/web/templates/modals/imapsync_source.twig +++ b/data/web/templates/modals/imapsync_source.twig @@ -9,6 +9,29 @@
+
+ +
+ {% if mailcow_cc_role != 'user' %} +
+ Microsoft 365 ({{ lang.syncjobs.source_flow_badge_app }}) + Microsoft 365 ({{ lang.syncjobs.source_flow_badge_user }}) + Google ({{ lang.syncjobs.source_flow_badge_user }}) +
+ {% endif %} +
+ Gmail + GMX + WEB.DE + T-Online + iCloud + Yahoo + IONOS + STRATO +
+ {{ lang.syncjobs.source_presets_hint }} +
+
@@ -101,6 +124,13 @@
+