public
nobgit
read
NobMail
Based on mailcow: dockerized
Languages
Repository composition by tracked source files.
PHP
49%
JavaScript
35%
HTML
9%
CSS
4%
Shell
2%
Python
1%
Lua
0%
Perl
0%
Ruby
0%
SCSS
0%
Create file
Wiki Documentation
Clone
https://nobgit.com/orgs/nobgit/nobmail.git
ssh://[email protected]:2222/orgs/nobgit/nobmail.git
Commit
[Dovecot] Update imapsync
a771d668
data/Dockerfiles/dovecot/Dockerfile | 10 +
data/Dockerfiles/dovecot/imapsync | 11930 ++++++++++++++++++++--------------
2 files changed, 7201 insertions(+), 4739 deletions(-)Diff
diff --git a/data/Dockerfiles/dovecot/Dockerfile b/data/Dockerfiles/dovecot/Dockerfile
index d2cdd0e3..1da6678a 100644
--- a/data/Dockerfiles/dovecot/Dockerfile
+++ b/data/Dockerfiles/dovecot/Dockerfile
@@ -14,6 +14,16 @@ RUN apt-get update && apt-get -y install \
cpanminus \
curl \
default-libmysqlclient-dev \
+ libjson-webtoken-perl \
+ libcgi-pm-perl \
+ libcrypt-openssl-rsa-perl \
+ libdata-uniqid-perl \
+ libhtml-parser-perl \
+ libmail-imapclient-perl \
+ libparse-recdescent-perl \
+ libsys-meminfo-perl \
+ libtest-mockobject-perl \
+ libwww-perl \
libauthen-ntlm-perl \
libbz2-dev \
libcrypt-ssleay-perl \
diff --git a/data/Dockerfiles/dovecot/imapsync b/data/Dockerfiles/dovecot/imapsync
index 8df547c6..c31abb18 100755
--- a/data/Dockerfiles/dovecot/imapsync
+++ b/data/Dockerfiles/dovecot/imapsync
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $Id: imapsync,v 1.727 2016/08/19 10:30:36 gilles Exp gilles $
+# $Id: imapsync,v 1.836 2017/09/05 16:14:53 gilles Exp gilles $
# structure
# pod documentation
# pragmas
@@ -11,7 +11,7 @@
# folder loop
# subroutines
# sub usage {
-# IMAPClient 3.xx ads
+
# pod documentation
@@ -19,15 +19,15 @@
=head1 NAME
-imapsync - Email IMAP tool for syncing, copying and migrating email mailboxes.
+imapsync - Email IMAP tool for syncing, copying and migrating
+email mailboxes between two imap servers, one way,
+and without duplicates.
-The imapsync command synchronises mailboxes between two imap servers.
-More than 69 different IMAP server softwares supported with success,
-few failures.
+=head1 VERSION
-$Revision: 1.727 $
+This documentation refers to Imapsync $Revision: 1.836 $
-=head1 SYNOPSIS
+=head1 USAGE
To synchronize the source imap account
"test1" on server "test1.lamiral.info" with password "secret1"
@@ -39,84 +39,102 @@ $Revision: 1.727 $
--host1 test1.lamiral.info --user1 test1 --password1 secret1 \
--host2 test2.lamiral.info --user2 test2 --password2 secret2
-=head1 REQUIRED ARGUMENTS
+=head1 DESCRIPTION
-The required argmuments are the six values, three on each sides,
-needed to login into the IMAP servers,
-a host, a username, and a password, two times.
+We sometimes need to transfer mailboxes from one imap server to
+another.
-=head1 INSTALL
+Imapsync command is a tool allowing incremental and
+recursive imap transfers from one mailbox to another.
- Imapsync works under any Unix with perl.
- Imapsync works under Windows (2000, XP, Vista, Seven)
- as a standalone binary software called imapsync.exe
- Imapsync works under OS X as a standalone binary
- software called imapsync_bin_Darwin.
+By default all folders are transferred, recursively, meaning
+the whole folder hierarchy is taken, all messages in them,
+and all messages flags (\Seen \Answered \Flagged etc.)
+are synced too.
- Purchase latest imapsync at
- http://imapsync.lamiral.info/
+Imapsync reduces the amount
+of data transferred by not transferring a given message
+if it resides already on both sides. Same specific headers
+and the transfer is done only once (by default it's
+"Message-Id:" and "Received:" lines but it can be changed with
+--useheader option).
- 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):
+All flags are preserved, unread will stay unread, read will stay read,
+deleted will stay deleted.
- tar xzvf imapsync-x.xx.tgz
+You can stop the transfer at any
+time and restart it later, imapsync works well with bad
+connections and interruptions.
- Go into the directory imapsync-x.xx and read the INSTALL file.
- As mentioned at http://imapsync.lamiral.info/#install
- the INSTALL file can also be found at
- http://imapsync.lamiral.info/INSTALL
- It is now split in several files for each system
- http://imapsync.lamiral.info/INSTALL.d/
+You can decide to delete the messages from the source mailbox
+after a successful transfer, it can be a good feature when migrating
+live mailboxes since messages will be only on one side.
+In that case, use the --delete1 option. Option --delete1 implies
+also option --expunge1 so all messages marked deleted on host1
+will be really deleted.
-=head1 CONFIGURATION
+A different scenario is synchronizing a mailbox B from another mailbox A
+in case you just want to keep a "live" copy of A in B.
+In that case --delete2 has to be used, it deletes messages in host2
+folder B that are not in host1 folder A. If you also need to destroy
+host2 folders that are not in host1 then use --delete2folders (see also
+--delete2foldersonly and --delete2foldersbutnot).
-There is no specific configuration file for imapsync,
-everything is specified by the command line parameteres
-and the default 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.
-=head1 USAGE
-To get a description of each option just run imapsync
-with no argument, like this:
+=head1 OPTIONS
- imapsync
+ usage: imapsync [options]
-This description of options is also available at
-http://imapsync.lamiral.info/OPTIONS and is
-reproduced here:
+Mandatory options are the six values, three on each sides,
+needed to log in into the IMAP servers, ie,
+a host, a username, and a password, two times.
- usage: ./imapsync [options]
+Conventions used:
- Several options are mandatory.
str means string
int means integer
reg means regular expression
cmd means command
- --dry : Makes imapsync doing nothing, just print what would
- be done without --dry.
+ --dry : Makes imapsync doing nothing for real, just print what
+ would be done without --dry.
+
+=head2 OPTIONS/credentials
+
--host1 str : Source or "from" imap server. Mandatory.
--port1 int : Port to connect on host1. Default is 143, 993 if --ssl1
--user1 str : User to login on host1. Mandatory.
- --showpasswords : Shows passwords on output instead of "MASKED".
- Useful to restart a complete run by just reading the log.
--password1 str : Password for the user1.
--host2 str : "destination" imap server. Mandatory.
--port2 int : Port to connect on host2. Default is 143, 993 if --ssl2
--user2 str : User to login on host2. Mandatory.
--password2 str : Password for the user2.
+ --showpasswords : Shows passwords on output instead of "MASKED".
+ Useful to restart a complete run by just reading the log,
+ or to debug passwords. It's not a secure practice.
+
--passfile1 str : Password file for the user1. It must contain the
password on the first line. This option avoids to show
the password on the command line like --password1 does.
--passfile2 str : Password file for the user2. Contains the password.
- --ssl1 : Use a SSL connection on host1.
- --ssl2 : Use a SSL connection on host2.
- --tls1 : Use a TLS connection on host1.
- --tls2 : Use a TLS connection on host2.
+=head2 OPTIONS/encryption
+
+ --nossl1 : Do not use a SSL connection on host1.
+ --ssl1 : Use a SSL connection on host1. On by default if possible.
+ --nossl2 : Do not use a SSL connection on host2.
+ --ssl2 : Use a SSL connection on host2. On 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.
+ --notls2 : Do not use a TLS connection on host2.
+ --tls2 : Use a TLS connection on host2. On by default if possible.
--debugssl int : SSL debug mode from 0 to 4.
--sslargs1 str : Pass any ssl parameter for host1 ssl or tls connection. Example:
--sslargs1 SSL_verify_mode=1 --sslargs1 SSL_version=SSLv3
@@ -130,6 +148,9 @@ reproduced here:
--timeout2 int : Connection timeout in seconds for host2.
Default is 120 and 0 means no timeout at all.
+
+=head2 OPTIONS/authentication
+
--authmech1 str : Auth mechanism to use with host1:
PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE.
--authmech2 str : Auth mechanism to use with host2. See --authmech1
@@ -142,12 +163,15 @@ reproduced here:
be able to use an administrative user.
--proxyauth2 : Use proxyauth on host2. Requires --authuser2.
- --authmd51 : Use MD5 authentification for host1.
- --authmd52 : Use MD5 authentification for host2.
+ --authmd51 : Use MD5 authentication for host1.
+ --authmd52 : Use MD5 authentication for host2.
--domain1 str : Domain on host1 (NTLM authentication).
--domain2 str : Domain on host2 (NTLM authentication).
+=head2 OPTIONS/folders
+
+
--folder str : Sync this folder.
--folder str : and this one, etc.
--folderrec str : Sync this folder recursively.
@@ -158,17 +182,16 @@ reproduced here:
--folderlast str : Sync this folder last. --folderlast "[Gmail]/All Mail"
--folderlast str : then this one, etc.
- --nomixfolders : Do not merge folders when host1 is case sensitive
+ --nomixfolders : Do not merge folders when host1 is case-sensitive
while host2 is not (like Exchange). Only the first
similar folder is synced (ex: Sent SENT sent -> Sent).
--skipemptyfolders : Empty host1 folders are not created on host2.
- --f1f2 str1=str2 : Force folder str1 to be synced to str2.
--include reg : Sync folders matching this regular expression
--include reg : or this one, etc.
- in case both --include --exclude options are
- use, include is done before.
+ If both --include --exclude options are used, then
+ include is done before.
--exclude reg : Skips folders matching this regular expression
Several folders to avoid:
--exclude 'fold1|fold2|f3' skips fold1, fold2 and f3.
@@ -179,37 +202,73 @@ reproduced here:
It does it by adding two --regextrans2 options before
all others. Add --debug to see what's really going on.
+ --automap : guesses folders mapping, for folders like
+ "Sent", "Junk", "Drafts", "All", "Archive", "Flagged".
+ --f1f2 str1=str2 : Force folder str1 to be synced to str2,
+ --f1f2 overrides --automap and --regextrans2.
+
+ --nomixfolders : Avoid merging folders that are considered different on
+ host1 but the same on destination host2 because of
+ case sensitivities and insensitivities.
+
+ --subscribed : Transfers subscribed folders.
+ --subscribe : Subscribe to the folders transferred on the
+ host2 that are subscribed on host1. On by default.
+ --subscribeall : Subscribe to the folders transferred on the
+ host2 even if they are not subscribed on host1.
+
+ --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
+ does not have NAMESPACE capability. This option
+ should not be used, most of the time.
+ --prefix2 str : Add prefix to all host2 folders. See --prefix1
+ --sep1 str : Host1 separator in case NAMESPACE is not supported.
+ --sep2 str : Host2 separator in case NAMESPACE is not supported.
+
--regextrans2 reg : Apply the whole regex to each destination folders.
--regextrans2 reg : and this one. etc.
When you play with the --regextrans2 option, first
add also the safe options --dry --justfolders
Then, when happy, remove --dry, remove --justfolders.
Have in mind that --regextrans2 is applied after prefix
- and separator inversion.
+ and separator inversion. For examples see
+ http://imapsync.lamiral.info/FAQ.d/FAQ.Folders_Mapping.txt
+
+=head2 OPTIONS/folders sizes
+
+ --nofoldersizes : Do not calculate the size of each folder at the
+ beginning of the sync. Default is to calculate them.
+ --nofoldersizesatend: Do not calculate the size of each folder at the
+ end of the sync. Default is to calculate them.
+ --justfoldersizes : Exit after having printed the initial folder sizes.
+
+
+=head2 OPTIONS/tmp
+
--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
- it's often small and deleted at reboot.
+ /tmp is often too small and deleted at reboot.
--tmpdir /var/tmp should be better.
- --pidfile str : The file where imapsync pid is written.
- --pidfilelocking : Abort if pidfile already exists. Usefull to avoid
+ --pidfile str : The file where imapsync pid is written,
+ it can be dirname/filename.
+ Default name is imapsync.pid in tmpdir.
+ --pidfilelocking : Abort if pidfile already exists. Useful to avoid
concurrent transfers on the same mailbox.
+
+=head2 OPTIONS/log
+
--nolog : Turn off logging on file
--logfile str : Change the default log filename (can be dirname/filename).
- --logdir str : Change the default log directory. Default is LOG_imapsync
+ --logdir str : Change the default log directory. Default is LOG_imapsync/
- --prefix1 str : Remove prefix to all destination folders
- (usually INBOX. or INBOX/ or an empty string "")
- you have to use --prefix1 if host1 imap server
- does not have NAMESPACE capability, so imapsync
- suggests to use it. All other cases are bad.
- --prefix2 str : Add prefix to all host2 folders. See --prefix1
- --sep1 str : Host1 separator in case NAMESPACE is not supported.
- --sep2 str : Host2 separator in case NAMESPACE is not supported.
- --skipmess reg : Skips messages maching the regex.
+=head2 OPTIONS/messages
+
+ --skipmess reg : Skips messages matching the regex.
Example: 'm/[\x80-ff]/' # to avoid 8bits messages.
--skipmess is applied before --regexmess
--skipmess reg : or this one, etc.
@@ -224,15 +283,32 @@ reproduced here:
Example: 's/\000/ /g' # to replace null by space.
--regexmess reg : and this one, etc.
+
+=head2 OPTIONS/flags
+
--regexflag reg : Apply the whole regex to each flags list.
Example: 's/"Junk"//g' # to remove "Junk" flag.
- --regexflag reg : and this one, etc.
+ --regexflag reg : then this one, etc.
+
- --delete : Deletes messages on host1 server after a successful
- transfer. Option --delete has the following behavior:
+=head2 OPTIONS/deletions
+
+ --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
- EXPUNGE IMAP command.
+ EXPUNGE IMAP command. If expunging after each message
+ slows down too much the sync then use
+ --noexpungeaftereach to speed up.
+ --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
+ if option --delete1 is set.
+ --noexpunge1 : Do not expunge messages on host1.
+ --delete1emptyfolders : Deletes empty folders on host1, INBOX excepted.
+ Useful with --delete1 since what remains on host1
+ is only what failed to be synced.
--delete2 : Delete messages in host2 that are not in
host1 server. Useful for backup or pre-sync.
@@ -247,19 +323,13 @@ reproduced here:
Example: --delete2foldersonly "/^Junk$|^INBOX.Junk$/"
--delete2foldersbutnot reg : Do not delete folders matching regex.
Example: --delete2foldersbutnot "/Tasks$|Contacts$|Foo$/"
- --noexpunge : Do not expunge messages on host1.
- Expunge really deletes messages marked deleted.
- Expunge is made at the beginning, on host1 only.
- Newly transferred messages are also expunged if
- option --delete is given.
- No expunge is done on host2 account (unless --expunge2)
- --expunge1 : Expunge messages on host1 after messages transfer.
+
--expunge2 : Expunge messages on host2 after messages transfer.
--uidexpunge2 : uidexpunge messages on the host2 account
that are not on the host1 account, requires --delete2
- --nomixfolders : Avoid merging folders that are considered different on
- host1 but the same on destination host2 because of
- case sensitivities and insensitivities.
+
+
+=head2 OPTIONS/dates
--syncinternaldates : Sets the internal dates on host2 same as host1.
Turned on by default. Internal date is the date
@@ -267,6 +337,9 @@ reproduced here:
--idatefromheader : Sets the internal dates on host2 same as the
"Date:" headers.
+
+=head2 OPTIONS/message selection
+
--maxsize int : Skip messages larger (or equal) than int bytes
--minsize int : Skip messages smaller (or equal) than int bytes
--maxage int : Skip messages older than int days.
@@ -286,44 +359,35 @@ reproduced here:
--search2 str : Same as --search for selecting host2 messages only.
--search CRIT equals --search1 CRIT --search2 CRIT
- --exitwhenover int : Stop syncing when total bytes transferred reached.
- Gmail per day allows
- 2500000000 = 2.5 GB downloaded from Gmail as host2
- 500000000 = 500 MB uploaded to Gmail as host1.
-
--maxlinelength int : skip messages with a line length longer than int bytes.
RFC 2822 says it must be no more than 1000 bytes.
+
--useheader str : Use this header to compare messages on both sides.
Ex: Message-ID or Subject or Date.
--useheader str and this one, etc.
- --subscribed : Transfers subscribed folders.
- --subscribe : Subscribe to the folders transferred on the
- host2 that are subscribed on host1. On by default.
- --subscribeall : Subscribe to the folders transferred on the
- host2 even if they are not subscribed on host1.
-
- --nofoldersizes : Do not calculate the size of each folder in bytes
- and message counts. Default is to calculate them.
- --nofoldersizesatend: Do not calculate the size of each folder in bytes
- and message counts at the end. Default is on.
- --justfoldersizes : Exit after having printed the folder sizes.
-
- --syncacls : Synchronises acls (Access Control Lists).
- --nosyncacls : Does not synchronize acls. This is the default.
- Acls in IMAP are not standardized, be careful.
-
- --usecache : Use cache to speedup.
+ --usecache : Use cache to speed up the sync.
--nousecache : Do not use cache. Caveat: --useuid --nousecache creates
duplicates on multiple runs.
--useuid : Use uid instead of header as a criterium to recognize
messages. Option --usecache is then implied unless
--nousecache is used.
+
+=head2 OPTIONS/miscelaneous
+
+ --syncacls : Synchronizes acls (Access Control Lists).
+ --nosyncacls : Does not synchronize acls. This is the default.
+ Acls in IMAP are not standardized, be careful.
+
+
+
+=head2 OPTIONS/debugging
+
--debug : Debug mode.
--debugfolders : Debug mode for the folders part only.
- --debugcontent : Debug content of the messages transfered. Huge ouput.
+ --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.
@@ -335,6 +399,42 @@ reproduced here:
--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 connexion.
+ --testslive6 : Run a live test with ks2ipv6.lamiral.info imap server.
+ Useful to check the ipv6 connectivity. Needs internet.
+
+
+=head2 OPTIONS/specific
+
+ --gmail1 : sets --host1 to Gmail and options from FAQ.Gmail.txt
+ --gmail2 : sets --host2 to Gmail and options from FAQ.Gmail.txt
+
+ --office1 : sets --host1 to Office365 options from FAQ.Exchange.txt
+ --office2 : sets --host2 to Office365 options from FAQ.Exchange.txt
+
+ --exchange1 : sets options from FAQ.Exchange.txt, account1 part
+ --exchange2 : sets options from FAQ.Exchange.txt, account2 part
+
+ --domino1 : sets options from FAQ.Domino.txt, account1 part
+ --domino2 : sets options from FAQ.Domino.txt, account2 part
+
+
+
+
+=head2 OPTIONS/behavior
+
+ --maxmessagespersecond int : limits the number of messages transferred per second.
+
+ --maxbytespersecond int : limits the average transfer rate per second.
+ --maxbytesafter int : starts --maxbytespersecond limitation only after
+ --maxbytesafter amount of data transferred.
+
+ --maxsleep int : do not sleep more than int seconds.
+ On by default, 2 seconds max, like --maxsleep 2
+
+ --abort : terminates a previous call still running.
+ It uses the pidfile to know what processus to abort.
+
+ --exitwhenover int : Stop syncing when total bytes transferred reached.
--version : Print only software version.
--noreleasecheck : Do not check for new imapsync release (a http request).
@@ -348,102 +448,22 @@ reproduced here:
--help : print this help.
- Example:
- To synchronize the source imap account
- "test1" on server "test1.lamiral.info" with password "secret1"
- to the destination imap account
- "test2" on server "test2.lamiral.info" with password "secret2"
- do:
+ 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"
imapsync \
--host1 test1.lamiral.info --user1 test1 --password1 secret1 \
--host2 test2.lamiral.info --user2 test2 --password2 secret2
+
=cut
# comment
=pod
-=head1 DESCRIPTION
-
-Imapsync command is a tool allowing incremental and
-recursive imap transfers from one mailbox to another.
-
-By default all folders are transferred, recursively, all
-possible flags (\Seen \Answered \Flagged etc.) are synced too.
-
-We sometimes need to transfer mailboxes from one imap server to
-another. This is called migration.
-
-Imapsync reduces the amount
-of data transferred by not transferring a given message
-if it resides already on both sides. Same specific headers
-and the transfer is done only once; taken into account are by default
-Message-Id and Received header lines.
-All flags are
-preserved, unread will stay unread, read will stay read,
-deleted will stay deleted. You can stop the transfer at any
-time and restart it later, imapsync works well with bad
-connections and interruptions.
-
-You can decide to delete the messages from the source mailbox
-after a successful transfer, it can be a good feature when migrating
-live mailboxes since messages will be only on one side.
-In that case, use the --delete option. Option --delete implies
-also option --expunge so all messages marked deleted on host1
-will be really deleted.
-(you can use --noexpunge to avoid this but I don't see any
-good real world scenario for the combination --delete --noexpunge).
-
-A different scenario is synchronizing a mailbox B from another mailbox A
-in case you just want to keep a "live" copy of A in B.
-In that case --delete2 has to be used, it deletes messages in host2
-folder B that are not in host1 folder A. If you also need to destroy
-host2 folders that are not in host1 then use --delete2folders (see also
---delete2foldersonly and --delete2foldersbutnot).
-
-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 2 ways synchronizations.
-
-
-=head1 OPTIONS
-
-To get a description of each option just invoke:
-
- imapsync
-
-or read the previous section named USAGE,
-
-or read http://imapsync.lamiral.info/OPTIONS
-
-=head1 HISTORY
-
-I wrote imapsync because an enterprise (basystemes) paid me to install
-a new imap server without losing huge old mailboxes located on a far
-away remote imap server accessible by a low bandwidth link. The tool
-imapcp (written in python) could not help me because I had to verify
-every mailbox was well transferred and delete it after a good
-transfer. imapsync started its life as a copy_folder.pl patch.
-The tool copy_folder.pl comes from the Mail-IMAPClient-2.1.3 perl
-module tarball source (in the examples/ directory of the tarball).
-
-=head1 EXAMPLE
-
-While working on imapsync parameters please run imapsync in
-dry mode (no modification induced) with the --dry
-option. Nothing bad can be done this way.
-To synchronize the imap account "buddy" (with password "secret1")
-on host "imap.src.fr" to the imap account "max" (with password "secret2")
-on host "imap.dest.fr":
-
- imapsync --host1 imap.src.fr --user1 buddy --password1 secret1 \
- --host2 imap.dest.fr --user2 max --password2 secret2
-
-Then you will have max's mailbox updated from buddy's
-mailbox.
=head1 SECURITY
@@ -455,81 +475,42 @@ dangerous because of the 'ps auxwwwwe' command. So, saving
the password in a well protected file (600 or rw-------) is
the best solution.
-imasync is not totally protected against sniffers on the
-network since passwords may be transferred in plain text
-if CRAM-MD5 is not supported by your imap servers. Use
---ssl1 (or --tls1) and --ssl2 (or --tls2) to enable
-encryption on host1 and host2.
-
-You may authenticate as one user (typically an admin user),
-but be authorized as someone else, which means you don't
-need to know every user's personal password. Specify
---authuser1 "adminuser" to enable this on host1. In this
-case, --authmech1 PLAIN will be used by default since it
-is the only way to go for now. So don't use --authmech1 SOMETHING
-with --authuser1 "adminuser", it will not work.
-Same behavior with the --authuser2 option.
-Authenticate with an admin account must be supported by your
-imap server to work with imapsync.
-
-When working on Sun/iPlanet/Netscape IMAP servers you must use
---proxyauth1 to enable administrative user to masquerade as another user.
-Can also be used on destination server with --proxyauth2
-
-You can authenticate with OAUTH when transfering from Google Apps.
-The consumer key will be the domain part of the --user, and the
---password will be used as the consumer secret. It does not work
-with Google Apps free edition.
+Imapsync activates ssl or tls encryption by default, if possible.
+What details are 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.
+
+If the automatic ssl/tls detection fails then imapsync will
+not protect against sniffing activities on the
+network, especially for passwords.
+
+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.
+Imapsync will exit with a 0 status (return code) if everything went good.
Otherwise, it exits with a non-zero status.
-So if you have an unreliable internet connection, you can use this loop
-in a Bourne shell:
- while ! imapsync ...; do
- echo imapsync not complete
- done
=head1 LICENSE AND COPYRIGHT
-imapsync is free, open, public but not always gratis software
+Imapsync is free, open, public but not always gratis software
cover by the NOLIMIT Public License.
See the LICENSE file included in the distribution or just read this
-simple sentence as it is the licence text:
+simple sentence as it IS the licence text:
"No limit to do anything with this work and this license."
-In case it is not long enough I repeat:
+In case it is not long enough, I repeat:
"No limit to do anything with this work and this license."
-=head1 MAILING-LIST
-
-The public mailing-list may be the best way to get free support.
-
-To write on the mailing-list, the address is:
-<[email protected]>
-
-To subscribe, send any message (even empty) to:
-<[email protected]>
-then just reply to the confirmation message.
-
-To unsubscribe, send a message to:
-<[email protected]>
-
-To contact the person in charge for the list:
-<[email protected]>
-
-The list archives are available at:
-http://www.linux-france.org/prj/imapsync_list/
-So consider that the list is public, anyone
-can see your post. Use a pseudonym or do not
-post to this list if you want to stay private.
-
-Thank you for your participation.
+https://imapsync.lamiral.info/LICENSE
=head1 AUTHOR
@@ -539,81 +520,25 @@ Feedback good or bad is very often welcome.
Gilles LAMIRAL earns his living by writing, installing,
configuring and teaching free, open and often gratis
-softwares. It used to be "always gratis" but now it is
-"often" because imapsync is sold by its author, a good
-way to stay maintening and supporting free open public
-softwares (see the license) over decades.
+software. Imapsync used to be "always gratis" but now it is
+only "often gratis" because imapsync is sold by its author,
+a good way to maintain and support free open public
+software over decades.
=head1 BUGS AND LIMITATIONS
-Help me to help you: follow the following guidelines.
-
-Report any bugs or feature requests to the public mailing-list
-or to the author.
-
-Before reporting bugs, read the FAQs, the README and the
-TODO files. http://imapsync.lamiral.info/
-
-Upgrade to last imapsync release, maybe the bug
-is already fixed.
-
-Upgrade to last Mail-IMAPClient Perl module.
-http://search.cpan.org/dist/Mail-IMAPClient/
-maybe the bug is already fixed there.
-
-Make a good title with word "imapsync" in it (my spam filters won't filter it),
-Try to write an email title with more words than just "imapsync" or "problem",
-a good title is made of keywords summary, but not too long (one visible line).
-
-Help us to help you: in your report, please include:
-
- - imapsync version.
-
- - output near the first failures, a few lines before is good to get the context
- of the issue. First failures messages are often more significant than
- the last ones.
-
- - if the issue is always related to the same messages, include the output
- with --debug --debugimap, near the failure point. For example,
- Isolate a buggy message or two in a folder 'BUG' and use
+See https://imapsync.lamiral.info/FAQ.d/FAQ.Reporting_Bugs.txt
- imapsync ... --folder 'BUG' --debug --debugimap
+=head1 IMAP SERVERS supported
- - imap server softwares on both sides and their version number.
-
- - imapsync with all the options you use, the full command line
- you use (except the passwords of course).
-
- - IMAPClient.pm version.
-
- - the run context. Do you run imapsync.exe, a unix binary
- or the perl script imapsync.
-
- - operating system running imapsync.
-
- - virtual software context (vmware, xen etc.)
-
- - operating systems on both sides and the third side in case
- you run imapsync on a foreign host from the both.
-
-Most of those values can be found as a copy/paste at the begining of the output,
-so a carbon copy of the output is a very easy and very good debug report for me.
-
-One time in your life, read the paper
-"How To Ask Questions The Smart Way"
-http://www.catb.org/~esr/faqs/smart-questions.html
-and then forget it.
-
-=head1 IMAP SERVERS
-
-See http://imapsync.lamiral.info/S/imapservers.shtml
+See https://imapsync.lamiral.info/S/imapservers.shtml
=head1 HUGE MIGRATION
Pay special attention to options
--subscribed
--subscribe
---delete
+--delete1
--delete2
--delete2folders
--maxage
@@ -639,7 +564,7 @@ user005_1;password005_1;user005_2;password005_2
On Unix the shell program can be:
{ while IFS=';' read u1 p1 u2 p2; do
- imapsync --host1 imap.side1.org --user1 "$u1" --password1 "$p1" \
+ imapsync --host1 imap.side1.org --user1 "$u1" --password1 "$p1" \
--host2 imap.side2.org --user2 "$u2" --password2 "$p2" ...
done ; } < file.txt
@@ -650,20 +575,46 @@ On Windows the batch program can be:
--host2 imap.side2.org --user2 %%I --password2 %%J ...
The ... have to be replaced by nothing or any imapsync option.
-Welcome in shell programming !
+Welcome in shell or batch programming !
You will find already written scripts at
http://imapsync.lamiral.info/examples/
+=head1 INSTALL
+
+ Imapsync works under any Unix with perl.
+ Imapsync works under Windows (2000, XP, Vista, Seven)
+ as a standalone binary software called imapsync.exe
+ Imapsync works under OS X as a standalone binary
+ software called imapsync_bin_Darwin.
+
+ Purchase latest imapsync at
+ http://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):
+
+ tar xzvf imapsync-x.xx.tgz
+
+ Go into the directory imapsync-x.xx and read the INSTALL file.
+ As mentioned at http://imapsync.lamiral.info/#install
+ the INSTALL file can also be found at
+ http://imapsync.lamiral.info/INSTALL
+ It is now split in several files for each system
+ http://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.
+
=head1 HACKING
Feel free to hack imapsync as the NOLIMIT license permits it.
-=head1 LINKS
-
-Entries for imapsync:
-https://web.archive.org/web/20070202005121/http://www.imap.org/products/showall.php
=head1 SIMILAR SOFTWARES
@@ -686,7 +637,18 @@ https://web.archive.org/web/20070202005121/http://www.imap.org/products/showall.
Feedback (good or bad) will often be welcome.
-$Id: imapsync,v 1.727 2016/08/19 10:30:36 gilles Exp gilles $
+=head1 HISTORY
+
+I wrote imapsync because an enterprise (basystemes) paid me to install
+a new imap server without losing huge old mailboxes located in a far
+away remote imap server, accessible by a low-bandwidth link. The tool
+imapcp (written in python) could not help me because I had to verify
+every mailbox was well transferred, and then delete it after a good
+transfer. 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
+Mail-IMAPClient tarball).
+
=cut
@@ -695,11 +657,9 @@ $Id: imapsync,v 1.727 2016/08/19 10:30:36 gilles Exp gilles $
use strict ;
use warnings ;
-++$| ;
-
use Carp ;
use Data::Dumper ;
-use Digest::HMAC_SHA1 qw( hmac_sha1 ) ;
+use Digest::HMAC_SHA1 qw( hmac_sha1 hmac_sha1_hex ) ;
use Digest::MD5 qw( md5 md5_hex md5_base64 ) ;
use English qw( -no_match_vars ) ;
use Errno qw(EAGAIN EPIPE ECONNRESET) ;
@@ -710,15 +670,18 @@ use File::Glob qw( :glob ) ;
use File::Path qw( mkpath rmtree ) ;
use File::Spec ;
use File::stat ;
-#use Imapsync::Getopt::Long ;
+use Getopt::Long ( ) ;
use IO::File ;
-use IO::Socket qw(:crlf SOL_SOCKET SO_KEEPALIVE) ;
-#use IO::Socket::SSL ;
+use IO::Socket qw( :crlf SOL_SOCKET SO_KEEPALIVE ) ;
+use IO::Socket::INET6 ;
+use IO::Socket::SSL ;
use IO::Tee ;
use IPC::Open3 'open3' ;
use Mail::IMAPClient 3.30 ;
use MIME::Base64 ;
+use Pod::Usage qw(pod2usage) ;
use POSIX qw(uname SIGALRM) ;
+use Sys::Hostname ;
use Term::ReadKey ;
use Test::More ;
use Time::HiRes qw( time sleep ) ;
@@ -726,6 +689,10 @@ use Time::Local ;
use Unicode::String ;
use Cwd ;
use Readonly ;
+#use Net::Ping ;
+use Sys::MemInfo ;
+
+local $OUTPUT_AUTOFLUSH = 1 ;
# constants
@@ -735,10 +702,10 @@ use Readonly ;
Readonly my $EX_OK => 0 ; #/* successful termination */
Readonly my $EX_USAGE => 64 ; #/* command line usage error */
#Readonly my $EX_DATAERR => 65 ; #/* data format error */
-#Readonly my $EX_NOINPUT => 66 ; #/* cannot open input */
+Readonly my $EX_NOINPUT => 66 ; #/* cannot open input */
#Readonly my $EX_NOUSER => 67 ; #/* addressee unknown */
#Readonly my $EX_NOHOST => 68 ; #/* host name unknown */
-#Readonly my $EX_UNAVAILABLE => 69 ; #/* service unavailable */
+Readonly my $EX_UNAVAILABLE => 69 ; #/* service unavailable */
Readonly my $EX_SOFTWARE => 70 ; #/* internal software error */
#Readonly my $EX_OSERR => 71 ; #/* system error (e.g., can't fork) */
#Readonly my $EX_OSFILE => 72 ; #/* critical OS file missing */
@@ -752,11 +719,17 @@ Readonly my $EX_SOFTWARE => 70 ; #/* internal software error */
# Mine
Readonly my $EXIT_BY_SIGNAL => 6 ;
Readonly my $EXIT_PID_FILE_ALREADY_EXIST => 8 ;
+
Readonly my $EXIT_WITH_ERRORS => 111 ;
Readonly my $EXIT_WITH_ERRORS_MAX => 112 ;
Readonly my $EXIT_UNKNOWN => 126 ;
-Readonly my $ERRORS_MAX => 50 ; # exit after 50 errors.
+Readonly my $EXIT_TESTS_FAILED => 254 ; # Like Test::More API
+
+
+
+Readonly my $ERRORS_MAX => 50 ; # exit after 50 errors.
+Readonly my $ERRORS_MAX_CGI => 20 ; # exit after 20 errors in CGI context.
Readonly my $INTERVAL_TO_EXIT => 2 ; # interval max to exit instead of reconnect
@@ -768,18 +741,20 @@ Readonly my $SPLIT_FACTOR => 10 ; # init_imap() calls Maxcommandlength( $SPLIT_
Readonly my $IMAP_PORT => 143 ; # Well know port for IMAP
Readonly my $IMAP_SSL_PORT => 993 ; # Well know port for IMAP over SSL
-Readonly my $LAST => -1 ;
-Readonly my $MINUS_ONE => -1 ;
+Readonly my $LAST => -1 ;
+Readonly my $MINUS_ONE => -1 ;
-Readonly my $RELEASE_NUMBER_EXAMPLE_1 => '1.351' ;
+Readonly my $RELEASE_NUMBER_EXAMPLE_1 => '1.351' ;
Readonly my $RELEASE_NUMBER_EXAMPLE_2 => 42.4242 ;
-
+Readonly my $TCP_PING_TIMEOUT => 5 ;
Readonly my $DEFAULT_TIMEOUT => 120 ;
Readonly my $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND => 3 ;
-Readonly my $DEFAULT_UIDNEXT => 999999 ;
+Readonly my $DEFAULT_UIDNEXT => 999_999 ;
Readonly my $DEFAULT_BUFFER_SIZE => 4096 ;
+Readonly my $MAX_SLEEP => 2 ; # 2 seconds max for limiting too long sleeps from --maxbytespersecond and --maxmessagespersecond
+
Readonly my $DEFAULT_EXPIRATION_TIME_OAUTH2_PK12 => 3600 ;
Readonly my $PERMISSION_FILTER => 7777 ;
@@ -796,11 +771,11 @@ Readonly my $NUMBER_20_000 => 20_000 ;
Readonly my $QUOTA_PERCENT_LIMIT => 90 ;
-Readonly my $NUMBER_104857600 => 104857600 ;
+Readonly my $NUMBER_104_857_600 => 104_857_600 ;
Readonly my $SIZE_MAX_STR => 64 ;
-Readonly my $NB_SECONDS_IN_A_DAY => 86400 ;
+Readonly my $NB_SECONDS_IN_A_DAY => 86_400 ;
Readonly my $STD_CHAR_PER_LINE => 80 ;
@@ -809,20 +784,22 @@ Readonly my $FALSE => 0 ;
Readonly my $LAST_RESSORT_SEPARATOR => q{/} ;
+Readonly my $CGI_TMPDIR_TOP => '/var/tmp/imapsync_cgi' ;
+Readonly my $CGI_HASHFILE => '/var/tmp/imapsync_hash' ;
+Readonly my $UMASK_PARANO => '0077' ;
+
# global variables
my(
- $sync,
- $rcs,
+ $sync,
$debug, $debugimap, $debugimap1, $debugimap2, $debugcontent, $debugflags,
$debuglist, $debugdev, $debugmaxlinelength, @debugbasket, $debugcgi,
- $host1, $host2, $port1, $port2,
- $user1, $user2, $domain1, $domain2,
- $password1, $password2, $passfile1, $passfile2,
+ $domain1, $domain2,
+ $passfile1, $passfile2,
@folder, @include, @exclude, @folderrec,
@folderfirst, @folderlast,
$prefix1, $prefix2,
- $subfolder2,
+ $subfolder2,
@regextrans2, @regexmess, @regexflag, @skipmess, @pipemess, $pipemesscheck,
$flagscase, $filterflags, $syncflagsaftercopy,
$sep1, $sep2,
@@ -835,19 +812,16 @@ my(
$search, $search1, $search2,
$skipheader, @useheader,
$skipsize, $allowsizemismatch, $foldersizes, $foldersizesatend, $buffersize,
- $delete, $delete2, $delete2duplicates,
- $expunge, $expunge1, $expunge2, $uidexpunge2, $dry,
+ $delete1, $delete2, $delete2duplicates,
+ $expunge1, $expunge2, $uidexpunge2,
$justfoldersizes,
$authmd5, $authmd51, $authmd52,
$subscribed, $subscribe, $subscribeall,
$version, $help,
$justconnect, $justfolders, $justbanner,
$fast,
-
- $total_bytes_transferred,
$total_bytes_skipped,
$total_bytes_error,
- $nb_msg_transferred,
$nb_msg_skipped,
$nb_msg_skipped_dry_mode,
$h1_nb_msg_duplicate,
@@ -867,18 +841,14 @@ my(
$h2_nb_msg_end, $h2_bytes_end,
$timeout,
- $timestart_int, $timeend,
+ $timestart_int,
$timebefore,
- $ssl1, $ssl2,
- $ssl1_ssl_version, $ssl2_ssl_version,
- $tls1, $tls2,
$uid1, $uid2,
$authuser1, $authuser2,
$proxyauth1, $proxyauth2,
$authmech1, $authmech2,
$split1, $split2,
$reconnectretry1, $reconnectretry2,
- $tests, $test_builder, $testsdebug, $testslive,
$justlogin,
$tmpdir,
$releasecheck,
@@ -891,8 +861,6 @@ my(
%h1, %h2,
$checkselectable, $checkmessageexists,
$expungeaftereach,
- $abletosearch,
- $showpasswords,
$fixslash2,
$messageidnodomain,
$fixInboxINBOX,
@@ -901,24 +869,36 @@ my(
$uidnext_default,
$fixcolonbug,
$create_folder_old,
- $maxmessagespersecond,
- $maxbytespersecond,
$skipcrossduplicates, $debugcrossduplicates,
$disarmreadreceipts,
$mixfolders, $skipemptyfolders,
- $fetch_hash_set,
+ $fetch_hash_set,
);
-# main program
+# main program
# global variables initialisation
-$rcs = q{$Id: imapsync,v 1.727 2016/08/19 10:30:36 gilles Exp gilles $} ;
+# Currently removing all global variables except $sync
+# passing each of them under $sync->{variable_name}
+
+$sync->{timestart} = time ; # Is a float because of use Time::HiRres
+
+$sync->{rcs} = q{$Id: imapsync,v 1.836 2017/09/05 16:14:53 gilles Exp gilles $} ;
+
+
+
+my @loadavg = loadavg( ) ;
+$sync->{cpu_number} = cpu_number( ) ;
+$sync->{loaddelay} = load_and_delay( $sync->{cpu_number}, @loadavg ) ;
+$sync->{loadavg} = join( q{ }, @loadavg ) . " on $sync->{cpu_number} cores." ;
+
+
-$total_bytes_transferred = 0;
+$sync->{total_bytes_transferred} = 0 ;
$total_bytes_skipped = 0;
$total_bytes_error = 0;
-$nb_msg_transferred = 0;
+$sync->{nb_msg_transferred} = 0;
$nb_msg_skipped = $nb_msg_skipped_dry_mode = 0;
$h1_nb_msg_deleted = $h2_nb_msg_deleted = 0;
$h1_nb_msg_duplicate = $h2_nb_msg_duplicate = 0;
@@ -952,49 +932,70 @@ my %month_abrev = (
);
+my $cgidir ;
+# CGI environment in case
+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 ) ;
+docker_context( $sync ) ;
+cgibuildheader( $sync ) ;
+myprint( output( $sync ) ) ;
+output_reset_with( $sync ) ;
-# @ARGV will be eat by get_options()
-my @argv_copy = @ARGV;
+# Can break here if load is too heavy
+cgiload( $sync ) ;
-my $cgi_dir = '/var/tmp/imapsync_cgi' ;
+# don't go on if options are not all known.
+if ( ! defined $options_good ) { exit $EX_USAGE ; }
-# Under CGI environment
-if ( $ENV{SERVER_SOFTWARE} ) {
- myprint( "\n" ) ;
- myprint( "<pre>\n" ) ;
- -d $cgi_dir or mkpath $cgi_dir or die "Can not create $cgi_dir: $!\n" ;
- chdir $cgi_dir or die "Can not cd to $cgi_dir: $!\n" ;
-}
+# just the version
+myprint( imapsync_version( $sync ), "\n" ) and exit 0 if ( $version ) ;
+
+$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( $options_good ) ;
+
+# Under CGI environment, fix caveat emptor potentiel issues
+cgisetcontext( $sync ) ;
+
+easyany( $sync ) ;
+
+$tmpdir ||= File::Spec->tmpdir( ) ;
+
+# Unit tests
+testsexit( $sync ) ;
+
+# init live varaiables
+testslive( $sync ) if ( $sync->{testslive} ) ;
+testslive6( $sync ) if ( $sync->{testslive6} ) ;
-get_options( ) ;
-unsetunsafe( ) if ( $ENV{SERVER_SOFTWARE} ) ;
+#
+$sync->{pidfile} = defined $sync->{pidfile} ? $sync->{pidfile} : $tmpdir . '/imapsync.pid' ;
+$sync->{pidfilelocking} = defined $sync->{pidfilelocking} ? $sync->{pidfilelocking} : 0 ;
-# Under CGI environment
-if ( $ENV{SERVER_SOFTWARE} ) {
- 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" ) ;
+if ( $sync->{abort} ) {
+ abort( $sync ) ;
}
+
local $SIG{ INT } = sub {
my $signame = shift ;
catch_reconnect( $sync, $signame ) ;
} ;
local $SIG{ QUIT } = local $SIG{ TERM } = sub {
- my $signame = shift ;
+ my $signame = shift ;
catch_exit( $sync, $signame ) ;
} ;
-$sync->{timestart} = $BASETIME ; # Never too let reading books and perlvar
-
$sync->{log} = defined $sync->{log} ? $sync->{log} : 1 ;
$sync->{errorsdump} = defined $sync->{errorsdump} ? $sync->{errorsdump} : 1 ;
$sync->{errorsmax} = defined $sync->{errorsmax} ? $sync->{errorsmax} : $ERRORS_MAX ;
-$sync->{user2} = $user2 ;
if ( $sync->{log} ) {
setlogfile( $sync ) ;
@@ -1008,23 +1009,23 @@ my $timestart_str = localtime( $sync->{timestart} ) ;
myprint( "Transfer started at $timestart_str\n" ) ;
myprint( "PID is $PROCESS_ID\n" ) ;
myprint( "Log file is $sync->{logfile} ( to change it, use --logfile path ; or use --nolog to turn off logging )\n" ) if ( $sync->{log} ) ;
+myprint( "Load is " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $sync->{cpu_number} cores\n" ) ;
+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 ;
# If you want releasecheck not to be done by default (like the github maintainer),
-# then uncomment the first "$releasecheck =" line, the line ending with "0 ;".
-# The second line (ending with "1 ;") can stay active or be commented,
-# the result will be the same: no releasecheck by default.
+# then just uncomment the first "$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 defined value).
$releasecheck = defined $releasecheck ? $releasecheck : 0 ;
#$releasecheck = defined $releasecheck ? $releasecheck : 1 ;
my $warn_release = ( $releasecheck ) ? check_last_release( ) : q{} ;
-# default values
-
-$sync->{pidfile} = defined $sync->{pidfile} ? $sync->{pidfile} : $tmpdir . '/imapsync.pid' ;
-
-$sync->{pidfilelocking} = defined $sync->{pidfilelocking} ? $sync->{pidfilelocking} : 0 ;
$wholeheaderifneeded = defined $wholeheaderifneeded ? $wholeheaderifneeded : 1;
@@ -1047,9 +1048,15 @@ $cacheaftercopy = 1 if ( $usecache and ( ! defined $cacheaftercopy ) ) ;
$checkselectable = defined $checkselectable ? $checkselectable : 1 ;
$checkmessageexists = defined $checkmessageexists ? $checkmessageexists : 0 ;
$expungeaftereach = defined $expungeaftereach ? $expungeaftereach : 1 ;
-$abletosearch = defined $abletosearch ? $abletosearch : 1 ;
-$checkmessageexists = 0 if ( not $abletosearch ) ;
-$showpasswords = defined $showpasswords ? $showpasswords : 0 ;
+
+# 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->{showpasswords} = defined $sync->{showpasswords} ? $sync->{showpasswords} : 0 ;
$fixslash2 = defined $fixslash2 ? $fixslash2 : 1 ;
$fixInboxINBOX = defined $fixInboxINBOX ? $fixInboxINBOX : 1 ;
$create_folder_old = defined $create_folder_old ? $create_folder_old : 0 ;
@@ -1058,46 +1065,31 @@ $sync->{automap} = defined $sync->{automap} ? $sync->{automap} : 0 ;
$delete2duplicates = 1 if ( $delete2 and ( ! defined $delete2duplicates ) ) ;
-$maxmessagespersecond = defined $maxmessagespersecond ? $maxmessagespersecond : 0 ;
-$maxbytespersecond = defined $maxbytespersecond ? $maxbytespersecond : 0 ;
+$sync->{maxmessagespersecond} = defined $sync->{maxmessagespersecond} ? $sync->{maxmessagespersecond} : 0 ;
+$sync->{maxbytespersecond} = defined $sync->{maxbytespersecond} ? $sync->{maxbytespersecond} : 0 ;
+
+$sync->{sslcheck} = defined $sync->{sslcheck} ? $sync->{sslcheck} : 1 ;
-myprint( banner_imapsync( @argv_copy ) ) ;
+myprint( banner_imapsync( @ARGV ) ) ;
myprint( "Temp directory is $tmpdir ( to change it use --tmpdir dirpath )\n") ;
+myprint( output( $sync ) ) ;
-is_valid_directory( $tmpdir ) || croak "Error creating tmpdir $tmpdir : $!" ;
+do_valid_directory( $tmpdir ) || croak "Error creating tmpdir $tmpdir : $OS_ERROR" ;
if ( $sync->{pidfile} ) {
write_pidfile( $sync->{pidfile}, $sync->{pidfilelocking} ) ;
}
-$fixcolonbug = defined $fixcolonbug ? $fixcolonbug : 1 ;
+if ( $sync->{simulong} ) { simulong( $sync->{simulong} ) ; }
-if ( $usecache and $fixcolonbug ) { tmpdir_fix_colon_bug( ) } ;
-$modulesversion and myprint( "Modules version list:\n", modulesversion(), "( use --no-modulesversion to turn off printing this Perl modules list )\n" ) ;
-my $DEFAULT_SSL_VERIFY ;
-my %SSL_VERIFY_STR ;
+$fixcolonbug = defined $fixcolonbug ? $fixcolonbug : 1 ;
-if ( $ssl1 or $ssl2 or $tls1 or $tls2) {
- Readonly $DEFAULT_SSL_VERIFY => IO::Socket::SSL::SSL_VERIFY_NONE( ) ;
- Readonly %SSL_VERIFY_STR => (
- IO::Socket::SSL::SSL_VERIFY_NONE( ) => 'SSL_VERIFY_NONE' ,
- IO::Socket::SSL::SSL_VERIFY_PEER( ) => 'SSL_VERIFY_PEER' ,
- ) ;
- $IO::Socket::SSL::DEBUG = $sync->{debugssl} || 1 ;
- 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 ( $usecache and $fixcolonbug ) { tmpdir_fix_colon_bug( ) } ;
-if ( $ssl1 ) {
- myprint( 'Host1: SSL default mode is like --sslargs1 SSL_verify_mode=' . $DEFAULT_SSL_VERIFY . " meaning $SSL_VERIFY_STR{$DEFAULT_SSL_VERIFY} on host1 (do not check the certificate server)\n" ) ;
- myprint( 'Host1: Use --sslargs1 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " for $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} on host1\n" ) ;
-}
-if ( $ssl2 ) {
- myprint( 'Host2: SSL default mode is like --sslargs2 SSL_verify_mode=' . $DEFAULT_SSL_VERIFY . " meaning $SSL_VERIFY_STR{$DEFAULT_SSL_VERIFY} on host2 (do not check the certificate server)\n" ) ;
- myprint( 'Host2: Use --sslargs2 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " for $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} on host2\n" ) ;
-}
+$modulesversion and myprint( "Modules version list:\n", modulesversion(), "( use --no-modulesversion to turn off printing this Perl modules list )\n" ) ;
check_lib_version( ) or
@@ -1105,15 +1097,17 @@ check_lib_version( ) or
exit_clean( $sync, $EX_OK ) if ( $justbanner ) ;
+sslcheck( $sync ) ;
+
$split1 ||= $SPLIT ;
$split2 ||= $SPLIT ;
-$host1 || missing_option( '--host1' ) ;
-$port1 ||= ( $ssl1 ) ? $IMAP_SSL_PORT : $IMAP_PORT ;
+$sync->{host1} || missing_option( '--host1' ) ;
+$sync->{port1} ||= ( $sync->{ssl1} ) ? $IMAP_SSL_PORT : $IMAP_PORT ;
-$host2 || missing_option( '--host2' ) ;
-$port2 ||= ( $ssl2 ) ? $IMAP_SSL_PORT : $IMAP_PORT ;
+$sync->{host2} || missing_option( '--host2' ) ;
+$sync->{port2} ||= ( $sync->{ssl2} ) ? $IMAP_SSL_PORT : $IMAP_PORT ;
$debugimap1 = $debugimap2 = 1 if ( $debugimap ) ;
$debug = 1 if ( $debugimap1 or $debugimap2 ) ;
@@ -1129,30 +1123,60 @@ $subscribe = defined $subscribe ? $subscribe : 1;
# Allow size mismatch by default
$allowsizemismatch = defined $allowsizemismatch ? $allowsizemismatch : 1;
-$delete2folders = 1
- if ( defined $delete2foldersbutnot or defined $delete2foldersonly ) ;
+
+if ( defined $delete2foldersbutnot or defined $delete2foldersonly ) {
+ $delete2folders = 1 ;
+}
+
+my $DEFAULT_SSL_VERIFY ;
+my %SSL_VERIFY_STR ;
+
+Readonly $DEFAULT_SSL_VERIFY => IO::Socket::SSL::SSL_VERIFY_NONE( ) ;
+Readonly %SSL_VERIFY_STR => (
+ IO::Socket::SSL::SSL_VERIFY_NONE( ) => 'SSL_VERIFY_NONE' ,
+ IO::Socket::SSL::SSL_VERIFY_PEER( ) => 'SSL_VERIFY_PEER' ,
+) ;
+$IO::Socket::SSL::DEBUG = $sync->{debugssl} || 1 ;
+
+
+
+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} ) {
+ myprint( 'Host1: SSL default mode is like --sslargs1 SSL_verify_mode=' . $DEFAULT_SSL_VERIFY . " meaning $SSL_VERIFY_STR{$DEFAULT_SSL_VERIFY} on host1 (do not check the certificate server)\n" ) ;
+ myprint( 'Host1: Use --sslargs1 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " for $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} on host1\n" ) ;
+}
+
+if ( $sync->{ssl2} ) {
+ myprint( 'Host2: SSL default mode is like --sslargs2 SSL_verify_mode=' . $DEFAULT_SSL_VERIFY . " meaning $SSL_VERIFY_STR{$DEFAULT_SSL_VERIFY} on host2 (do not check the certificate server)\n" ) ;
+ myprint( 'Host2: Use --sslargs2 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " for $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} on host2\n" ) ;
+}
+
+
if ( $justconnect ) {
- justconnect( ) ;
- exit_clean( $sync, $EX_OK ) ;
+ justconnect( ) ;
+ exit_clean( $sync, $EX_OK ) ;
}
-$user1 || missing_option( '--user1' ) ;
-$user2 || missing_option( '--user2' ) ;
+$sync->{user1} || missing_option( '--user1' ) ;
+$sync->{user2} || missing_option( '--user2' ) ;
$syncinternaldates = defined $syncinternaldates ? $syncinternaldates : 1;
-# Turn on expunge if there is not explicit option --noexpunge and option
-# --delete is given.
-# Done because --delete --noexpunge is very dangerous on the second run:
-# the Deleted flag is then synced to all previously transfered messages.
-# So --delete implies --expunge is a better usability default behaviour.
-if ( $delete ) {
- if ( ! defined $expunge ) {
- myprint( "Info: turning on --expunge1 because --delete --noexpunge1 is very dangerous on the second run.\n" ) ;
- $expunge = 1 ;
- }
- myprint( "Info: if expunging after each message slows down too much the sync then use --noexpungeaftereach to speed up\n" ) ;
+# 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 ( $delete1 ) {
+ if ( ! defined $expunge1 ) {
+ myprint( "Info: turning on --expunge1 because --delete1 --noexpunge1 is very dangerous on the second run.\n" ) ;
+ $expunge1 = 1 ;
+ }
+ myprint( "Info: if expunging after each message slows down too much the sync then use --noexpungeaftereach to speed up\n" ) ;
}
if ( $uidexpunge2 and not Mail::IMAPClient->can( 'uidexpunge' ) ) {
@@ -1163,48 +1187,48 @@ if ( $uidexpunge2 and not Mail::IMAPClient->can( 'uidexpunge' ) ) {
if ( ( $delete2 or $delete2duplicates ) and not defined $uidexpunge2 ) {
if ( Mail::IMAPClient->can( 'uidexpunge' ) ) {
myprint( "Info: will act as --uidexpunge2\n" ) ;
- $uidexpunge2 = 1 ;
+ $uidexpunge2 = 1 ;
}elsif ( not defined $expunge2 ) {
myprint( "Info: will act as --expunge2 (no uidexpunge support)\n" ) ;
$expunge2 = 1 ;
}
}
-if ( $delete and $delete2 ) {
- myprint( "Warning: using --delete and --delete2 together is almost always a bad idea, exiting imapsync\n" ) ;
- exit_clean( $sync, $EX_USAGE ) ;
+if ( $delete1 and $delete2 ) {
+ myprint( "Warning: using --delete1 and --delete2 together is almost always a bad idea, exiting imapsync\n" ) ;
+ exit_clean( $sync, $EX_USAGE ) ;
}
if ( $idatefromheader ) {
- myprint( 'Turned ON idatefromheader, ',
- "will set the internal dates on host2 from the 'Date:' header line.\n" ) ;
- $syncinternaldates = 0 ;
+ myprint( 'Turned ON idatefromheader, ',
+ "will set the internal dates on host2 from the 'Date:' header line.\n" ) ;
+ $syncinternaldates = 0 ;
}
if ( $syncinternaldates ) {
- myprint( 'Info: turned ON syncinternaldates, ',
- "will set the internal dates (arrival dates) on host2 same as host1.\n" ) ;
+ 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 ) {
- $authmd51 = 1 ;
- $authmd52 = 1 ;
+ $authmd51 = 1 ;
+ $authmd52 = 1 ;
}
if ( defined $authmd51 and $authmd51 ) {
- $authmech1 ||= 'CRAM-MD5';
+ $authmech1 ||= 'CRAM-MD5';
}
else{
- $authmech1 ||= $authuser1 ? 'PLAIN' : 'LOGIN';
+ $authmech1 ||= $authuser1 ? 'PLAIN' : 'LOGIN';
}
if ( defined $authmd52 and $authmd52 ) {
- $authmech2 ||= 'CRAM-MD5';
+ $authmech2 ||= 'CRAM-MD5';
}
else{
- $authmech2 ||= $authuser2 ? 'PLAIN' : 'LOGIN';
+ $authmech2 ||= $authuser2 ? 'PLAIN' : 'LOGIN';
}
$authmech1 = uc $authmech1;
@@ -1218,8 +1242,8 @@ if (defined $proxyauth2 && !$authuser2) {
missing_option( 'With --proxyauth2, --authuser2' ) ;
}
-$authuser1 ||= $user1;
-$authuser2 ||= $user2;
+$authuser1 ||= $sync->{user1};
+$authuser2 ||= $sync->{user2};
myprint( "Host1: will try to use $authmech1 authentication on host1\n") ;
myprint( "Host2: will try to use $authmech2 authentication on host2\n") ;
@@ -1249,7 +1273,7 @@ $reconnectretry2 = defined $reconnectretry2 ? $reconnectretry2 : $DEFAULT_NB_R
# then $uidnext_default is never used. So I have to remove it.
$uidnext_default = $DEFAULT_UIDNEXT ;
-@useheader = qw( Message-Id Received ) unless ( @useheader ) ;
+if ( ! @useheader ) { @useheader = qw( Message-Id Received ) ; }
my %useheader ;
@@ -1259,44 +1283,18 @@ for ( @useheader ) { $useheader{ uc $_ } = undef } ;
#myprint( Data::Dumper->Dump( [ \%useheader ] ) ) ;
#exit ;
-myprint( "Host1: IMAP server [$host1] port [$port1] user [$user1]\n" ) ;
-myprint( "Host2: IMAP server [$host2] port [$port2] user [$user2]\n" ) ;
-
-$password1 || $passfile1 || 'PREAUTH' eq $authmech1 || 'EXTERNAL' eq $authmech1 || do {
- myprint( << 'FIN_PASSFILE' ) ;
-
-If you are afraid of giving password on the command line arguments, you can put the
-password of user1 in a file named file1 and use "--passfile1 file1" instead of typing it.
-Then give this file restrictive permissions with the command "chmod 600 file1".
-FIN_PASSFILE
-
- $password1 = ask_for_password( $authuser1 || $user1, $host1 ) ;
-} ;
-
-$password1 = ( defined $passfile1 ) ? firstline ( $passfile1 ) : $password1 ;
-
-
-$password2 || $passfile2 || 'PREAUTH' eq $authmech2 || 'EXTERNAL' eq $authmech2 || do {
- myprint( << 'FIN_PASSFILE' ) ;
-
-If you are afraid of giving password on the command line arguments, you can put the
-password of user2 in a file named file2 and use "--passfile2 file2" instead of typing it.
-Then give this file restrictive permissions with the command "chmod 600 file2".
-FIN_PASSFILE
+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" ) ;
- $password2 = ask_for_password( $authuser2 || $user2, $host2 ) ;
-} ;
+get_password1( $sync ) ;
+get_password2( $sync ) ;
-$password2 = ( defined $passfile2 ) ? firstline ( $passfile2 ) : $password2 ;
-# need clean up => write methods dry() and dry_message()
-$sync->{dry} = $dry ;
-my $dry_message = q{} ;
+$sync->{dry_message} = q{} ;
if( $sync->{dry} ) {
- $dry_message = "\t(not really since --dry mode)" ;
+ $sync->{dry_message} = "\t(not really since --dry mode)" ;
}
-$sync->{dry_message} = $dry_message ;
$search1 ||= $search if ( $search ) ;
@@ -1305,95 +1303,97 @@ $search2 ||= $search if ( $search ) ;
if ( $disarmreadreceipts ) {
- push @regexmess, q{s{\A((?:[^\n]+\r\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims} ;
+ 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 ;
if ( @pipemess and $pipemesscheck ) {
- myprint( 'Checking each --pipemess command, '
- . join( q{, }, @pipemess )
+ myprint( 'Checking each --pipemess command, '
+ . join( q{, }, @pipemess )
. ", with an space string. ( Can avoid this check with --nopipemesscheck )\n" ) ;
- my $string = pipemess( q{ }, @pipemess ) ;
+ my $string = pipemess( q{ }, @pipemess ) ;
# string undef means something was bad.
if ( not ( defined $string ) ) {
- die_clean( "Error: one of --pipemess command is bad, check it\n" ) ;
+ die_clean( "Error: one of --pipemess command is bad, check it\n" ) ;
}
- myprint( "Ok with each --pipemess @pipemess\n" ) ;
+ myprint( "Ok with each --pipemess @pipemess\n" ) ;
}
if ( $maxlinelengthcmd ) {
- myprint( "Checking --maxlinelengthcmd command, $maxlinelengthcmd, with an space string.\n" ) ;
- my $string = pipemess( q{ }, $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 ) ) {
- die_clean( "Error: --maxlinelengthcmd command is bad, check it\n" ) ;
+ die_clean( "Error: --maxlinelengthcmd command is bad, check it\n" ) ;
}
- myprint( "Ok with --maxlinelengthcmd $maxlinelengthcmd\n" ) ;
+ myprint( "Ok with --maxlinelengthcmd $maxlinelengthcmd\n" ) ;
}
if ( @regexmess ) {
- my $string = regexmess( q{ } ) ;
- myprint( "Checking each --regexmess command with an space string.\n" ) ;
+ 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 ) ) {
- die_clean( 'Error: one of --regexmess option is bad, check it' ) ;
+ die_clean( 'Error: one of --regexmess option is bad, check it' ) ;
}
- myprint( "Ok with each --regexmess\n" ) ;
+ myprint( "Ok with each --regexmess\n" ) ;
}
if ( @skipmess ) {
- myprint( "Checking each --skipmess command with an space string.\n" ) ;
- my $match = skipmess( q{ } ) ;
+ 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 ) ) {
- die_clean( 'Error: one of --skipmess option is bad, check it' ) ;
+ die_clean( 'Error: one of --skipmess option is bad, check it' ) ;
}
- myprint( "Ok with each --skipmess\n" ) ;
+ myprint( "Ok with each --skipmess\n" ) ;
}
if ( @regexflag ) {
- myprint( "Checking each --regexflag command with an space string.\n" ) ;
- my $string = flags_regex( q{ } ) ;
- # string undef means one of the eval regex was bad.
- if ( not ( defined $string ) ) {
- die_clean( 'Error: one of --regexflag option is bad, check it' ) ;
- }
- myprint( "Ok with each --regexflag\n" ) ;
+ myprint( "Checking each --regexflag command with an space string.\n" ) ;
+ my $string = flags_regex( q{ } ) ;
+ # string undef means one of the eval regex was bad.
+ if ( not ( defined $string ) ) {
+ die_clean( 'Error: one of --regexflag option is bad, check it' ) ;
+ }
+ myprint( "Ok with each --regexflag\n" ) ;
}
-$sync->{imap1} = my $imap1 = login_imap($host1, $port1, $user1, $domain1, $password1,
- $debugimap1, $sync->{h1}->{timeout}, $fastio1, $ssl1, $tls1,
- $authmech1, $authuser1, $reconnectretry1,
- $proxyauth1, $uid1, $split1, 'Host1', $sync->{h1} ) ;
+$sync->{imap1} = my $imap1 = login_imap( $sync->{host1}, $sync->{port1}, $sync->{user1}, $domain1, $sync->{password1},
+ $debugimap1, $sync->{h1}->{timeout}, $fastio1, $sync->{ssl1}, $sync->{tls1},
+ $authmech1, $authuser1, $reconnectretry1,
+ $proxyauth1, $uid1, $split1, 'Host1', $sync->{h1}, $sync ) ;
-$sync->{imap2} = my $imap2 = login_imap($host2, $port2, $user2, $domain2, $password2,
- $debugimap2, $sync->{h2}->{timeout}, $fastio2, $ssl2, $tls2,
- $authmech2, $authuser2, $reconnectretry2,
- $proxyauth2, $uid2, $split2, 'Host2', $sync->{h2} ) ;
+$sync->{imap2} = my $imap2 = login_imap( $sync->{host2}, $sync->{port2}, $sync->{user2}, $domain2, $sync->{password2},
+ $debugimap2, $sync->{h2}->{timeout}, $fastio2, $sync->{ssl2}, $sync->{tls2},
+ $authmech2, $authuser2, $reconnectretry2,
+ $proxyauth2, $uid2, $split2, 'Host2', $sync->{h2}, $sync ) ;
$debug and myprint( 'Host1 Buffer I/O: ', $imap1->Buffer(), "\n" ) ;
$debug and myprint( 'Host2 Buffer I/O: ', $imap2->Buffer(), "\n" ) ;
-die_clean( 'Not authenticated on host1' ) unless $imap1->IsAuthenticated( ) ;
+if ( ! $imap1->IsAuthenticated( ) ) { die_clean( 'Not authenticated on host1' ) ; }
myprint( "Host1: state Authenticated\n" ) ;
-die_clean( 'Not authenticated on host2' ) unless $imap2->IsAuthenticated( ) ;
+if ( ! $imap2->IsAuthenticated( ) ) { die_clean( 'Not authenticated on host2' ) ; }
myprint( "Host2: state Authenticated\n" ) ;
-myprint( 'Host1 capability: ', join(q{ }, @{ $imap1->capability_update() || [] }), "\n" ) ;
-myprint( 'Host2 capability: ', join(q{ }, @{ $imap2->capability_update() || [] }), "\n" ) ;
+myprint( 'Host1 capability once authenticated: ', join(q{ }, @{ $imap1->capability() || [] }), "\n" ) ;
+myprint( 'Host2 capability once authenticated: ', join(q{ }, @{ $imap2->capability() || [] }), "\n" ) ;
+# ID on by default since 1.832
+$sync->{id} = defined $sync->{id} ? $sync->{id} : 1 ;
imap_id_stuff( $sync ) ;
-#quota( $imap1, 'host1' ) ; # quota on host1 is useless and pollute host2 output.
-quota( $imap2, 'host2', $sync ) ;
+#quota( $imap1, 'h1', $sync ) ; # quota on host1 is useless and pollute host2 output.
+quota( $imap2, 'h2', $sync ) ;
if ( $justlogin ) {
- $imap1->logout( ) ;
- $imap2->logout( ) ;
- exit_clean( $sync, $EX_OK ) ;
+ $imap1->logout( ) ;
+ $imap2->logout( ) ;
+ exit_clean( $sync, $EX_OK ) ;
}
@@ -1410,7 +1410,7 @@ my (
%h2_folders_from_1_all ,
) ;
-my $h1_folders_wanted_nb = 0 ;
+my $h1_folders_wanted_nb = 0 ;
my $h1_folders_wanted_ct = 0 ; # counter of folders done.
# All folders on host1 and host2
@@ -1421,11 +1421,13 @@ my $h1_folders_wanted_ct = 0 ; # counter of folders done.
myprint( 'Host1: found ', scalar @h1_folders_all , " folders.\n" ) ;
myprint( 'Host2: found ', scalar @h2_folders_all , " folders.\n" ) ;
-for ( @h1_folders_all ) { $h1_folders_all{ $_ } = 1 } ;
-for ( @h2_folders_all ) {
- $h2_folders_all{ $_ } = 1 ;
- $h2_folders_all_UPPER{ uc $_ } = 1 ;
-} ;
+foreach my $f ( @h1_folders_all ) {
+ $h1_folders_all{ $f } = 1
+}
+foreach my $f ( @h2_folders_all ) {
+ $h2_folders_all{ $f } = 1 ;
+ $h2_folders_all_UPPER{ uc $f } = 1 ;
+}
$sync->{h1_folders_all} = \%h1_folders_all ;
$sync->{h2_folders_all} = \%h2_folders_all ;
@@ -1438,59 +1440,59 @@ for ( $imap2->subscribed( ) ) { $h2_subscribed_folder{ $_ } = 1 } ;
if ( defined $subfolder2 ) {
- unshift @regextrans2,
- q's,^${h2_prefix}(.*),${h2_prefix}${subfolder2}${h2_sep}$1,',
- q's,^INBOX$,${h2_prefix}${subfolder2}${h2_sep}INBOX,' ;
+ unshift @regextrans2,
+ q(s,^${h2_prefix}(.*),${h2_prefix}${subfolder2}${h2_sep}$1,),
+ q(s,^INBOX$,${h2_prefix}${subfolder2}${h2_sep}INBOX,) ;
}
if ( $fixInboxINBOX and ( my $reg = fix_Inbox_INBOX_mapping( \%h1_folders_all, \%h2_folders_all ) ) ) {
- push @regextrans2, $reg ;
+ push @regextrans2, $reg ;
}
if (scalar @folder or $subscribed or scalar @folderrec) {
- # folders given by option --folder
- if (scalar @folder) {
- add_to_requested_folders(@folder);
- }
+ # folders given by option --folder
+ if (scalar @folder) {
+ add_to_requested_folders(@folder);
+ }
- # option --subscribed
- if ( $subscribed ) {
- add_to_requested_folders( keys %h1_subscribed_folder ) ;
- }
+ # option --subscribed
+ if ( $subscribed ) {
+ add_to_requested_folders( keys %h1_subscribed_folder ) ;
+ }
- # option --folderrec
- if (scalar @folderrec) {
- foreach my $folderrec (@folderrec) {
- add_to_requested_folders($imap1->folders($folderrec));
- }
- }
+ # option --folderrec
+ if (scalar @folderrec) {
+ foreach my $folderrec (@folderrec) {
+ add_to_requested_folders($imap1->folders($folderrec));
+ }
+ }
}
else {
- # no include, no folder/subscribed/folderrec options => all folders
- if (not scalar @include) {
- 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);
- }
+ # no include, no folder/subscribed/folderrec options => all folders
+ 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);
+ }
}
# consider (optional) includes and excludes
if ( scalar @include ) {
- foreach my $include ( @include ) {
- my @included_folders = grep { /$include/ } @h1_folders_all ;
- add_to_requested_folders( @included_folders ) ;
- myprint( "Including folders matching pattern $include\n" . jux_utf8_list( @included_folders ) . "\n" ) ;
- }
+ foreach my $include ( @include ) {
+ my @included_folders = grep { /$include/ } @h1_folders_all ;
+ add_to_requested_folders( @included_folders ) ;
+ myprint( "Including folders matching pattern $include\n" . jux_utf8_list( @included_folders ) . "\n" ) ;
+ }
}
if ( scalar @exclude ) {
- foreach my $exclude ( @exclude ) {
- my @requested_folder = sort keys %requested_folder ;
- my @excluded_folders = grep { /$exclude/ } @requested_folder ;
- remove_from_requested_folders( @excluded_folders ) ;
- myprint( "Excluding folders matching pattern $exclude\n" . jux_utf8_list( @excluded_folders ) . "\n" ) ;
- }
+ foreach my $exclude ( @exclude ) {
+ my @requested_folder = sort keys %requested_folder ;
+ my @excluded_folders = grep { /$exclude/ } @requested_folder ;
+ remove_from_requested_folders( @excluded_folders ) ;
+ myprint( "Excluding folders matching pattern $exclude\n" . jux_utf8_list( @excluded_folders ) . "\n" ) ;
+ }
}
@@ -1504,13 +1506,13 @@ if ( scalar @exclude ) {
my @h1_folders_wanted_exist ;
myprint( "Host1: checking all wanted folders exist.\n" ) ;
foreach my $folder ( @h1_folders_wanted ) {
- ( $debug or $sync->{debugfolders} ) and myprint( "Checking $folder exists on host1\n" ) ;
- if ( ! exists $h1_folders_all{ $folder } ) {
+ ( $debug or $sync->{debugfolders} ) and myprint( "Checking $folder exists on host1\n" ) ;
+ if ( ! exists $h1_folders_all{ $folder } ) {
myprint( "Host1: warning! ignoring folder $folder because it is not in host1 whole folders list.\n" ) ;
- next ;
- }else{
- push @h1_folders_wanted_exist, $folder ;
- }
+ next ;
+ }else{
+ push @h1_folders_wanted_exist, $folder ;
+ }
}
@h1_folders_wanted = @h1_folders_wanted_exist ;
@@ -1518,17 +1520,17 @@ foreach my $folder ( @h1_folders_wanted ) {
$checkselectable and do {
- my @h1_folders_wanted_selectable ;
+ my @h1_folders_wanted_selectable ;
myprint( "Host1: checking all wanted folders are selectable. Use --nocheckselectable to avoid this check.\n" ) ;
- foreach my $folder ( @h1_folders_wanted ) {
- ( $debug or $sync->{debugfolders} ) and myprint( "Checking $folder is selectable on host1\n" ) ;
- if ( ! $imap1->selectable( $folder ) ) {
+ foreach my $folder ( @h1_folders_wanted ) {
+ ( $debug or $sync->{debugfolders} ) and myprint( "Checking $folder is selectable on host1\n" ) ;
+ if ( ! $imap1->selectable( $folder ) ) {
myprint( "Host1: warning! ignoring folder $folder because it is not selectable\n" ) ;
- }else{
- push @h1_folders_wanted_selectable, $folder ;
- }
- }
- @h1_folders_wanted = @h1_folders_wanted_selectable ;
+ }else{
+ push @h1_folders_wanted_selectable, $folder ;
+ }
+ }
+ @h1_folders_wanted = @h1_folders_wanted_selectable ;
( $debug or $sync->{debugfolders} ) and myprint( 'Host1: checking folders took ', timenext( ), " s\n" ) ;
} ;
@@ -1554,19 +1556,19 @@ automap( $sync ) ;
foreach my $h1_fold ( @h1_folders_wanted ) {
- my $h2_fold ;
- $h2_fold = imap2_folder_name( $h1_fold ) ;
- $h2_folders_from_1_wanted{ $h2_fold }++ ;
+ my $h2_fold ;
+ $h2_fold = imap2_folder_name( $h1_fold ) ;
+ $h2_folders_from_1_wanted{ $h2_fold }++ ;
if ( 1 < $h2_folders_from_1_wanted{ $h2_fold } ) {
- $h2_folders_from_1_several{ $h2_fold }++ ;
+ $h2_folders_from_1_several{ $h2_fold }++ ;
}
}
@h2_folders_from_1_wanted = sort keys %h2_folders_from_1_wanted;
foreach my $h1_fold ( @h1_folders_all ) {
- my $h2_fold ;
- $h2_fold = imap2_folder_name( $h1_fold ) ;
- $h2_folders_from_1_all{ $h2_fold }++ ;
+ my $h2_fold ;
+ $h2_fold = imap2_folder_name( $h1_fold ) ;
+ $h2_folders_from_1_all{ $h2_fold }++ ;
}
@@ -1583,12 +1585,17 @@ Y is the uft8 output just printed for convenience, to recognize it.
END_LISTING
print
- "Host1 folders list:\n",
+ "Host1 folders list (first the raw imap format then the [X] = [Y]):\n",
+ $imap1->list( ),
+ "\n",
jux_utf8_list( @h1_folders_all ),
"\n",
- "Host2 folders list:\n",
+ "Host2 folders list (first the raw imap format then the [X] = [Y]):\n",
+ $imap2->list( ),
+ "\n",
jux_utf8_list( @h2_folders_all ),
- "\n" ;
+ "\n",
+ q{} ;
print
'Host1 subscribed folders list: ',
@@ -1599,31 +1606,31 @@ my @h2_folders_not_in_1;
@h2_folders_not_in_1 = list_folders_in_2_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" ) ;
+ myprint( "Folders in host2 not in host1:\n",
+ jux_utf8_list( @h2_folders_not_in_1 ), "\n" ) ;
}
-if ( defined $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} ;
- myprintf( "%-40s -> %-40s\n",
- jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ;
+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} ;
+ myprintf( "%-40s -> %-40s\n",
+ jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ;
}
myprint( "\n" ) ;
}
-if ( defined $sync->{f1f2} ) {
- myprint( "Folders mapping from --f1f2 options, it overrides --automap:\n" ) ;
- foreach my $h1_fold ( keys %{$sync->{f1f2}} ) {
- my $h2_fold = $sync->{f1f2}{$h1_fold} ;
+if ( keys %{ $sync->{f1f2} } ) {
+ myprint( "Folders mapping from --f1f2 options, it overrides --automap:\n" ) ;
+ foreach my $h1_fold ( keys %{ $sync->{f1f2} } ) {
+ my $h2_fold = $sync->{f1f2}{$h1_fold} ;
my $warn = q{} ;
if ( not exists $h1_folders_all{ $h1_fold } ) {
$warn = "BUT $h1_fold does NOT exist on host1!" ;
}
- myprintf( "%-40s -> %-40s %s\n",
- jux_utf8( $h1_fold ), jux_utf8( $h2_fold ), $warn ) ;
+ myprintf( "%-40s -> %-40s %s\n",
+ jux_utf8( $h1_fold ), jux_utf8( $h2_fold ), $warn ) ;
}
myprint( "\n" ) ;
}
@@ -1653,7 +1660,7 @@ $h1_folders_wanted_nb = scalar @h1_folders_wanted ;
myprint( "++++ Looping on each one of $h1_folders_wanted_nb folders to sync\n" ) ;
-my $begin_transfer_time = time ;
+$sync->{begin_transfer_time} = time ;
my %uid_candidate_for_deletion ;
my %uid_candidate_no_deletion ;
@@ -1662,234 +1669,235 @@ my %h2_folders_of_md5 = ( ) ;
FOLDER: foreach my $h1_fold ( @h1_folders_wanted ) {
- last FOLDER if $imap1->IsUnconnected( ) ;
- last FOLDER if $imap2->IsUnconnected( ) ;
+ if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
- my $h2_fold = imap2_folder_name( $h1_fold ) ;
+ my $h2_fold = imap2_folder_name( $h1_fold ) ;
- $h1_folders_wanted_ct++ ;
- myprintf( "Folder %7s %-35s -> %-35s\n", "$h1_folders_wanted_ct/$h1_folders_wanted_nb",
- jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ;
+ $h1_folders_wanted_ct++ ;
+ myprintf( "Folder %7s %-35s -> %-35s\n", "$h1_folders_wanted_ct/$h1_folders_wanted_nb",
+ jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ;
if ( $sync->{debugmemory} ) {
myprintf("FL: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
}
- # host1 can not be fetched read only, select is needed because of expunge.
- select_folder( $imap1, $h1_fold, 'Host1' ) or next FOLDER ;
+ # host1 can not be fetched read only, select is needed because of expunge.
+ select_folder( $imap1, $h1_fold, 'Host1' ) or next FOLDER ;
debugsleep( $sync ) ;
- my $h1_fold_nb_messages = count_from_select( $imap1->History ) ;
+ my $h1_fold_nb_messages = count_from_select( $imap1->History ) ;
myprint( "Host1 folder [$h1_fold] has $h1_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ;
if ( $skipemptyfolders and 0 == $h1_fold_nb_messages ) {
- myprint( "Skipping empty host1 folder [$h1_fold]\n" ) ;
+ myprint( "Skipping empty host1 folder [$h1_fold]\n" ) ;
next FOLDER ;
}
- if ( ! exists $h2_folders_all{ $h2_fold } ) {
- create_folder( $imap2, $h2_fold, $h1_fold ) or next FOLDER ;
- }
+ if ( ! exists $h2_folders_all{ $h2_fold } ) {
+ create_folder( $imap2, $h2_fold, $h1_fold ) or next FOLDER ;
+ }
- acls_sync( $h1_fold, $h2_fold ) ;
+ acls_sync( $h1_fold, $h2_fold ) ;
# Sometimes the folder on host2 is listed (it exists) but is
# not selectable but becomes selectable by a create (Gmail)
- select_folder( $imap2, $h2_fold, 'Host2' )
+ select_folder( $imap2, $h2_fold, 'Host2' )
or ( create_folder( $imap2, $h2_fold, $h1_fold )
and select_folder( $imap2, $h2_fold, 'Host2' ) )
or next FOLDER ;
- my @select_results = $imap2->Results( ) ;
+ my @select_results = $imap2->Results( ) ;
- my $h2_fold_nb_messages = count_from_select( @select_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( @select_results ) ;
- ( $debug or $debugflags ) and myprint( "Host2 folder [$h2_fold] permanentflags: $permanentflags2\n" ) ;
+ my $permanentflags2 = permanentflags( @select_results ) ;
+ myprint( "Host2 folder [$h2_fold] permanentflags: $permanentflags2\n" ) ;
- if ( $expunge or $expunge1 ){
- myprint( "Host1: Expunging $h1_fold $dry_message\n" ) ;
- unless( $dry ) { $imap1->expunge( ) } ;
- }
+ if ( $expunge1 ){
+ myprint( "Host1: Expunging $h1_fold $sync->{dry_message}\n" ) ;
+ if ( ! $sync->{dry} ) { $imap1->expunge( ) } ;
+ }
- if ( ( ( $subscribe and exists $h1_subscribed_folder{ $h1_fold } ) or $subscribeall )
+ if ( ( ( $subscribe and exists $h1_subscribed_folder{ $h1_fold } ) or $subscribeall )
and not exists $h2_subscribed_folder{ $h2_fold } ) {
- myprint( "Host2: Subscribing to folder $h2_fold\n" ) ;
- unless( $dry ) { $imap2->subscribe( $h2_fold ) } ;
- }
+ myprint( "Host2: Subscribing to folder $h2_fold\n" ) ;
+ if ( ! $sync->{dry} ) { $imap2->subscribe( $h2_fold ) } ;
+ }
- next FOLDER if ( $justfolders ) ;
+ next FOLDER if ( $justfolders ) ;
- last FOLDER if $imap1->IsUnconnected( ) ;
- last FOLDER if $imap2->IsUnconnected( ) ;
+ if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
my $h1_msgs_all_hash_ref = { } ;
- my @h1_msgs = select_msgs( $imap1, $h1_msgs_all_hash_ref, $search1, $h1_fold );
- last FOLDER if $imap1->IsUnconnected( ) ;
+ my @h1_msgs = select_msgs( $imap1, $h1_msgs_all_hash_ref, $search1, $sync->{abletosearch1}, $h1_fold );
+
+ if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
my $h1_msgs_nb = scalar @h1_msgs ;
$h1{ $h1_fold }{ 'messages_nb' } = $h1_msgs_nb ;
- myprint( "Host1 folder [$h1_fold] considering $h1_msgs_nb messages\n" ) ;
- ( $debug or $debuglist ) and myprint( "Host1 folder [$h1_fold] considering $h1_msgs_nb messages, LIST gives: @h1_msgs\n" ) ;
+ myprint( "Host1 folder [$h1_fold] considering $h1_msgs_nb messages\n" ) ;
+ ( $debug or $debuglist ) and myprint( "Host1 folder [$h1_fold] considering $h1_msgs_nb messages, LIST gives: @h1_msgs\n" ) ;
$debug and myprint( "Host1 selecting messages of folder [$h1_fold] took ", timenext(), " s\n" ) ;
my $h2_msgs_all_hash_ref = { } ;
- my @h2_msgs = select_msgs( $imap2, $h2_msgs_all_hash_ref, $search2, $h2_fold ) ;
- last FOLDER if $imap2->IsUnconnected( ) ;
+ my @h2_msgs = select_msgs( $imap2, $h2_msgs_all_hash_ref, $search2, $sync->{abletosearch2}, $h2_fold ) ;
+
+ if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
my $h2_msgs_nb = scalar @h2_msgs ;
$h2{ $h2_fold }{ 'messages_nb' } = $h2_msgs_nb ;
- myprint( "Host2 folder [$h2_fold] considering $h2_msgs_nb messages\n" ) ;
- ( $debug or $debuglist ) and myprint( "Host2 folder [$h2_fold] considering $h2_msgs_nb messages, LIST gives: @h2_msgs\n" ) ;
+ myprint( "Host2 folder [$h2_fold] considering $h2_msgs_nb messages\n" ) ;
+ ( $debug or $debuglist ) and myprint( "Host2 folder [$h2_fold] considering $h2_msgs_nb messages, LIST gives: @h2_msgs\n" ) ;
$debug and myprint( "Host2 selecting messages of folder [$h2_fold] took ", timenext(), " s\n" ) ;
- my $cache_base = "$tmpdir/imapsync_cache/" ;
- my $cache_dir = cache_folder( $cache_base, "$host1/$user1/$host2/$user2", $h1_fold, $h2_fold ) ;
- my ( $cache_1_2_ref, $cache_2_1_ref ) = ( {}, {} ) ;
+ my $cache_base = "$tmpdir/imapsync_cache/" ;
+ my $cache_dir = cache_folder( $cache_base, "$sync->{host1}/$sync->{user1}/$sync->{host2}/$sync->{user2}", $h1_fold, $h2_fold ) ;
+ my ( $cache_1_2_ref, $cache_2_1_ref ) = ( {}, {} ) ;
- my $h1_uidvalidity = $imap1->uidvalidity( ) || q{} ;
- my $h2_uidvalidity = $imap2->uidvalidity( ) || q{} ;
+ my $h1_uidvalidity = $imap1->uidvalidity( ) || q{} ;
+ my $h2_uidvalidity = $imap2->uidvalidity( ) || q{} ;
- last FOLDER if $imap1->IsUnconnected( ) ;
- last FOLDER if $imap2->IsUnconnected( ) ;
+ if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
- if ( $usecache ) {
- myprint( "cache directory: $cache_dir\n" ) ;
- mkpath( "$cache_dir" ) ;
- ( $cache_1_2_ref, $cache_2_1_ref )
+ if ( $usecache ) {
+ myprint( "cache directory: $cache_dir\n" ) ;
+ mkpath( "$cache_dir" ) ;
+ ( $cache_1_2_ref, $cache_2_1_ref )
= get_cache( $cache_dir, \@h1_msgs, \@h2_msgs, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ;
- myprint( 'CACHE h1 h2: ', scalar keys %{ $cache_1_2_ref } , " files\n" ) ;
- $debug and myprint( '[',
- map ( { "$_->$cache_1_2_ref->{$_} " } keys %{ $cache_1_2_ref } ), " ]\n" ) ;
- }
+ myprint( 'CACHE h1 h2: ', scalar keys %{ $cache_1_2_ref } , " files\n" ) ;
+ $debug and myprint( '[',
+ map ( { "$_->$cache_1_2_ref->{$_} " } keys %{ $cache_1_2_ref } ), " ]\n" ) ;
+ }
- my %h1_hash = () ;
- my %h2_hash = () ;
+ my %h1_hash = () ;
+ my %h2_hash = () ;
- my ( %h1_msgs, %h2_msgs ) ;
- @h1_msgs{ @h1_msgs } = ();
- @h2_msgs{ @h2_msgs } = ();
+ my ( %h1_msgs, %h2_msgs ) ;
+ @h1_msgs{ @h1_msgs } = ();
+ @h2_msgs{ @h2_msgs } = ();
- my @h1_msgs_in_cache = sort { $a <=> $b } keys %{ $cache_1_2_ref } ;
- my @h2_msgs_in_cache = keys %{ $cache_2_1_ref } ;
+ my @h1_msgs_in_cache = sort { $a <=> $b } keys %{ $cache_1_2_ref } ;
+ my @h2_msgs_in_cache = keys %{ $cache_2_1_ref } ;
- my ( %h1_msgs_not_in_cache, %h2_msgs_not_in_cache ) ;
- %h1_msgs_not_in_cache = %h1_msgs ;
- %h2_msgs_not_in_cache = %h2_msgs ;
- delete @h1_msgs_not_in_cache{ @h1_msgs_in_cache } ;
- delete @h2_msgs_not_in_cache{ @h2_msgs_in_cache } ;
+ my ( %h1_msgs_not_in_cache, %h2_msgs_not_in_cache ) ;
+ %h1_msgs_not_in_cache = %h1_msgs ;
+ %h2_msgs_not_in_cache = %h2_msgs ;
+ delete @h1_msgs_not_in_cache{ @h1_msgs_in_cache } ;
+ delete @h2_msgs_not_in_cache{ @h2_msgs_in_cache } ;
- my @h1_msgs_not_in_cache = keys %h1_msgs_not_in_cache ;
- #myprint( "h1_msgs_not_in_cache: [@h1_msgs_not_in_cache]\n" ) ;
- my @h2_msgs_not_in_cache = keys %h2_msgs_not_in_cache ;
+ my @h1_msgs_not_in_cache = keys %h1_msgs_not_in_cache ;
+ #myprint( "h1_msgs_not_in_cache: [@h1_msgs_not_in_cache]\n" ) ;
+ my @h2_msgs_not_in_cache = keys %h2_msgs_not_in_cache ;
- my @h2_msgs_delete2_not_in_cache = () ;
- %h1_msgs_copy_by_uid = ( ) ;
+ my @h2_msgs_delete2_not_in_cache = () ;
+ %h1_msgs_copy_by_uid = ( ) ;
- if ( $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 ;
- @h1_msgs_not_in_cache = ( ) ;
- @h2_msgs_not_in_cache = ( ) ;
+ if ( $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 ;
+ @h1_msgs_not_in_cache = ( ) ;
+ @h2_msgs_not_in_cache = ( ) ;
- #myprint( "delete2: @h2_msgs_delete2_not_in_cache\n" ) ;
- }
+ #myprint( "delete2: @h2_msgs_delete2_not_in_cache\n" ) ;
+ }
- $debug and myprint( "Host1 parsing headers of folder [$h1_fold]\n" ) ;
+ $debug and myprint( "Host1 parsing headers of folder [$h1_fold]\n" ) ;
- my ($h1_heads_ref, $h1_fir_ref) = ({}, {});
- $h1_heads_ref = $imap1->parse_headers([@h1_msgs_not_in_cache], @useheader) if (@h1_msgs_not_in_cache);
- $debug and myprint( "Host1 parsing headers of folder [$h1_fold] took ", timenext(), " s\n" ) ;
+ my ($h1_heads_ref, $h1_fir_ref) = ({}, {});
+ $h1_heads_ref = $imap1->parse_headers([@h1_msgs_not_in_cache], @useheader) if (@h1_msgs_not_in_cache);
+ $debug and myprint( "Host1 parsing headers of folder [$h1_fold] took ", timenext(), " s\n" ) ;
- @{ $h1_fir_ref }{@h1_msgs} = ( undef ) ;
+ @{ $h1_fir_ref }{@h1_msgs} = ( undef ) ;
- $debug and myprint( "Host1 getting flags idate and sizes of folder [$h1_fold]\n" ) ;
- if ( $abletosearch ) {
- $h1_fir_ref = $imap1->fetch_hash( \@h1_msgs, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h1_fir_ref )
- if ( @h1_msgs ) ;
+ $debug and myprint( "Host1 getting flags idate and sizes of folder [$h1_fold]\n" ) ;
+ if ( $sync->{abletosearch1} ) {
+ $h1_fir_ref = $imap1->fetch_hash( \@h1_msgs, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h1_fir_ref )
+ if ( @h1_msgs ) ;
}else{
- my $uidnext = $imap1->uidnext( $h1_fold ) || $uidnext_default ;
- my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
- $h1_fir_ref = $imap1->fetch_hash( $fetch_hash_uids, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h1_fir_ref )
- if ( @h1_msgs ) ;
- }
- $debug and myprint( "Host1 getting flags idate and sizes of folder [$h1_fold] took ", timenext(), " s\n" ) ;
- unless ($h1_fir_ref) {
- my $error = join( q{}, "Host1 folder $h1_fold: Could not fetch_hash ",
- scalar @h1_msgs, ' msgs: ', $imap1->LastError || q{}, "\n" ) ;
- errors_incr( $sync, $error ) ;
- next FOLDER ;
- }
+ my $uidnext = $imap1->uidnext( $h1_fold ) || $uidnext_default ;
+ my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
+ $h1_fir_ref = $imap1->fetch_hash( $fetch_hash_uids, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h1_fir_ref )
+ if ( @h1_msgs ) ;
+ }
+ $debug and myprint( "Host1 getting flags idate and sizes of folder [$h1_fold] took ", timenext(), " s\n" ) ;
+ if ( ! $h1_fir_ref ) {
+ my $error = join( q{}, "Host1 folder $h1_fold: Could not fetch_hash ",
+ scalar @h1_msgs, ' msgs: ', $imap1->LastError || q{}, "\n" ) ;
+ errors_incr( $sync, $error ) ;
+ next FOLDER ;
+ }
- my @h1_msgs_duplicate;
- foreach my $m (@h1_msgs_not_in_cache) {
- my $rc = parse_header_msg($imap1, $m, $h1_heads_ref, $h1_fir_ref, 'Host1', \%h1_hash);
- if (! defined $rc) {
- my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0;
- myprint( "Host1 $h1_fold/$m size $h1_size ignored (no wanted headers so we ignore this message. To solve this: use --addheader)\n" ) ;
- $total_bytes_skipped += $h1_size;
- $nb_msg_skipped += 1;
- $h1_nb_msg_noheader +=1;
+ my @h1_msgs_duplicate;
+ foreach my $m (@h1_msgs_not_in_cache) {
+ my $rc = parse_header_msg($imap1, $m, $h1_heads_ref, $h1_fir_ref, 'Host1', \%h1_hash);
+ if ( ! defined $rc ) {
+ my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0;
+ myprint( "Host1 $h1_fold/$m size $h1_size ignored (no wanted headers so we ignore this message. To solve this: use --addheader)\n" ) ;
+ $total_bytes_skipped += $h1_size;
+ $nb_msg_skipped += 1;
+ $h1_nb_msg_noheader +=1;
$h1_nb_msg_processed +=1 ;
- } elsif(0 == $rc) {
- # duplicate
- push @h1_msgs_duplicate, $m;
- # duplicate, same id same size?
- my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0;
- $nb_msg_skipped += 1;
- $h1_total_bytes_duplicate += $h1_size;
- $h1_nb_msg_duplicate += 1;
+ } elsif(0 == $rc) {
+ # duplicate
+ push @h1_msgs_duplicate, $m;
+ # duplicate, same id same size?
+ my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0;
+ $nb_msg_skipped += 1;
+ $h1_total_bytes_duplicate += $h1_size;
+ $h1_nb_msg_duplicate += 1;
$h1_nb_msg_processed +=1 ;
- }
- }
+ }
+ }
my $h1_msgs_duplicate_nb = scalar @h1_msgs_duplicate ;
$h1{ $h1_fold }{ 'duplicates_nb' } = $h1_msgs_duplicate_nb ;
$debug and myprint( "Host1 selected: $h1_msgs_nb duplicates: $h1_msgs_duplicate_nb\n" ) ;
- $debug and myprint( 'Host1 whole time parsing headers took ', timenext(), " s\n" ) ;
+ $debug and myprint( 'Host1 whole time parsing headers took ', timenext(), " s\n" ) ;
+ # Getting headers and metada can be so long that host2 might be disconnected here
+ if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
- $debug and myprint( "Host2 parsing headers of folder [$h2_fold]\n" ) ;
- my ($h2_heads_ref, $h2_fir_ref) = ( {}, {} );
- $h2_heads_ref = $imap2->parse_headers([@h2_msgs_not_in_cache], @useheader) if (@h2_msgs_not_in_cache);
- $debug and myprint( "Host2 parsing headers of folder [$h2_fold] took ", timenext(), " s\n" ) ;
+ $debug and myprint( "Host2 parsing headers of folder [$h2_fold]\n" ) ;
- $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
+ my ($h2_heads_ref, $h2_fir_ref) = ( {}, {} );
+ $h2_heads_ref = $imap2->parse_headers([@h2_msgs_not_in_cache], @useheader) if (@h2_msgs_not_in_cache);
+ $debug and myprint( "Host2 parsing headers of folder [$h2_fold] took ", timenext(), " s\n" ) ;
+ $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
- if ( $abletosearch ) {
- $h2_fir_ref = $imap2->fetch_hash( \@h2_msgs, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h2_fir_ref)
- if (@h2_msgs) ;
+
+ if ( $sync->{abletosearch2} and scalar( @h2_msgs ) ) {
+ $h2_fir_ref = $imap2->fetch_hash( \@h2_msgs, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h2_fir_ref) ;
}else{
- my $uidnext = $imap2->uidnext( $h2_fold ) || $uidnext_default ;
- my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
- $h2_fir_ref = $imap2->fetch_hash( $fetch_hash_uids, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h2_fir_ref )
- if ( @h2_msgs ) ;
+ my $uidnext = $imap2->uidnext( $h2_fold ) || $uidnext_default ;
+ my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
+ $h2_fir_ref = $imap2->fetch_hash( $fetch_hash_uids, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h2_fir_ref )
+ if ( @h2_msgs ) ;
}
- $debug and myprint( "Host2 getting flags idate and sizes of folder [$h2_fold] took ", timenext(), " s\n" ) ;
+ $debug and myprint( "Host2 getting flags idate and sizes of folder [$h2_fold] took ", timenext(), " s\n" ) ;
- my @h2_msgs_duplicate;
- foreach my $m (@h2_msgs_not_in_cache) {
- my $rc = parse_header_msg($imap2, $m, $h2_heads_ref, $h2_fir_ref, 'Host2', \%h2_hash) ;
- my $h2_size = $h2_fir_ref->{$m}->{'RFC822.SIZE'} || 0 ;
- if (! defined $rc ) {
+ my @h2_msgs_duplicate;
+ foreach my $m (@h2_msgs_not_in_cache) {
+ my $rc = parse_header_msg($imap2, $m, $h2_heads_ref, $h2_fir_ref, 'Host2', \%h2_hash) ;
+ my $h2_size = $h2_fir_ref->{$m}->{'RFC822.SIZE'} || 0 ;
+ if (! defined $rc ) {
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 ) {
- # duplicate
- $h2_nb_msg_duplicate += 1 ;
- $h2_total_bytes_duplicate += $h2_size ;
- push @h2_msgs_duplicate, $m ;
- }
- }
+ $h2_nb_msg_noheader += 1 ;
+ } elsif( 0 == $rc ) {
+ # duplicate
+ $h2_nb_msg_duplicate += 1 ;
+ $h2_total_bytes_duplicate += $h2_size ;
+ push @h2_msgs_duplicate, $m ;
+ }
+ }
# %h2_folders_of_md5
foreach my $md5 ( keys %h2_hash ) {
- $h2_folders_of_md5{ $md5 }->{ $h2_fold } ++ ;
+ $h2_folders_of_md5{ $md5 }->{ $h2_fold } ++ ;
}
@@ -1897,271 +1905,272 @@ FOLDER: foreach my $h1_fold ( @h1_folders_wanted ) {
$h2{ $h2_fold }{ 'duplicates_nb' } = $h2_msgs_duplicate_nb ;
myprint( "Host2 folder $h2_fold selected: $h2_msgs_nb messages, duplicates: $h2_msgs_duplicate_nb\n" )
- if ( $debug or $delete2duplicates or $h2_msgs_duplicate_nb ) ;
- $debug and myprint( 'Host2 whole time parsing headers took ', timenext( ), " s\n" ) ;
+ if ( $debug or $delete2duplicates or $h2_msgs_duplicate_nb ) ;
+ $debug and myprint( 'Host2 whole time parsing headers took ', timenext( ), " s\n" ) ;
- $debug and myprint( "++++ Verifying [$h1_fold] -> [$h2_fold]\n" ) ;
- # messages in host1 that are not in host2
+ $debug and myprint( "++++ Verifying [$h1_fold] -> [$h2_fold]\n" ) ;
+ # messages in host1 that are not in host2
- my @h1_hash_keys_sorted_by_uid
- = sort {$h1_hash{$a}{'m'} <=> $h1_hash{$b}{'m'}} keys %h1_hash;
+ my @h1_hash_keys_sorted_by_uid
+ = sort {$h1_hash{$a}{'m'} <=> $h1_hash{$b}{'m'}} keys %h1_hash;
- #myprint( map { $h1_hash{$_}{'m'} . q{ }} @h1_hash_keys_sorted_by_uid ) ;
+ #myprint( map { $h1_hash{$_}{'m'} . q{ }} @h1_hash_keys_sorted_by_uid ) ;
- my @h2_hash_keys_sorted_by_uid
- = sort {$h2_hash{$a}{'m'} <=> $h2_hash{$b}{'m'}} keys %h2_hash;
+ my @h2_hash_keys_sorted_by_uid
+ = sort {$h2_hash{$a}{'m'} <=> $h2_hash{$b}{'m'}} keys %h2_hash;
- if( $delete2duplicates and not exists $h2_folders_from_1_several{ $h2_fold } ) {
- my @h2_expunge ;
+ if( $delete2duplicates and not exists $h2_folders_from_1_several{ $h2_fold } ) {
+ my @h2_expunge ;
- foreach my $h2_msg ( @h2_msgs_duplicate ) {
- myprint( "msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2 $dry_message\n" ) ;
- push @h2_expunge, $h2_msg if $uidexpunge2 ;
- unless ( $dry ) {
- $imap2->delete_message( $h2_msg ) ;
- $h2_nb_msg_deleted += 1 ;
- }
- }
- my $cnt = scalar @h2_expunge ;
- if( @h2_expunge and not $expunge2 ) {
- myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $dry_message\n" ) ;
- $imap2->uidexpunge( \@h2_expunge ) if ! $dry ;
- }
- if ( $expunge2 ){
- myprint( "Host2: Expunging folder $h2_fold $dry_message\n" ) ;
- $imap2->expunge( ) if ! $dry ;
- }
- }
+ foreach my $h2_msg ( @h2_msgs_duplicate ) {
+ myprint( "msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2 $sync->{dry_message}\n" ) ;
+ push @h2_expunge, $h2_msg if $uidexpunge2 ;
+ if ( ! $sync->{dry} ) {
+ $imap2->delete_message( $h2_msg ) ;
+ $h2_nb_msg_deleted += 1 ;
+ }
+ }
+ my $cnt = scalar @h2_expunge ;
+ if( @h2_expunge and not $expunge2 ) {
+ myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ;
+ $imap2->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ;
+ }
+ if ( $expunge2 ){
+ myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ;
+ $imap2->expunge( ) if ! $sync->{dry} ;
+ }
+ }
- if( $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 " ) ;
- unless (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] $dry_message\n" )
- if ! $isdel;
- push @h2_expunge, $h2_msg if $uidexpunge2;
- unless ($dry or $isdel) {
- $imap2->delete_message($h2_msg);
- $h2_nb_msg_deleted += 1;
- }
- }
- }
- foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) {
- myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2 $dry_message\n" ) ;
+ if( $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} ) {
+ 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" )
+ if ! $isdel;
+ push @h2_expunge, $h2_msg if $uidexpunge2;
+ if ( ! ( $sync->{dry} or $isdel ) ) {
+ $imap2->delete_message($h2_msg);
+ $h2_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" ) ;
push @h2_expunge, $h2_msg if $uidexpunge2;
- unless ($dry) {
- $imap2->delete_message($h2_msg);
- $h2_nb_msg_deleted += 1;
- }
- }
- my $cnt = scalar @h2_expunge ;
+ if ( ! $sync->{dry} ) {
+ $imap2->delete_message($h2_msg);
+ $h2_nb_msg_deleted += 1;
+ }
+ }
+ my $cnt = scalar @h2_expunge ;
- if( @h2_expunge and not $expunge2 ) {
- myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $dry_message\n" ) ;
- $imap2->uidexpunge( \@h2_expunge ) if ! $dry ;
- }
- if ( $expunge2 ) {
- myprint( "Host2: Expunging folder $h2_fold $dry_message\n" ) ;
- $imap2->expunge( ) if ! $dry ;
- }
- }
+ if( @h2_expunge and not $expunge2 ) {
+ myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ;
+ $imap2->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ;
+ }
+ if ( $expunge2 ) {
+ myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ;
+ $imap2->expunge( ) if ! $sync->{dry} ;
+ }
+ }
- if( $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' } ;
- unless ( exists $h1_hash{ $m_id } ) {
- my $h2_flags = $h2_hash{ $m_id }{ 'F' } || q{} ;
- my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0 ;
- unless ( $isdel ) {
- $debug and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [$m_id]\n" ) ;
- $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ;
- }
- }else{
- $debug and myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [$m_id]\n" ) ;
- $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
+ if( $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 } ) {
+ my $h2_flags = $h2_hash{ $m_id }{ 'F' } || q{} ;
+ my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0 ;
+ if ( ! $isdel ) {
+ $debug and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [$m_id]\n" ) ;
+ $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ;
+ }
+ }else{
+ $debug and myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [$m_id]\n" ) ;
+ $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
}
- }
- foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) {
- myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [not in cache]\n" ) ;
+ }
+ foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) {
+ myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [not in cache]\n" ) ;
$uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ;
- }
+ }
- foreach my $h2_msg ( @h2_msgs_in_cache ) {
- myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [in cache]\n" ) ;
+ foreach my $h2_msg ( @h2_msgs_in_cache ) {
+ myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [in cache]\n" ) ;
$uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
- }
+ }
if ( 0 == $h2_folders_from_1_several{ $h2_fold } ) {
- # last host1 folder going to $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 } } ) {
- $debug and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion\n" ) ;
+ $debug and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion\n" ) ;
if ( exists $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg } ) {
- $debug and myprint( "Host2: msg $h2_fold/$h2_msg canceled deletion\n" ) ;
+ $debug and myprint( "Host2: msg $h2_fold/$h2_msg canceled deletion\n" ) ;
}else{
- myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted $dry_message\n" ) ;
+ myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted $sync->{dry_message}\n" ) ;
push @h2_expunge, $h2_msg if $uidexpunge2 ;
- unless ( $dry ) {
- $imap2->delete_message( $h2_msg ) ;
- $h2_nb_msg_deleted += 1 ;
+ if ( ! $sync->{dry} ) {
+ $imap2->delete_message( $h2_msg ) ;
+ $h2_nb_msg_deleted += 1 ;
}
}
}
}
- my $cnt = scalar @h2_expunge ;
- if( @h2_expunge and not $expunge2 ) {
- myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $dry_message\n" ) ;
- $imap2->uidexpunge( \@h2_expunge ) if ! $dry ;
- }
- if ( $expunge2 ) {
- myprint( "Host2: Expunging host2 folder $h2_fold $dry_message\n" ) ;
- $imap2->expunge( ) if ! $dry ;
- }
+ my $cnt = scalar @h2_expunge ;
+ if( @h2_expunge and not $expunge2 ) {
+ myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ;
+ $imap2->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ;
+ }
+ if ( $expunge2 ) {
+ myprint( "Host2: Expunging host2 folder $h2_fold $sync->{dry_message}\n" ) ;
+ $imap2->expunge( ) if ! $sync->{dry} ;
+ }
$h2_folders_from_1_several{ $h2_fold }-- ;
- }
-
+ }
- my $h2_uidnext = $imap2->uidnext( $h2_fold ) ;
+ my $h2_uidnext = $imap2->uidnext( $h2_fold ) ;
$debug and myprint( "Host2 uidnext: $h2_uidnext\n" ) ;
- $h2_uidguess = $h2_uidnext ;
- MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) {
- last FOLDER if $imap1->IsUnconnected( ) ;
- last FOLDER if $imap2->IsUnconnected( ) ;
-
- #myprint( "h1_nb_msg_processed: $h1_nb_msg_processed\n" ) ;
- my $h1_size = $h1_hash{$m_id}{'s'};
- my $h1_msg = $h1_hash{$m_id}{'m'};
- my $h1_idate = $h1_hash{$m_id}{'D'};
-
- if ( ( not exists $h2_hash{ $m_id } )
- and ( not ( exists $h2_folders_of_md5{ $m_id } )
+ $h2_uidguess = $h2_uidnext ;
+
+ # Getting host2 headers, metada and delete2 stuff can be so long that host1 might be disconnected here
+ if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
+
+ MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) {
+ if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
+
+ #myprint( "h1_nb_msg_processed: $h1_nb_msg_processed\n" ) ;
+ my $h1_size = $h1_hash{$m_id}{'s'};
+ my $h1_msg = $h1_hash{$m_id}{'m'};
+ my $h1_idate = $h1_hash{$m_id}{'D'};
+
+ if ( ( not exists $h2_hash{ $m_id } )
+ and ( not ( exists $h2_folders_of_md5{ $m_id } )
or not $skipcrossduplicates ) ) {
- # copy
- my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ;
+ # copy
+ my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ;
$h2_folders_of_md5{ $m_id }->{ $h2_fold } ++ ;
if( $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 }++ ;
+ myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ;
+ $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
}
last FOLDER if total_bytes_max_reached( ) ;
- next MESS;
- }
- else{
- # already on host2
+ next MESS;
+ }
+ else{
+ # already on host2
if ( exists $h2_hash{ $m_id } ) {
- my $h2_msg = $h2_hash{$m_id}{'m'} ;
- $debug and myprint( "Host1 found msg $h1_fold/$h1_msg equals Host2 $h2_fold/$h2_msg\n" ) ;
+ my $h2_msg = $h2_hash{$m_id}{'m'} ;
+ $debug and myprint( "Host1 found msg $h1_fold/$h1_msg equals Host2 $h2_fold/$h2_msg\n" ) ;
if ( $usecache ) {
- $debugcache and myprint( "touch $cache_dir/${h1_msg}_$h2_msg\n" ) ;
- touch( "$cache_dir/${h1_msg}_$h2_msg" )
+ $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" ) ;
}
}elsif( exists $h2_folders_of_md5{ $m_id } ) {
- my @folders_dup = keys %{ $h2_folders_of_md5{ $m_id } } ;
- ( $debug or $debugcrossduplicates ) and myprint( "Host1 found msg $h1_fold/$h1_msg is also in Host2 folders @folders_dup\n" ) ;
+ my @folders_dup = keys %{ $h2_folders_of_md5{ $m_id } } ;
+ ( $debug or $debugcrossduplicates ) and myprint( "Host1 found msg $h1_fold/$h1_msg is also in Host2 folders @folders_dup\n" ) ;
}
- $total_bytes_skipped += $h1_size ;
- $nb_msg_skipped += 1 ;
+ $total_bytes_skipped += $h1_size ;
+ $nb_msg_skipped += 1 ;
$h1_nb_msg_processed +=1 ;
}
if ( exists $h2_hash{ $m_id } ) {
- #$debug and myprint( "MESSAGE $m_id\n" ) ;
- my $h2_msg = $h2_hash{$m_id}{'m'};
-
- sync_flags_fir( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ;
- # Good
- my $h2_size = $h2_hash{$m_id}{'s'};
- $debug and myprint(
- "Host1 size msg $h1_fold/$h1_msg = $h1_size <> $h2_size = Host2 $h2_fold/$h2_msg\n" ) ;
- }
- last FOLDER if $imap2->IsUnconnected( ) ;
+ #$debug and myprint( "MESSAGE $m_id\n" ) ;
+ my $h2_msg = $h2_hash{$m_id}{'m'};
+
+ sync_flags_fir( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ;
+ # Good
+ my $h2_size = $h2_hash{$m_id}{'s'};
+ $debug and myprint(
+ "Host1 size msg $h1_fold/$h1_msg = $h1_size <> $h2_size = Host2 $h2_fold/$h2_msg\n" ) ;
+ }
- if ( $delete ) {
- delete_message_on_host1( $h1_msg, $h1_fold ) ;
- }
- }
- # END MESS: loop
- last FOLDER if $imap1->IsUnconnected( ) ;
- last FOLDER if $imap2->IsUnconnected( ) ;
- MESS_IN_CACHE: 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" ) ;
- sync_flags_fir( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ;
- my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } || 0 ;
- $total_bytes_skipped += $h1_size;
- $nb_msg_skipped += 1;
+ if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
+
+
+ if ( $delete1 ) {
+ delete_message_on_host1( $h1_msg, $h1_fold ) ;
+ }
+ }
+ # END MESS: loop
+ if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
+ MESS_IN_CACHE: 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" ) ;
+ sync_flags_fir( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ;
+ my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } || 0 ;
+ $total_bytes_skipped += $h1_size;
+ $nb_msg_skipped += 1;
$h1_nb_msg_processed +=1 ;
- last FOLDER if $imap2->IsUnconnected( ) ;
- }
+ if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
- #myprint( "Messages by uid: ", map { "$_ " } keys %h1_msgs_copy_by_uid, "\n" ) ;
- MESS_BY_UID: foreach my $h1_msg ( sort { $a <=> $b } keys %h1_msgs_copy_by_uid ) {
- #
- $debug and myprint( "Copy by uid $h1_fold/$h1_msg\n" ) ;
- last FOLDER if $imap1->IsUnconnected( ) ;
- last FOLDER if $imap2->IsUnconnected( ) ;
- my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ;
+ }
+
+ #myprint( "Messages by uid: ", map { "$_ " } keys %h1_msgs_copy_by_uid, "\n" ) ;
+ MESS_BY_UID: foreach my $h1_msg ( sort { $a <=> $b } keys %h1_msgs_copy_by_uid ) {
+ #
+ $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( $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 }++ ;
+ myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ;
+ $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
}
- last FOLDER if total_bytes_max_reached( ) ;
- }
+ last FOLDER if total_bytes_max_reached( ) ;
+ }
- if ( $expunge or $expunge1 ){
- myprint( "Host1: Expunging folder $h1_fold $dry_message\n" ) ;
- unless( $dry ) { $imap1->expunge( ) } ;
- }
- if ( $expunge2 ){
- myprint( "Host2: Expunging folder $h2_fold $dry_message\n" ) ;
- unless( $dry ) { $imap2->expunge( ) } ;
- }
- $debug and myprint( 'Time: ', timenext( ), " s\n" ) ;
+ if ( $expunge1 ){
+ myprint( "Host1: Expunging folder $h1_fold $sync->{dry_message}\n" ) ;
+ if ( ! $sync->{dry} ) { $imap1->expunge( ) } ;
+ }
+ if ( $expunge2 ){
+ myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ;
+ if ( ! $sync->{dry} ) { $imap2->expunge( ) } ;
+ }
+ $debug and myprint( 'Time: ', timenext( ), " s\n" ) ;
}
-sub total_bytes_max_reached {
-
- return( 0 ) if not $exitwhenover ;
- if ( $total_bytes_transferred >= $exitwhenover ) {
- myprint( "Maximum bytes transferred reached, $total_bytes_transferred >= $exitwhenover, ending sync\n" ) ;
- return( 1 ) ;
- }
+myprint( "++++ End looping on each folder\n" ) ;
+if ( $delete1 and $sync->{'delete1emptyfolders'} ) {
+ delete1emptyfolders( $sync ) ;
}
-myprint( "++++ End looping on each folder\n" ) ;
( $debug or $sync->{debugfolders} ) and myprint( 'Time: ', timenext( ), " s\n" ) ;
if ( $foldersizesatend ) {
- myprint( << 'END_SIZE' ) ;
+ myprint( << 'END_SIZE' ) ;
Folders sizes after the synchronization.
You can remove this foldersizes listing by using "--nofoldersizesatend"
END_SIZE
- foldersizesatend( ) ;
+ foldersizesatend( ) ;
}
-$imap1->logout( ) unless lost_connection( $imap1, "for host1 [$host1]" ) ;
-$imap2->logout( ) unless lost_connection( $imap2, "for host2 [$host2]" ) ;
+if ( ! lost_connection( $imap1, "for host1 [$sync->{host1}]" ) ) { $imap1->logout( ) ; }
+if ( ! lost_connection( $imap2, "for host2 [$sync->{host2}]" ) ) { $imap2->logout( ) ; }
stats( $sync ) ;
myprint( errorsdump( $sync->{nb_errors}, errors_log( $sync ) ) ) if ( $sync->{errorsdump} ) ;
-tests_live_result( $sync->{nb_errors} ) if ( $testslive ) ;
+tests_live_result( $sync->{nb_errors} ) if ( $sync->{testslive} or $sync->{testslive6} ) ;
+
+
exit_clean( $sync, $EXIT_WITH_ERRORS ) if ( $sync->{nb_errors} ) ;
exit_clean( $sync, $EX_OK ) ;
@@ -2169,1019 +2178,1986 @@ exit_clean( $sync, $EX_OK ) ;
# subroutines
-sub myprint { return print @ARG ; }
-sub myprintf { return printf @ARG ; }
+sub myprint { return print @ARG ; }
+sub myprintf { return printf @ARG ; }
sub mysprintf {
my( $format, @list ) = @ARG ;
- return sprintf $format, @list ;
+ return sprintf $format, @list ;
}
-sub unsetunsafe {
- # Remove all content in unsafe evalued options
- @regextrans2 = ( ) ;
- @regexflag = ( ) ;
- @regexmess = ( ) ;
- @skipmess = ( ) ;
- @pipemess = ( ) ;
- $delete2foldersonly = undef ;
- $delete2foldersbutnot = undef ;
- return ;
-}
+sub output_start {
+ my $mysync = shift @ARG ;
-sub debugsleep {
- my $mysync = shift ;
- if ( defined $mysync->{debugsleep} ) {
- myprint( "Info: sleeping $mysync->{debugsleep}s\n" ) ;
- sleep $mysync->{debugsleep} ;
- }
- return ;
+ if ( not $mysync ) { return ; }
+
+ my @output = @ARG ;
+ $mysync->{ output } = join( q{}, @output ) . ( $mysync->{ output } || q{} ) ;
+ return $mysync->{ output } ;
}
-sub foldersizes_on_h1h2 {
- myprint( << 'END_SIZE' ) ;
+sub tests_output_start {
+ note( 'Entering tests_output_start()' ) ;
-Folders sizes before the synchronization.
-You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend"
-but then you will also loose the ETA (Estimation Time of Arrival) given after each message copy.
-END_SIZE
+ my $mysync = { } ;
- ( $h1_nb_msg_start, $h1_bytes_start ) = foldersizes( 'Host1', $imap1, $search1, @h1_folders_wanted ) ;
- ( $h2_nb_msg_start, $h2_bytes_start ) = foldersizes( 'Host2', $imap2, $search2, @h2_folders_from_1_wanted ) ;
+ is( undef, output_start( ), 'output_start: no args => undef' ) ;
+ is( q{}, output_start( $mysync ), 'output_start: one arg => ""' ) ;
+ is( 'rrrr', output_start( $mysync, 'rrrr' ), 'output_start: rrrr => rrrr' ) ;
+ is( 'aaaarrrr', output_start( $mysync, 'aaaa' ), 'output_start: aaaa => aaaarrrr' ) ;
+ is( "\naaaarrrr", output_start( $mysync, "\n" ), 'output_start: \n => \naaaarrrr' ) ;
+ is( "ABC\naaaarrrr", output_start( $mysync, 'A', 'B', 'C' ), 'output_start: A B C => ABC\naaaarrrr' ) ;
- if ( not all_defined( $h1_nb_msg_start, $h1_bytes_start, $h2_nb_msg_start, $h2_bytes_start ) ) {
- my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ;
- errors_incr( $sync, $error ) ;
- $foldersizes = 0 ;
- $foldersizesatend = 0 ;
- return ;
- }
-
- my $h2_bytes_limit = $sync->{host2}->{quota_limit_bytes} || 0 ;
- if ( $h2_bytes_limit and ( $h2_bytes_limit < $h1_bytes_start ) ) {
- my $quota_percent = mysprintf( '%.0f', $h1_bytes_start/$h2_bytes_limit ) ;
- my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $h1_bytes_start bytes / $h2_bytes_limit bytes )\n" ;
- errors_incr( $sync, $error ) ;
- }
- return ;
-}
-
-sub all_defined {
- if ( not @ARG ) {
- return 0 ;
- }
- foreach my $elem ( @ARG ) {
- if ( not defined $elem ) {
- return 0 ;
- }
- }
- return 1 ;
-}
-
-sub tests_all_defined {
- is( 0, all_defined( ), 'all_defined: no param => 0' ) ;
- is( 0, all_defined( () ), 'all_defined: void list => 0' ) ;
- is( 0, all_defined( undef ), 'all_defined: undef => 0' ) ;
- is( 0, all_defined( undef, undef ), 'all_defined: undef => 0' ) ;
- is( 0, all_defined( 1, undef ), 'all_defined: 1 undef => 0' ) ;
- is( 0, all_defined( undef, 1 ), 'all_defined: undef 1 => 0' ) ;
- is( 1, all_defined( 1, 1 ), 'all_defined: 1 1 => 1' ) ;
- is( 1, all_defined( (1, 1) ), 'all_defined: (1 1) => 1' ) ;
- return ;
+ note( 'Leaving tests_output_start()' ) ;
+ return ;
}
+sub tests_output {
+ note( 'Entering tests_output()' ) ;
-sub imap_id_stuff {
- my $sync = shift ;
-
- if ( not $sync->{id} ) { return ; } ;
+ my $mysync = { } ;
- $sync->{h1_imap_id} = imap_id( $sync->{imap1}, 'Host1' ) ;
- #myprint( 'Host1: ' . $sync->{h1_imap_id} ) ;
- $sync->{h2_imap_id} = imap_id( $sync->{imap2}, 'Host2' ) ;
- #myprint( 'Host2: ' . $sync->{h2_imap_id} ) ;
+ is( undef, output( ), 'output: no args => undef' ) ;
+ is( q{}, output( $mysync ), 'output: one arg => ""' ) ;
+ is( 'rrrr', output( $mysync, 'rrrr' ), 'output: rrrr => rrrr' ) ;
+ is( 'rrrraaaa', output( $mysync, 'aaaa' ), 'output: aaaa => rrrraaaa' ) ;
+ is( "rrrraaaa\n", output( $mysync, "\n" ), 'output: \n => rrrraaaa\n' ) ;
+ is( "rrrraaaa\nABC", output( $mysync, 'A', 'B', 'C' ), 'output: A B C => rrrraaaaABC\n' ) ;
+ note( 'Leaving tests_output()' ) ;
return ;
}
-sub imap_id {
- my ( $imap, $Side ) = @_ ;
+sub output {
+ my $mysync = shift @ARG ;
- $Side ||= q{} ;
- my $imap_id_response = q{} ;
+ if ( not $mysync ) { return ; }
- if ( not $imap->has_capability( 'ID' ) ) {
- $imap_id_response = 'No ID capability' ;
- myprint( "$Side: No ID capability\n" ) ;
- }else{
- my $id_inp = imapsync_id( { side => lc $Side } ) ;
- myprint( "\n$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" ) ;
- $imap->Debug( $debug_before ) ;
- #$imap_id_response = Data::Dumper->Dump( [ $id_out ], [ 'IMAP_ID' ] ) ;
- }
- return( $imap_id_response ) ;
+ my @output = @ARG ;
+ $mysync->{ output } .= join( q{}, @output ) ;
+ return $mysync->{ output } ;
}
-sub imapsync_id {
- my $overhashref = shift ;
- # See http://tools.ietf.org/html/rfc2971.html
-
- my $imapsync_id = { } ;
-
- my $imapsync_id_lamiral = {
- name => 'imapsync',
- version => imapsync_version( ),
- os => $OSNAME,
- vendor => 'Gilles LAMIRAL',
- 'support-url' => 'http://imapsync.lamiral.info/',
- # Example of date-time: 19-Sep-2015 08:56:07
- date => date_from_rcs( q{$Date: 2016/08/19 10:30:36 $ } ),
- } ;
- my $imapsync_id_github = {
- name => 'imapsync',
- version => imapsync_version( ),
- os => $OSNAME,
- vendor => 'github',
- 'support-url' => 'https://github.com/imapsync/imapsync',
- date => date_from_rcs( q{$Date: 2016/08/19 10:30:36 $ } ),
- } ;
- $imapsync_id = $imapsync_id_lamiral ;
- #$imapsync_id = $imapsync_id_github ;
- my %mix = ( %{ $imapsync_id }, %{ $overhashref } ) ;
- my $imapsync_id_str = format_for_imap_arg( \%mix ) ;
- #myprint( "$imapsync_id_str\n" ) ;
- return( $imapsync_id_str ) ;
-}
+sub tests_output_reset_with {
+ note( 'Entering tests_output_reset_with()' ) ;
-sub tests_imapsync_id {
- ok( '("name" "imapsync" "version" "111" "os" "beurk" "vendor" "Gilles LAMIRAL" "support-url" "http://imapsync.lamiral.info/" "date" "22-12-1968" "side" "host1")'
- eq imapsync_id( {
- version => 111,
- os => 'beurk',
- date => '22-12-1968',
- side => 'host1' } ),
- 'tests_imapsync_id override' ) ;
+ my $mysync = { } ;
+
+ is( undef, output_reset_with( ), 'output_reset_with: no args => undef' ) ;
+ is( q{}, output_reset_with( $mysync ), 'output_reset_with: one arg => ""' ) ;
+ is( 'rrrr', output_reset_with( $mysync, 'rrrr' ), 'output_reset_with: rrrr => rrrr' ) ;
+ is( 'aaaa', output_reset_with( $mysync, 'aaaa' ), 'output_reset_with: aaaa => aaaa' ) ;
+ is( "\n", output_reset_with( $mysync, "\n" ), 'output_reset_with: \n => \n' ) ;
+ note( 'Leaving tests_output_reset_with()' ) ;
return ;
}
-sub format_for_imap_arg {
- my $ref = shift ;
-
- my $string = q{} ;
- my %terms = %{ $ref } ;
- my @terms = ( ) ;
- if ( not ( %terms ) ) { return( 'NIL' ) } ;
- # sort like in RFC then add extra key/values
- foreach my $key ( qw( name version os os-version vendor support-url address date command arguments environment) ) {
- if ( $terms{ $key } ) {
- push @terms, $key, $terms{ $key } ;
- delete $terms{ $key } ;
- }
- }
- push @terms, %terms ;
- $string = '(' . ( join q{ }, map { '"' . $_ . '"' } @terms ) . ')' ;
- return( $string ) ;
+sub output_reset_with {
+ my $mysync = shift @ARG ;
+
+ if ( not $mysync ) { return ; }
+
+ my @output = @ARG ;
+ $mysync->{ output } = join( q{}, @output ) ;
+ return $mysync->{ output } ;
}
-sub tests_format_for_imap_arg {
- ok( 'NIL' eq format_for_imap_arg( { } ), 'format_for_imap_arg empty hash ref' ) ;
- ok( '("name" "toto")' eq format_for_imap_arg( { name => 'toto' } ), 'format_for_imap_arg { name => toto }' ) ;
- ok( '("name" "toto" "key" "val")' eq format_for_imap_arg( { name => 'toto', key => 'val' } ), 'format_for_imap_arg 2 x key val' ) ;
- return ;
-}
+sub abort {
+ my $mysync = shift @ARG ;
+ if ( ! -r $sync->{pidfile} ) {
+ myprint( "Can not read pidfile $sync->{pidfile}. Exiting.\n" ) ;
+ exit $EX_OK ;
+ }
+ my $pidtokill = firstline( $sync->{pidfile} ) ;
+ if ( ! $pidtokill ) {
+ myprint( "No process to abort. Exiting.\n" ) ;
+ exit $EX_OK ;
+ }
+ # First ask for suicide
+ if ( kill 'ZERO', $pidtokill ) {
+ myprint( "Sending signal QUIT to PID $pidtokill \n" ) ;
+ kill 'QUIT', $pidtokill ;
+ sleep 1 ;
+ }else{
+ myprint( "Can not send signal to PID $pidtokill. Exiting.\n" ) ;
+ exit $EX_OK ;
+ }
+ # Then murder
+ if ( kill 'ZERO', $pidtokill ) {
+ myprint( "Sending signal KILL to PID $pidtokill \n" ) ;
+ kill 'KILL', $pidtokill ;
+ sleep 1 ;
+ }else{
+ myprint( "Process PID $pidtokill ended. Exiting.\n" ) ;
+ exit $EX_OK ;
+ }
+ # Well ...
+ if ( kill 'ZERO', $pidtokill ) {
+ myprint( "Process PID $pidtokill still there. Can not do much. Exiting.\n" ) ;
+ exit $EX_OK ;
+ }
-sub quota {
- my ( $imap, $side, $sync ) = @_ ;
-
- my $Side = ucfirst $side ;
- my $debug_before = $imap->Debug( ) ;
- $imap->Debug( 1 ) ;
- if ( not $imap->has_capability( 'QUOTA' ) ) {
- $imap->Debug( $debug_before ) ;
- return ;
- } ;
- myprint( "\n$Side: found quota, presented in raw IMAP\n" ) ;
- my $getquotaroot = $imap->getquotaroot( 'INBOX' ) ;
- # Gmail INBOX quotaroot is "" but with it Mail::IMAPClient does a literal GETQUOTA {2} \n ""
- #$imap->quota( 'ROOT' ) ;
- #$imap->quota( '""' ) ;
- myprint( "\n" ) ;
- $imap->Debug( $debug_before ) ;
- my $quota_limit_bytes = quota_extract_storage_limit_in_bytes( $getquotaroot ) ;
- my $quota_current_bytes = quota_extract_storage_current_in_bytes( $getquotaroot ) ;
- $sync->{$side}->{quota_limit_bytes} = $quota_limit_bytes ;
- $sync->{$side}->{quota_current_bytes} = $quota_current_bytes ;
- my $quota_percent ;
- if ( $quota_limit_bytes > 0 ) {
- $quota_percent = mysprintf( '%.2f', $NUMBER_100 * $quota_current_bytes / $quota_limit_bytes ) ;
- }else{
- $quota_percent = 0 ;
- }
- myprint( "$Side: Quota current storage is $quota_current_bytes bytes. Limit is $quota_limit_bytes bytes. So $quota_percent % full\n" ) ;
- if ( $QUOTA_PERCENT_LIMIT < $quota_percent ) {
- my $error = "$Side: $quota_percent % full: it is time to find a bigger place! ( $quota_current_bytes bytes / $quota_limit_bytes bytes )\n" ;
- errors_incr( $sync, $error ) ;
- }
return ;
}
-sub tests_quota_extract_storage_limit_in_bytes {
- my $imap_output = [
- '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"',
- '* QUOTA "Storage quota" (STORAGE 1 104857600)',
- '* QUOTA "Messages quota" (MESSAGE 2 100000)',
- '5 OK Getquotaroot completed.'
- ] ;
- ok( $NUMBER_104857600 * $KIBI == quota_extract_storage_limit_in_bytes( $imap_output ), 'quota_extract_storage_limit_in_bytes ') ;
- return ;
-}
-sub quota_extract_storage_limit_in_bytes {
- my $imap_output = shift ;
- my $limit_kb ;
- $limit_kb = ( map { /.*\(\s*STORAGE\s+\d+\s+(\d+)\s*\)/ ? $1 : () } @{ $imap_output } )[0] ;
- $limit_kb ||= 0 ;
- $debug and myprint( "storage_limit_kb = $limit_kb\n" ) ;
- return( $KIBI * $limit_kb ) ;
+sub docker_context {
+ my $mysync = shift ;
+ -e '/.dockerenv' || return ;
+ myprint( "Docker context detected with /.dockerenv\n" ) ;
+ # No pidfile
+ $mysync->{pidfile} = q{} ;
+ # No log
+ $mysync->{log} = 0 ;
+ # In case
+ myprint( "Changing current directory to /var/tmp/\n" ) ;
+ chdir '/var/tmp/' ;
+
+ return ;
}
+sub cgibegin {
+ if ( ! under_cgi_context( ) ) { return ; }
+ my $mysync = shift ;
+ require CGI ;
+ CGI->import( qw( -no_debug ) ) ;
+ require CGI::Carp ;
+ CGI::Carp->import( qw( fatalsToBrowser ) ) ;
+ $mysync->{cgi} = CGI->new( ) ;
+ return ;
+}
-sub tests_quota_extract_storage_current_in_bytes {
- my $imap_output = [
- '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"',
- '* QUOTA "Storage quota" (STORAGE 1 104857600)',
- '* QUOTA "Messages quota" (MESSAGE 2 100000)',
- '5 OK Getquotaroot completed.'
- ] ;
- ok( 1*$KIBI == quota_extract_storage_current_in_bytes( $imap_output ), 'quota_extract_storage_current_in_bytes: 1 => 1024 ') ;
- return ;
+sub tests_under_cgi_context {
+ note( 'Entering tests_under_cgi_context()' ) ;
+ # $ENV{SERVER_SOFTWARE} = 'under imapsync' ;
+ do {
+ # Not in cgi context
+ delete local $ENV{SERVER_SOFTWARE} ;
+ is( undef, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE unset => not in cgi context' ) ;
+ } ;
+ do {
+ # In cgi context
+ local $ENV{SERVER_SOFTWARE} = 'under imapsync' ;
+ is( 1, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE set => in cgi context' ) ;
+ } ;
+ do {
+ # Not in cgi context
+ delete local $ENV{SERVER_SOFTWARE} ;
+ is( undef, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE unset => not in cgi context' ) ;
+ } ;
+ do {
+ # In cgi context
+ local $ENV{SERVER_SOFTWARE} = 'under imapsync' ;
+ is( 1, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE set => in cgi context' ) ;
+ } ;
+ note( 'Leaving tests_under_cgi_context()' ) ;
+ return ;
}
-sub quota_extract_storage_current_in_bytes {
- my $imap_output = shift ;
- my $current_kb ;
- $current_kb = ( map { /.*\(\s*STORAGE\s+(\d+)\s+\d+\s*\)/ ? $1 : () } @{ $imap_output } )[0] ;
- $current_kb ||= 0 ;
- $debug and myprint( "storage_current_kb = $current_kb\n" ) ;
- return( $KIBI * $current_kb ) ;
+sub under_cgi_context {
+ # Under cgi context
+ if ( $ENV{SERVER_SOFTWARE} ) {
+ return 1 ;
+ }
+ # Not in cgi context
+ return ;
}
+sub cgibuildheader {
+ if ( ! under_cgi_context( ) ) { return ; }
+ my $mysync = shift ;
-sub automap {
- my ( $sync ) = @_ ;
-
- if ( $sync->{automap} ) {
- myprint( "Turned on automapping folders ( use --noautomap to turn off automapping )\n" ) ;
+ my $imapsync_runs = $mysync->{cgi}->cookie( 'imapsync_runs' ) || 0 ;
+ my $cookie = $mysync->{cgi}->cookie(
+ -name => 'imapsync_runs',
+ -value => 1 + $imapsync_runs,
+ -expires => '+20y',
+ -path => '/cgi-bin/imapsync',
+ ) ;
+ my $httpheader ;
+ if ( $mysync->{ abort } ) {
+ $httpheader = $mysync->{cgi}->header(
+ -type => 'text/plain',
+ -status => '200 OK to stop playing IMAP mailboxes' . ". Load is $mysync->{ loadavg }",
+ ) ;
+ }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.
+ $httpheader = $mysync->{cgi}->header(
+ -type => 'text/plain',
+ -status => '503 Service Unavailable' . ". Be back in $mysync->{ loaddelay } min. Load is $mysync->{ loadavg }",
+ ) ;
}else{
- myprint( "Turned off automapping folders ( use --automap to turn on automapping )\n" ) ;
- return ;
+ $httpheader = $mysync->{cgi}->header(
+ -type => 'text/plain',
+ -status => '200 OK to play IMAP mailboxes' . ". Load is $mysync->{ loadavg }",
+ -cookie => $cookie,
+ ) ;
}
-
- $sync->{h1_special} = special_from_folders_hash( $sync->{imap1}, 'Host1' ) ;
- $sync->{h2_special} = special_from_folders_hash( $sync->{imap2}, 'Host2' ) ;
-
- build_possible_special( $sync ) ;
- build_guess_special( $sync ) ;
- build_automap( $sync ) ;
+ output_start( $mysync, $httpheader ) ;
return ;
}
-
-
-
-sub build_guess_special {
- my ( $sync ) = shift ;
-
- foreach my $h1_fold ( sort keys %{ $sync->{h1_folders_all} } ) {
- my $special = guess_special( $h1_fold, $sync->{possible_special}, $sync->{h1_prefix} ) ;
- if ( $special ) {
- $sync->{h1_special_guessed}{$h1_fold} = $special ;
- my $already_guessed = $sync->{h1_special_guessed}{$special} ;
- if ( $already_guessed ) {
- myprint( "Host1: $h1_fold not $special because set to $already_guessed\n" ) ;
- }else{
- $sync->{h1_special_guessed}{$special} = $h1_fold ;
- }
- }
- }
- foreach my $h2_fold ( sort keys %{ $sync->{h2_folders_all} } ) {
- my $special = guess_special( $h2_fold, $sync->{possible_special}, $sync->{h2_prefix} ) ;
- if ( $special ) {
- $sync->{h2_special_guessed}{$h2_fold} = $special ;
- my $already_guessed = $sync->{h2_special_guessed}{$special} ;
- if ( $already_guessed ) {
- myprint( "Host2: $h2_fold not $special because set to $already_guessed\n" ) ;
- }else{
- $sync->{h2_special_guessed}{$special} = $h2_fold ;
- }
- }
- }
- return ;
+sub cgiload {
+ if ( ! under_cgi_context( ) ) { return ; }
+ my $mysync = shift ;
+ if ( $mysync->{ abort } ) { return ; } # keep going to abort
+ if ( $mysync->{ loaddelay } ) {
+ myprint( "Server is on heavy load. Be back in $mysync->{ loaddelay } min. Load is $mysync->{ loadavg }\n") ;
+ exit_clean( $mysync, $EX_UNAVAILABLE ) ;
+ }
+ return ;
}
-sub guess_special {
- my( $folder, $possible_special_ref, $prefix ) = @_ ;
-
- my $folder_no_prefix = $folder ;
- $folder_no_prefix =~ s/${prefix}// ;
- #$debug and myprint( "folder_no_prefix: $folder_no_prefix\n" ) ;
-
- my $guess_special = $possible_special_ref->{ $folder }
- || $possible_special_ref->{ $folder_no_prefix }
- || q{} ;
+sub tests_set_umask {
+ note( 'Entering tests_set_umask()' ) ;
+ my $save_umask = umask ;
- return( $guess_special ) ;
-}
+ my $mysync = {} ;
+ 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" ) ;
+ }
-sub tests_guess_special {
- my $possible_special_ref = build_possible_special( my $sync ) ;
- ok( '\Sent' eq guess_special( 'Sent', $possible_special_ref, q{} ) ,'guess_special: Sent => \Sent' ) ;
- ok( q{} eq guess_special( 'Blabla', $possible_special_ref, q{} ) ,'guess_special: Blabla => q{}' ) ;
- ok( '\Sent' eq guess_special( 'INBOX.Sent', $possible_special_ref, 'INBOX.' ) ,'guess_special: INBOX.Sent => \Sent' ) ;
+ umask $save_umask ;
+ note( 'Leaving tests_set_umask()' ) ;
return ;
}
-sub build_automap {
- my ( $sync ) = @_ ;
-
- foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) {
- my $h2_fold ;
- my $h1_special = $sync->{h1_special}{$h1_fold} ;
- my $h1_special_guessed = $sync->{h1_special_guessed}{$h1_fold} ;
-
- # Case 1: special on both sides.
- if ( $h1_special
- and exists $sync->{h2_special}{$h1_special} ) {
- $h2_fold = $sync->{h2_special}{$h1_special} ;
- $sync->{f1f2auto}{ $h1_fold } = $h2_fold ;
- next ;
- }
- # Case 2: special on host1, not on host2
- if ( $h1_special
- and ( not exists $sync->{h2_special}{$h1_special} )
- and ( exists $sync->{h2_special_guessed}{$h1_special} )
- ) {
- # special_guessed on host2
- $h2_fold = $sync->{h2_special_guessed}{$h1_special} ;
- $sync->{f1f2auto}{ $h1_fold } = $h2_fold ;
- next ;
- }
- # Case 3: no special on host1, special on host2
- if ( ( not $h1_special )
- and ( $h1_special_guessed )
- and ( exists $sync->{h2_special}{$h1_special_guessed} )
- ) {
- $h2_fold = $sync->{h2_special}{$h1_special_guessed} ;
- $sync->{f1f2auto}{ $h1_fold } = $h2_fold ;
- next ;
- }
- # Case 4: no special on both sides.
- if ( ( not $h1_special )
- and ( $h1_special_guessed )
- and ( not exists $sync->{h2_special}{$h1_special_guessed} )
- and ( exists $sync->{h2_special_guessed}{$h1_special_guessed} )
- ) {
- $h2_fold = $sync->{h2_special_guessed}{$h1_special_guessed} ;
- $sync->{f1f2auto}{ $h1_fold } = $h2_fold ;
- next ;
- }
+sub set_umask {
+ my $mysync = shift ;
+ 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 ) {
+ return 1 ;
}
- return( $sync->{f1f2auto} ) ;
+ return ;
}
-# I willll probably add what there is at:
-# http://stackoverflow.com/questions/2185391/localized-gmail-imap-folders/2185548#2185548
-sub build_possible_special {
- my $sync = shift ;
- 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', '&BCcENQRABD0EPgQyBDgEOgQ4-' ] ;
- $possible_special->{'\Flagged'} = [ 'Flagged', 'Starred', '&BB8EPgQ8BDUERwQ1BD0EPQRLBDU-' ] ;
- $possible_special->{'\Junk'} = [ 'Junk', 'Spam', '&BCEEPwQwBDw-' ] ;
- $possible_special->{'\Sent'} = [ 'Sent', 'Sent Messages', 'Sent Items',
- 'Gesendete Elemente', 'Gesendete Objekte',
- '&AMk-l&AOk-ments envoy&AOk-s', 'Envoy&AOk-',
- 'Elementos enviados',
- '&kAFP4W4IMH8wojCkMMYw4A-',
- '&BB4EQgQ,BEAEMAQyBDsENQQ9BD0ESwQ1-'] ;
- $possible_special->{'\Trash'} = [ 'Trash', '&BCMENAQwBDsENQQ9BD0ESwQ1-', '&BBoEPgRABDcEOAQ9BDA-' ] ;
+sub tests_umask_str {
+ note( 'Entering tests_umask_str()' ) ;
+ my $save_umask = umask ;
- foreach my $special ( qw( \All \Archive \Drafts \Flagged \Junk \Sent \Trash ) ){
- foreach my $possible_folder ( @{ $possible_special->{$special} } ) {
- $possible_special->{ $possible_folder } = $special ;
- } ;
+ is( umask_str( ), umask_str( ), 'umask_str: no parameters => idopotent' ) ;
+ is( my $save_umask_str = umask_str( ), umask_str( ), 'umask_str: no parameters => idopotent + save' ) ;
+ is( '0000', umask_str( q{ } ), 'umask_str: q{ } => 0000' ) ;
+ is( '0000', umask_str( q{} ), 'umask_str: q{} => 0000' ) ;
+ is( '0000', umask_str( '0000' ), 'umask_str: 0000 => 0000' ) ;
+ is( '0000', umask_str( '0' ), 'umask_str: 0 => 0000' ) ;
+ is( '0200', umask_str( '0200' ), 'umask_str: 0200 => 0200' ) ;
+ 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" ) ;
}
- $sync->{possible_special} = $possible_special ;
- $debug and myprint( Data::Dumper->Dump( [ $possible_special ], [ 'possible_special' ] ) ) ;
- return( $possible_special ) ;
-}
-sub special_from_folders_hash {
- my ( $imap, $side ) = @_ ;
- my %special = ( ) ;
- if ( not( Mail::IMAPClient->can( 'folders_hash' ) ) ) {
- my $error = "$side: To have automagic rfc6154 folder mapping, upgrade Mail::IMAPClient >= 3.34\n" ;
- errors_incr( $sync, $error ) ;
- return( \%special ) ; # empty hash ref
- }
- my $folders_hash = $imap->folders_hash( ) ;
- foreach my $fhash (@{ $folders_hash } ) {
- my @special = grep { /\\(?:All|Archive|Drafts|Flagged|Junk|Sent|Trash)/ } @{ $fhash->{attrs} } ;
- if ( @special ) {
- my $special = $special[0] ; # keep first one. Could be not very good.
- if ( exists $special{ $special } ) {
- myprintf( "%s: special %-20s = %s already asigned to %s\n",
- $side, $fhash->{name}, join( q{ }, @special ), $special{ $special } ) ;
- }else{
- myprintf( "%s: special %-20s = %s\n",
- $side, $fhash->{name}, join( q{ }, @special ) ) ;
- $special{ $special } = $fhash->{name} ;
- $special{ $fhash->{name} } = $special ; # double entry value => key
- }
- }
- }
- myprint( "\n" ) if ( %special ) ;
- return( \%special ) ;
-}
+ is( $save_umask_str, umask_str( $save_umask_str ), 'umask_str: restore with str' ) ;
+ is( $save_umask, umask, 'umask_str: umask is restored, controlled by direct umask' ) ;
+ is( $save_umask, umask $save_umask, 'umask_str: umask is restored by direct umask' ) ;
+ is( $save_umask, umask, 'umask_str: umask initial controlled by direct umask' ) ;
-sub errors_incr {
- my ( $mysync, @error ) = @ARG ;
- $sync->{nb_errors}++ ;
-
- if ( @error ) {
- errors_log( $mysync, @error ) ;
- myprint( @error ) ;
- }
-
- $mysync->{errorsmax} ||= $ERRORS_MAX ;
- if ( $sync->{nb_errors} >= $mysync->{errorsmax} ) {
- myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to 100 with --errorsmax 100 ). Exiting.\n" ) ;
- if ( $mysync->{errorsdump} ) {
- myprint( errorsdump( $sync->{nb_errors}, errors_log( $mysync ) ) ) ;
- # again since errorsdump( ) can be very verbose and masq previous warning
- myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to 100 with --errorsmax 100 ). Exiting.\n" ) ;
- }
- exit_clean( $mysync, $EXIT_WITH_ERRORS_MAX ) ;
- }
+ note( 'Leaving tests_umask_str()' ) ;
return ;
}
-sub errors_log {
- my ( $mysync, @error ) = @ARG ;
+sub umask_str {
+ my $value = shift ;
- if ( ! $mysync->{errors_log} ) {
- $mysync->{errors_log} = [] ;
- }
+ if ( defined $value ) {
+ umask oct( $value ) ;
+ }
+ my $current = umask ;
- if ( @error ) {
- push @{ $mysync->{errors_log} }, join( q{}, @error ) ;
- }
- if ( @{ $mysync->{errors_log} } ) {
- return @{ $mysync->{errors_log} } ;
- }
- else {
- return ;
- }
+ return( sprintf( '%#04o', $current ) ) ;
}
-sub tests_errors_log {
+sub tests_umask {
+ note( 'Entering tests_umask()' ) ;
+ my $save_umask ;
+ is( umask, umask, 'umask: umask is umask' ) ;
+ is( $save_umask = umask, umask, "umask: umask is umask again + save it: $save_umask" ) ;
+ is( $save_umask, umask oct(0000), 'umask: umask 0000' ) ;
+ is( oct(0000), umask, 'umask: umask is now 0000' ) ;
+ is( oct(0000), umask oct(777), 'umask: umask 0777 call, previous 0000' ) ;
+
+ SKIP: {
+ if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests success only for Unix', 2 ) ; }
+ is( oct(777), umask, 'umask: umask is now 0777' ) ;
+ is( oct(777), umask $save_umask, "umask: umask $save_umask restore inital value, previous 0777" ) ;
+ }
+ ok( defined umask $save_umask, "umask: umask $save_umask restore inital value, previous defined" ) ;
+ is( $save_umask, umask, 'umask: umask is umask restored' ) ;
+ note( 'Leaving tests_umask()' ) ;
+ return ;
}
+sub cgisetcontext {
+ if ( ! under_cgi_context( ) ) { return ; }
-sub errorsdump {
- my( $nb_errors, @errors_log ) = @ARG ;
- my $error_num = 0 ;
- my $errors_list = q{} ;
- if ( @errors_log ) {
- $errors_list = "++++ Listing $nb_errors errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n" ;
- foreach my $error ( @errors_log ) {
- $error_num++ ;
- $errors_list .= "Err $error_num/$nb_errors: $error" ;
- }
- }
- return( $errors_list ) ;
-}
+ my $mysync = shift @ARG ;
+ output( $mysync, "Under cgi context\n" ) ;
+ set_umask( $mysync ) ;
+ # Remove all content in unsafe evaled options
+ @regextrans2 = ( ) ;
+ @regexflag = ( ) ;
+ @regexmess = ( ) ;
+ @skipmess = ( ) ;
+ @pipemess = ( ) ;
+ $delete2foldersonly = undef ;
+ $delete2foldersbutnot = undef ;
+ $maxlinelengthcmd = undef ;
+
+ # Set safe default values (I hope...)
+
+ $mysync->{pidfile} = 'imapsync.pid' ;
+ $mysync->{pidfilelocking} = 1 ;
+ $mysync->{errorsmax} = $ERRORS_MAX_CGI ;
+ $modulesversion = 0 ;
+ $releasecheck = 1 ;
+ $usecache = 0 ;
+ $mysync->{showpasswords} = 0 ;
+ $debugimap1 = $debugimap2 = $debugimap = 0 ;
+ $reconnectretry1 = $reconnectretry2 = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ;
+ $pipemesscheck = 0 ;
+
+ $mysync->{hashfile} = $CGI_HASHFILE ;
+ my $hashsynclocal = hashsynclocal( $mysync ) || die "Can not get hashsynclocal. Exiting\n" ;
+ $cgidir = $CGI_TMPDIR_TOP . '/' . $hashsynclocal ;
+
+ -d $cgidir or mkpath $cgidir or die "Can not create $cgidir: $OS_ERROR\n" ;
+ chdir $cgidir or die "Can not cd to $cgidir: $OS_ERROR\n" ;
+ $tmpdir = $cgidir ;
+ cgioutputenvcontext( $mysync ) ;
+ $debug and output( $mysync, 'Current directory is ' . getcwd( ) . "\n" ) ;
+ $debug and output( $mysync, 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ;
+ $debug and output( $mysync, 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ;
-sub tests_live_result {
- my $nb_errors = shift ;
- if ( $nb_errors ) {
- myprint( "Live tests failed with $nb_errors errors\n" ) ;
- } else {
- myprint( "Live tests ended successfully\n" ) ;
- }
return ;
}
-sub foldersizesatend {
- timenext( ) ;
- return if ( $imap1->IsUnconnected( ) ) ;
- return if ( $imap2->IsUnconnected( ) ) ;
- # Get all folders on host2 again since new were created
- @h2_folders_all = sort $imap2->folders();
- for ( @h2_folders_all ) {
- $h2_folders_all{ $_ } = 1 ;
- $h2_folders_all_UPPER{ uc $_ } = 1 ;
- } ;
- ( $h1_nb_msg_end, $h1_bytes_end ) = foldersizes( 'Host1', $imap1, $search1, @h1_folders_wanted ) ;
- ( $h2_nb_msg_end, $h2_bytes_end ) = foldersizes( 'Host2', $imap2, $search2, @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( $sync, $error ) ;
- }
- return ;
-}
+sub cgioutputenvcontext {
+ my $mysync = shift @ARG ;
-sub size_filtered_flag {
- my $h1_size = shift ;
+ for my $envvar ( qw( REMOTE_ADDR REMOTE_HOST HTTP_REFERER HTTP_USER_AGENT HTTP_COOKIE ) ) {
- if (defined $maxsize and $h1_size >= $maxsize) {
- return( 1 ) ;
- }
- if (defined $minsize and $h1_size <= $minsize) {
- return( 1 ) ;
+ my $envval = $ENV{ $envvar } || q{} ;
+ if ( $envval ) { output( $mysync, "$envvar is $envval\n" ) } ;
}
- return( 0 ) ;
-}
-sub sync_flags_fir {
- my ( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ;
+ return ;
+}
- if ( not defined $h1_msg ) { return } ;
- if ( not defined $h2_msg ) { return } ;
- my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} ;
- return if size_filtered_flag( $h1_size ) ;
- # used cached flag values for efficiency
- my $h1_flags = $h1_fir_ref->{ $h1_msg }->{ 'FLAGS' } || q{} ;
- my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ 'FLAGS' } || q{} ;
- sync_flags( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ;
+sub debugsleep {
+ my $mysync = shift @ARG ;
+ if ( defined $mysync->{debugsleep} ) {
+ myprint( "Info: sleeping $mysync->{debugsleep}s\n" ) ;
+ sleep $mysync->{debugsleep} ;
+ }
return ;
}
-sub sync_flags_after_copy {
- my( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $permanentflags2 ) = @_ ;
-
- my @h2_flags = $imap2->flags( $h2_msg ) ;
- my $h2_flags = "@h2_flags" ;
- ( $debug or $debugflags ) and myprint( "Host2 flags before resync by STORE on msg $h2_msg: $h2_flags\n" ) ;
- sync_flags( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ;
- return ;
-}
+sub foldersizes_on_h1h2 {
+ myprint( << 'END_SIZE' ) ;
-sub sync_flags {
- my( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) = @_ ;
+Folders sizes before the synchronization.
+You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend"
+but then you will also loose the ETA (Estimation Time of Arrival) given after each message copy.
+END_SIZE
- ( $debug or $debugflags ) and
- myprint( "Host1: flags init msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 $h2_fold/$h2_msg flags( $h2_flags )\n" ) ;
+ ( $h1_nb_msg_start, $h1_bytes_start ) = foldersizes( 'Host1', $imap1, $search1, $sync->{abletosearch1}, @h1_folders_wanted ) ;
+ ( $h2_nb_msg_start, $h2_bytes_start ) = foldersizes( 'Host2', $imap2, $search2, $sync->{abletosearch2}, @h2_folders_from_1_wanted ) ;
- $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ;
-
- $h2_flags = flagscase( $h2_flags ) ;
-
- ( $debug or $debugflags ) and
- myprint( "Host1 flags filt msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 $h2_fold/$h2_msg flags( $h2_flags )\n" ) ;
-
-
- # compare flags - set flags if there a difference
- my @h1_flags = sort split(q{ }, $h1_flags );
- my @h2_flags = sort split(q{ }, $h2_flags );
- my $diff = compare_lists( \@h1_flags, \@h2_flags );
-
- $diff and ( $debug or $debugflags )
- and myprint( "Host2 flags msg $h2_fold/$h2_msg replacing h2 flags( $h2_flags ) with h1 flags( $h1_flags )\n" ) ;
- # This sets flags so flags can be removed with this
- # When you remove a \Seen flag on host1 you want to it
- # to be removed on host2. Just add flags is not what
- # we need most of the time.
-
- if ( not $dry and $diff and not $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]: ",
- $imap2->LastError || q{}, "\n" ;
- errors_incr( $sync, $error_msg ) ;
- }
+ if ( not all_defined( $h1_nb_msg_start, $h1_bytes_start, $h2_nb_msg_start, $h2_bytes_start ) ) {
+ my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ;
+ errors_incr( $sync, $error ) ;
+ $foldersizes = 0 ;
+ $foldersizesatend = 0 ;
+ return ;
+ }
+ my $h2_bytes_limit = $sync->{h2}->{quota_limit_bytes} || 0 ;
+ if ( $h2_bytes_limit and ( $h2_bytes_limit < $h1_bytes_start ) ) {
+ my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $h1_bytes_start / $h2_bytes_limit ) ;
+ my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $h1_bytes_start bytes / $h2_bytes_limit bytes )\n" ;
+ errors_incr( $sync, $error ) ;
+ }
return ;
}
+sub total_bytes_max_reached {
-sub _filter {
- my $str = shift or return q{} ;
- my $sz = $SIZE_MAX_STR ;
- my $len = length $str ;
- if ( not $debug and $len > $sz*2 ) {
- my $beg = substr $str, 0, $sz ;
- my $end = substr $str, -$sz, $sz ;
- $str = $beg . '...' . $end ;
+ return( 0 ) if not $exitwhenover ;
+ if ( $sync->{total_bytes_transferred} >= $exitwhenover ) {
+ myprint( "Maximum bytes transferred reached, $sync->{total_bytes_transferred} >= $exitwhenover, ending sync\n" ) ;
+ return( 1 ) ;
}
- $str =~ s/\012?\015$//x ;
- return "(len=$len) " . $str ;
-}
+}
-sub lost_connection {
- my( $imap, $error_message ) = @_;
- if ( $imap->IsUnconnected( ) ) {
- $sync->{nb_errors}++ ;
- my $lcomm = $imap->LastIMAPCommand || q{} ;
- my $einfo = $imap->LastError || @{$imap->History}[$LAST] || q{} ;
- # if string is long try reduce to a more reasonable size
- $lcomm = _filter( $lcomm ) ;
- $einfo = _filter( $einfo ) ;
- myprint( "Failure: last command: $lcomm\n") if ($debug && $lcomm) ;
- myprint( "Failure: lost connection $error_message: ", $einfo, "\n") ;
- return( 1 ) ;
+sub all_defined {
+ if ( not @ARG ) {
+ return 0 ;
}
- else{
- return( 0 ) ;
+ foreach my $elem ( @ARG ) {
+ if ( not defined $elem ) {
+ return 0 ;
+ }
}
+ return 1 ;
}
-sub max {
- my @list = @_ ;
- return( undef ) if ( 0 == scalar @list ) ;
- my @sorted = sort { $a <=> $b } @list ;
- return( pop @sorted ) ;
-}
-
-sub tests_max {
- ok( 0 == max( 0 ), 'max 0' ) ;
- ok( 1 == max( 1 ), 'max 1' ) ;
- ok( $MINUS_ONE == max( $MINUS_ONE ), 'max -1') ;
- ok( not ( defined max( ) ), 'max no arg' ) ;
- ok( $NUMBER_100 == max( 1, $NUMBER_100 ), 'max 1 100' ) ;
- ok( $NUMBER_100 == max( $NUMBER_100, 1 ), 'max 100 1' ) ;
- ok( $NUMBER_100 == max( $NUMBER_100, $NUMBER_42, 1 ), 'max 100 42 1' ) ;
- ok( $NUMBER_100 == max( $NUMBER_100, '42', 1 ), 'max 100 42 1' ) ;
- ok( $NUMBER_100 == max( '100', '42', 1 ), 'max 100 42 1' ) ;
- #ok( 100 == max( 100, 'haha', 1 ), 'max 100 42 1') ;
- return ;
-}
+sub tests_all_defined {
+ note( 'Entering tests_all_defined()' ) ;
+ is( 0, all_defined( ), 'all_defined: no param => 0' ) ;
+ is( 0, all_defined( () ), 'all_defined: void list => 0' ) ;
+ is( 0, all_defined( undef ), 'all_defined: undef => 0' ) ;
+ is( 0, all_defined( undef, undef ), 'all_defined: undef => 0' ) ;
+ is( 0, all_defined( 1, undef ), 'all_defined: 1 undef => 0' ) ;
+ is( 0, all_defined( undef, 1 ), 'all_defined: undef 1 => 0' ) ;
+ is( 1, all_defined( 1, 1 ), 'all_defined: 1 1 => 1' ) ;
+ is( 1, all_defined( (1, 1) ), 'all_defined: (1 1) => 1' ) ;
-sub check_lib_version {
- $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" ) ;
- return 0 ;
- }
- else{
- # 3.x.x is no longer buggy with imapsync.
- # 3.30 or currently superior is imposed in the Perl "use Mail::IMAPClient line".
- return 1 ;
- }
+ note( 'Leaving tests_all_defined()' ) ;
return ;
}
-sub module_version_str {
- my( $module_name, $module_version ) = @_ ;
- my $str = mysprintf( "%-20s %s\n", $module_name, $module_version ) ;
- return( $str ) ;
-}
-sub modulesversion {
+sub tests_hashsynclocal {
+ note( 'Entering tests_hashsynclocal()' ) ;
- my @list_version;
+ my $mysync = {
+ host1 => '',
+ user1 => '',
+ password1 => '',
+ host2 => '',
+ user2 => '',
+ password2 => '',
+ } ;
- my $v ;
- eval { require Mail::IMAPClient; $v = $Mail::IMAPClient::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Mail::IMAPClient', $v ) ;
+ is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no hashfile name' ) ;
- eval { require IO::Socket; $v = $IO::Socket::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'IO::Socket', $v ) ;
+ $mysync->{ hashfile } = '' ;
+ is( undef, hashsynclocal( $mysync ), 'hashsynclocal: empty hashfile name' ) ;
- eval { require IO::Socket::INET; $v = $IO::Socket::INET::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'IO::Socket::INET', $v ) ;
+ $mysync->{ hashfile } = './noexist/rrr' ;
+ is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no exists hashfile dir' ) ;
- eval { require IO::Socket::INET6; $v = $IO::Socket::INET6::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'IO::Socket::INET6', $v ) ;
+ SKIP: {
+ if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests only for Unix', 1 ) ; }
+ $mysync->{ hashfile } = '/rrr' ;
+ is( undef, hashsynclocal( $mysync ), 'hashsynclocal: permission denied' ) ;
+ }
+ ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'hashsynclocal: mkpath W/tmp/tests/' ) ;
+ $mysync->{ hashfile } = 'W/tmp/tests/imapsync_hash' ;
- eval { require IO::Socket::SSL ; $v = $IO::Socket::SSL::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'IO::Socket::SSL ', $v ) ;
+ ok( ! -e 'W/tmp/tests/imapsync_hash' || unlink 'W/tmp/tests/imapsync_hash', 'hashsynclocal: unlink W/tmp/tests/imapsync_hash' ) ;
+ ok( ! -e 'W/tmp/tests/imapsync_hash', 'hashsynclocal: verify there is no W/tmp/tests/imapsync_hash' ) ;
+ is( 'ecdeb4ede672794d173da4e08c52b8ee19b7d252', hashsynclocal( $mysync, 'mukksyhpmbixkxkpjlqivmlqsulpictj' ), 'hashsynclocal: creating/reading W/tmp/tests/imapsync_hash' ) ;
+ # A second time now
+ is( 'ecdeb4ede672794d173da4e08c52b8ee19b7d252', hashsynclocal( $mysync ), 'hashsynclocal: reading W/tmp/tests/imapsync_hash second time => same' ) ;
- eval { require Net::SSLeay ; $v = $Net::SSLeay::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Net::SSLeay ', $v ) ;
+ note( 'Leaving tests_hashsynclocal()' ) ;
+ return ;
+}
- eval { require Compress::Zlib; $v = $Compress::Zlib::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Compress::Zlib', $v ) ;
+sub hashsynclocal {
+ my $mysync = shift ;
+ my $hashkey = shift ; # Optional, only there for tests
+ my $hashfile = $mysync->{ hashfile } ;
+ $hashfile = createhashfileifneeded( $hashfile, $hashkey ) ;
+ if ( ! $hashfile ) {
+ return ;
+ }
+ $hashkey = firstline( $hashfile ) ;
+ if ( ! $hashkey ) {
+ myprint( "No hashkey!\n" ) ;
+ return ;
+ }
+ my $hashsynclocal = hashsync( $mysync, $hashkey ) ;
+ return( $hashsynclocal ) ;
- eval { require Digest::MD5; $v = $Digest::MD5::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Digest::MD5', $v ) ;
+}
- eval { require Digest::HMAC_MD5; $v = $Digest::HMAC_MD5::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Digest::HMAC_MD5', $v ) ;
+sub tests_hashsync {
+ note( 'Entering tests_hashsync()' ) ;
- eval { require Digest::HMAC_SHA1; $v = $Digest::HMAC_SHA1::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Digest::HMAC_SHA1', $v ) ;
- eval { require Term::ReadKey; $v = $Term::ReadKey::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Term::ReadKey', $v ) ;
+ is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( {}, q{} ), 'hashsync: empty args' ) ;
+ my $mysync ;
+ $mysync->{ host1 } = 'zzz' ;
+ is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ;
+ is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ;
+ $mysync->{ host2 } = 'zzz' ;
+ is( '15959573e4a86763253a7aedb1a2b0c60d133dc2', hashsync( $mysync, q{} ), 'hashsync: + host2 zzz => ' ) ;
+ is( 'b8d4ab541b209c75928528020ca28ee43488bd8f', hashsync( $mysync, 'A' ), 'hashsync: + hashkey A => ' ) ;
- eval { require File::Spec; $v = $File::Spec::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'File::Spec', $v ) ;
+ note( 'Leaving tests_hashsync()' ) ;
+ return ;
+}
- eval { require Time::HiRes; $v = $Time::HiRes::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Time::HiRes', $v ) ;
+sub hashsync {
+ my $mysync = shift ;
+ my $hashkey = shift ;
- eval { require Unicode::String; $v = $Unicode::String::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Unicode::String', $v ) ;
+ my $mystring = join( q{},
+ $mysync->{ host1 } || q{},
+ $mysync->{ user1 } || q{},
+ $mysync->{ password1 } || q{},
+ $mysync->{ host2 } || q{},
+ $mysync->{ user2 } || q{},
+ $mysync->{ password2 } || q{},
+ ) ;
+ my $hashsync = hmac_sha1_hex( $mystring, $hashkey ) ;
+ #myprint( "$hashsync\n" ) ;
+ return( $hashsync ) ;
+}
- eval { require IO::Tee; $v = $IO::Tee::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'IO::Tee', $v ) ;
- eval { require File::Copy::Recursive; $v = $File::Copy::Recursive::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'File::Copy::Recursive', $v ) ;
+sub tests_createhashfileifneeded {
+ note( 'Entering tests_createhashfileifneeded()' ) ;
- eval { require Authen::NTLM; $v = $Authen::NTLM::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Authen::NTLM', $v ) ;
+ is( undef, createhashfileifneeded( ), 'createhashfileifneeded: no parameters => undef' ) ;
- eval { require URI::Escape; $v = $URI::Escape::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'URI::Escape', $v ) ;
+ note( 'Leaving tests_createhashfileifneeded()' ) ;
+ return ;
+}
- eval { require Data::Uniqid; $v = $Data::Uniqid::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Data::Uniqid', $v ) ;
+sub createhashfileifneeded {
+ my $hashfile = shift ;
+ my $hashkey = shift || rand32( ) ;
- eval { require JSON; $v = $JSON::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'JSON', $v ) ;
+ # no name
+ if ( ! $hashfile ) {
+ return ;
+ }
+ # already there
+ if ( -e -r $hashfile ) {
+ return $hashfile ;
+ }
+ # not creatable
+ if ( ! -w dirname( $hashfile ) ) {
+ return ;
+ }
+ # creatable
+ open my $FILE_HANDLE, '>', $hashfile
+ or do {
+ myprint( "Could not open $hashfile for writing. Check permissions or disk space." ) ;
+ return ;
+ } ;
+ myprint( "Writing random hashkey in $hashfile, once for all times\n" ) ;
+ print $FILE_HANDLE $hashkey ;
+ close $FILE_HANDLE ;
+ # Should be there now
+ if ( -e -r $hashfile ) {
+ return $hashfile ;
+ }
+ # unknown failure
+ return ;
+}
- eval { require JSON::WebToken; $v = $JSON::WebToken::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'JSON::WebToken', $v ) ;
+sub tests_rand32 {
+ note( 'Entering tests_rand32()' ) ;
- eval { require Crypt::OpenSSL::RSA; $v = $Crypt::OpenSSL::RSA::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Crypt::OpenSSL::RSA', $v ) ;
+ my $string = rand32( ) ;
+ print "$string\n" ;
+ is( 32, length( $string ), 'rand32: 32 characters long' ) ;
+ is( 32, length( rand32( ) ), 'rand32: 32 characters long, another one' ) ;
- eval { require LWP; $v = $LWP::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'LWP', $v ) ;
+ note( 'Leaving tests_rand32()' ) ;
+ return ;
+}
- eval { require HTML::Entities; $v = $HTML::Entities::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'HTML::Entities', $v ) ;
+sub rand32 {
+ my @chars = ( "a".."z" ) ;
+ my $string;
+ $string .= $chars[rand @chars] for 1..32 ;
+ return $string ;
+}
- #eval { require Filesys::DfPortable; $v = $Filesys::DfPortable::VERSION } or $v = q{?} ;
- #push @list_version, module_version_str( 'Filesys::DfPortable', $v ) ;
+sub imap_id_stuff {
+ my $mysync = shift ;
- eval { require Getopt::Long; $v = $Getopt::Long::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Getopt::Long', $v ) ;
+ if ( not $mysync->{id} ) { return ; } ;
- eval { require Test::MockObject; $v = $Test::MockObject::VERSION } or $v = q{?} ;
- push @list_version, module_version_str( 'Test::MockObject', $v ) ;
+ $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' ) ;
+ #myprint( 'Host2: ' . $mysync->{h2_imap_id} ) ;
- return( @list_version ) ;
+ return ;
}
+sub imap_id {
+ my ( $mysync, $imap, $Side ) = @_ ;
-# Construct a command line copy with passwords replaced by MASKED.
-sub command_line_nopassword {
- my @argv = @_ ;
- my @argv_nopassword ;
-
- return( "@argv" ) if $showpasswords ;
- while ( @argv ) {
- my $arg = shift @argv ; # option name or value
- if ( $arg =~ m/-password[12]/x ) {
- shift @argv ; # password value
- push @argv_nopassword, $arg, 'MASKED' ; # option name and fake value
- }else{
- push @argv_nopassword, $arg ; # same option or value
- }
- }
- return("@argv_nopassword") ;
+ $Side ||= q{} ;
+ my $imap_id_response = q{} ;
+
+ if ( not $imap->has_capability( 'ID' ) ) {
+ $imap_id_response = 'No ID capability' ;
+ 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"
+ . "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" ) ;
+ $imap->Debug( $debug_before ) ;
+ #$imap_id_response = Data::Dumper->Dump( [ $id_out ], [ 'IMAP_ID' ] ) ;
+ }
+ return( $imap_id_response ) ;
}
-sub tests_command_line_nopassword {
+sub imapsync_id {
+ my $mysync = shift ;
+ my $overhashref = shift ;
+ # See http://tools.ietf.org/html/rfc2971.html
+
+ my $imapsync_id = { } ;
+
+ my $imapsync_id_lamiral = {
+ name => 'imapsync',
+ version => imapsync_version( $mysync ),
+ os => $OSNAME,
+ vendor => 'Gilles LAMIRAL',
+ 'support-url' => 'http://imapsync.lamiral.info/',
+ # Example of date-time: 19-Sep-2015 08:56:07
+ date => date_from_rcs( q{$Date: 2017/09/05 16:14:53 $ } ),
+ } ;
- ok(q{} eq command_line_nopassword(), 'command_line_nopassword void');
- ok('--blabla' eq command_line_nopassword('--blabla'), 'command_line_nopassword --blabla');
- #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ;
- ok('--password1 MASKED' eq command_line_nopassword(qw{ --password1 secret1}), 'command_line_nopassword --password1');
- ok('--blabla --password1 MASKED --blibli'
- eq command_line_nopassword(qw{ --blabla --password1 secret1 --blibli }), 'command_line_nopassword --password1 --blibli');
- $showpasswords = 1 ;
- ok(q{} eq command_line_nopassword(), 'command_line_nopassword void');
- ok('--blabla' eq command_line_nopassword('--blabla'), 'command_line_nopassword --blabla');
- #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ;
- ok('--password1 secret1' eq command_line_nopassword(qw{ --password1 secret1}), 'command_line_nopassword --password1');
- ok('--blabla --password1 secret1 --blibli'
- eq command_line_nopassword(qw{ --blabla --password1 secret1 --blibli }), 'command_line_nopassword --password1 --blibli');
- return ;
-}
+ my $imapsync_id_github = {
+ name => 'imapsync',
+ version => imapsync_version( $mysync ),
+ os => $OSNAME,
+ vendor => 'github',
+ 'support-url' => 'https://github.com/imapsync/imapsync',
+ date => date_from_rcs( q{$Date: 2017/09/05 16:14:53 $ } ),
+ } ;
-sub ask_for_password {
- my ( $user, $host ) = @_ ;
- myprint( "What's the password for $user" . '@' . "$host? (not visible while you type, then enter RETURN) " ) ;
- Term::ReadKey::ReadMode( 2 ) ;
- my $password = <> ;
- chomp $password ;
- myprint( "\nGot it\n" ) ;
- Term::ReadKey::ReadMode( 0 ) ;
- return $password ;
+ $imapsync_id = $imapsync_id_lamiral ;
+ #$imapsync_id = $imapsync_id_github ;
+ my %mix = ( %{ $imapsync_id }, %{ $overhashref } ) ;
+ my $imapsync_id_str = format_for_imap_arg( \%mix ) ;
+ #myprint( "$imapsync_id_str\n" ) ;
+ return( $imapsync_id_str ) ;
}
-sub catch_exit {
- my $mysync = shift ;
- my $signame = shift ;
- if ( $signame ) {
- myprint( "\nGot a signal $signame\n" ) ;
- }
- stats( $mysync ) ;
- myprint( "Ended by a signal\n" ) ;
- exit_clean( $mysync, $EXIT_BY_SIGNAL ) ;
+sub tests_imapsync_id {
+ note( 'Entering tests_imapsync_id()' ) ;
+
+ my $mysync ;
+ ok( '("name" "imapsync" "version" "111" "os" "beurk" "vendor" "Gilles LAMIRAL" "support-url" "http://imapsync.lamiral.info/" "date" "22-12-1968" "side" "host1")'
+ eq imapsync_id( $mysync,
+ {
+ version => 111,
+ os => 'beurk',
+ date => '22-12-1968',
+ side => 'host1'
+ }
+ ),
+ 'tests_imapsync_id override'
+ ) ;
+
+ note( 'Leaving tests_imapsync_id()' ) ;
return ;
}
-sub catch_reconnect {
- my $mysync = shift ;
- my $signame = shift ;
- myprint( "\nGot a signal $signame\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",
- ) ;
- if ( here_twice( $mysync ) ) {
- myprint( "Got two signals $signame within $INTERVAL_TO_EXIT seconds. Exiting...\n" ) ;
- catch_exit( $mysync ) ;
- }
- else{
- myprint( "For now only one signal $signame within $INTERVAL_TO_EXIT seconds.\n" ) ;
+sub format_for_imap_arg {
+ my $ref = shift ;
+
+ my $string = q{} ;
+ my %terms = %{ $ref } ;
+ my @terms = ( ) ;
+ if ( not ( %terms ) ) { return( 'NIL' ) } ;
+ # sort like in RFC then add extra key/values
+ foreach my $key ( qw( name version os os-version vendor support-url address date command arguments environment) ) {
+ if ( $terms{ $key } ) {
+ push @terms, $key, $terms{ $key } ;
+ delete $terms{ $key } ;
+ }
}
+ push @terms, %terms ;
+ $string = '(' . ( join q{ }, map { '"' . $_ . '"' } @terms ) . ')' ;
+ return( $string ) ;
+}
- if ( ! defined $mysync->{imap1} ) { return ; }
- if ( ! defined $mysync->{imap2} ) { return ; }
-
- myprint( "Info: reconnecting to host1 imap server\n" ) ;
- $mysync->{imap1}->State( Mail::IMAPClient::Unconnected ) ;
- $mysync->{imap1}->reconnect( ) ;
- myprint( "Info: reconnecting to host2 imap server\n" ) ;
- $mysync->{imap2}->State( Mail::IMAPClient::Unconnected ) ;
- $mysync->{imap2}->reconnect( ) ;
- myprint( "Info: reconnected to both imap servers\n" ) ;
+
+sub tests_format_for_imap_arg {
+ note( 'Entering tests_format_for_imap_arg()' ) ;
+
+ ok( 'NIL' eq format_for_imap_arg( { } ), 'format_for_imap_arg empty hash ref' ) ;
+ ok( '("name" "toto")' eq format_for_imap_arg( { name => 'toto' } ), 'format_for_imap_arg { name => toto }' ) ;
+ ok( '("name" "toto" "key" "val")' eq format_for_imap_arg( { name => 'toto', key => 'val' } ), 'format_for_imap_arg 2 x key val' ) ;
+
+ note( 'Leaving tests_format_for_imap_arg()' ) ;
return ;
}
-sub here_twice {
- my $mysync = shift ;
- my $now = time ;
- my $previous = $mysync->{lastcatch} || 0 ;
- $mysync->{lastcatch} = $now ;
-
- if ( $INTERVAL_TO_EXIT >= $now - $previous ) {
- return $TRUE ;
+sub quota {
+ my ( $imap, $side, $mysync ) = @_ ;
+
+ my %side = (
+ h1 => 'Host1',
+ h2 => 'Host2',
+ ) ;
+ my $Side = $side{ $side } ;
+ my $debug_before = $imap->Debug( ) ;
+ $imap->Debug( 1 ) ;
+ if ( not $imap->has_capability( 'QUOTA' ) ) {
+ $imap->Debug( $debug_before ) ;
+ return ;
+ } ;
+ myprint( "\n$Side: found quota, presented in raw IMAP\n" ) ;
+ my $getquotaroot = $imap->getquotaroot( 'INBOX' ) ;
+ # Gmail INBOX quotaroot is "" but with it Mail::IMAPClient does a literal GETQUOTA {2} \n ""
+ #$imap->quota( 'ROOT' ) ;
+ #$imap->quota( '""' ) ;
+ myprint( "\n" ) ;
+ $imap->Debug( $debug_before ) ;
+ my $quota_limit_bytes = quota_extract_storage_limit_in_bytes( $getquotaroot ) ;
+ my $quota_current_bytes = quota_extract_storage_current_in_bytes( $getquotaroot ) ;
+ $mysync->{$side}->{quota_limit_bytes} = $quota_limit_bytes ;
+ $mysync->{$side}->{quota_current_bytes} = $quota_current_bytes ;
+ my $quota_percent ;
+ if ( $quota_limit_bytes > 0 ) {
+ $quota_percent = mysprintf( '%.2f', $NUMBER_100 * $quota_current_bytes / $quota_limit_bytes ) ;
}else{
- return $FALSE ;
+ $quota_percent = 0 ;
+ }
+ myprint( "$Side: Quota current storage is $quota_current_bytes bytes. Limit is $quota_limit_bytes bytes. So $quota_percent % full\n" ) ;
+ if ( $QUOTA_PERCENT_LIMIT < $quota_percent ) {
+ my $error = "$Side: $quota_percent % full: it is time to find a bigger place! ( $quota_current_bytes bytes / $quota_limit_bytes bytes )\n" ;
+ errors_incr( $mysync, $error ) ;
}
+ return ;
}
+sub tests_quota_extract_storage_limit_in_bytes {
+ note( 'Entering tests_quota_extract_storage_limit_in_bytes()' ) ;
+ my $imap_output = [
+ '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"',
+ '* QUOTA "Storage quota" (STORAGE 1 104857600)',
+ '* QUOTA "Messages quota" (MESSAGE 2 100000)',
+ '5 OK Getquotaroot completed.'
+ ] ;
+ ok( $NUMBER_104_857_600 * $KIBI == quota_extract_storage_limit_in_bytes( $imap_output ), 'quota_extract_storage_limit_in_bytes ') ;
+ note( 'Leaving tests_quota_extract_storage_limit_in_bytes()' ) ;
+ return ;
+}
-sub justconnect {
+sub quota_extract_storage_limit_in_bytes {
+ my $imap_output = shift ;
- $imap1 = connect_imap( $host1, $port1, $debugimap1, $ssl1, $tls1, 'Host1', $sync->{h1}->{timeout}, $sync->{h1} ) ;
- myprint( 'Host1 banner: ', $imap1->Banner( ) ) ;
- myprint( 'Host1 capability: ', join(q{ }, $imap1->capability( ) ), "\n" ) ;
- $imap2 = connect_imap( $host2, $port2, $debugimap2, $ssl2, $tls2, 'Host2', $sync->{h2}->{timeout}, $sync->{h2} ) ;
- myprint( 'Host2 banner: ', $imap2->Banner( ) ) ;
- myprint( 'Host2 capability: ', join(q{ }, $imap2->capability( ) ), "\n" ) ;
- $imap1->logout( ) ;
- $imap2->logout( ) ;
- return ;
+ my $limit_kb ;
+ $limit_kb = ( map { /.*\(\s*STORAGE\s+\d+\s+(\d+)\s*\)/x ? $1 : () } @{ $imap_output } )[0] ;
+ $limit_kb ||= 0 ;
+ $debug and myprint( "storage_limit_kb = $limit_kb\n" ) ;
+ return( $KIBI * $limit_kb ) ;
}
-sub connect_imap {
- my( $host, $port, $mydebugimap, $ssl, $tls, $Side, $mytimeout, $h ) = @_ ;
- my $imap = Mail::IMAPClient->new() ;
- if ( $ssl ) { set_ssl( $imap, $h ) }
- if ( $tls ) { $imap->Tls( 1 ) }
- $imap->Server( $host ) ;
- $imap->Port( $port ) ;
- $imap->Debug( $mydebugimap ) ;
- $imap->Timeout( $mytimeout ) ;
- $imap->connect( )
- or die_clean( "$Side: Can not open imap connection on [$host]: $@\n" ) ;
- my $banner = $imap->Results()->[0] ;
- $imap->Banner( $banner ) ;
+sub tests_quota_extract_storage_current_in_bytes {
+ note( 'Entering tests_quota_extract_storage_current_in_bytes()' ) ;
- if ( $imap->Tls( ) ) {
- set_tls( $imap, $h ) ;
- $imap->starttls( )
- or die_clean("$Side: Can not go to tls encryption on [$host]:", $imap->LastError, "\n" ) ;
- myprint( "$Side: Socket successfuly converted to SSL\n" ) ;
- }
- return( $imap ) ;
-}
+ my $imap_output = [
+ '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"',
+ '* QUOTA "Storage quota" (STORAGE 1 104857600)',
+ '* QUOTA "Messages quota" (MESSAGE 2 100000)',
+ '5 OK Getquotaroot completed.'
+ ] ;
+ ok( 1*$KIBI == quota_extract_storage_current_in_bytes( $imap_output ), 'quota_extract_storage_current_in_bytes: 1 => 1024 ') ;
-sub login_imap {
+ note( 'Leaving tests_quota_extract_storage_current_in_bytes()' ) ;
+ return ;
+}
- my @allargs = @_ ;
- my(
- $host, $port, $user, $domain, $password,
- $mydebugimap, $mytimeout, $fastio,
- $ssl, $tls, $authmech, $authuser, $reconnectretry,
- $proxyauth, $uid, $split, $Side, $h ) = @allargs ;
+sub quota_extract_storage_current_in_bytes {
+ my $imap_output = shift ;
- my $side = lc $Side ;
- myprint( "$Side: connecting and login on $side [$host] port [$port] with user [$user]\n" ) ;
+ my $current_kb ;
+ $current_kb = ( map { /.*\(\s*STORAGE\s+(\d+)\s+\d+\s*\)/x ? $1 : () } @{ $imap_output } )[0] ;
+ $current_kb ||= 0 ;
+ $debug and myprint( "storage_current_kb = $current_kb\n" ) ;
+ return( $KIBI * $current_kb ) ;
- my $imap = init_imap( @allargs ) ;
+}
- $imap->connect()
- or die_clean("$Side failure: can not open imap connection on $side [$host] with user [$user]: $@\n") ;
- my $banner = $imap->Results()->[0] ;
- $imap->Banner( $banner ) ;
- myprint( "$Side banner: $banner" ) ;
+sub automap {
+ my ( $mysync ) = @_ ;
- if ( $authmech eq 'PREAUTH' ) {
- if ( $imap->IsAuthenticated( ) ) {
- $imap->Socket ;
- myprintf("%s: Assuming PREAUTH for %s\n", $Side, $imap->Server ) ;
- }else{
- die_clean( "$Side failure: error login on $side [$host] with user [$user] auth [PREAUTH]" ) ;
- }
+ if ( $mysync->{automap} ) {
+ myprint( "Turned on automapping folders ( use --noautomap to turn off automapping )\n" ) ;
+ }else{
+ myprint( "Turned off automapping folders ( use --automap to turn on automapping )\n" ) ;
+ return ;
}
- if ( $imap->Tls( ) ) {
- set_tls( $imap, $h ) ;
- $imap->starttls( )
- or die_clean("$Side failure: Can not go to tls encryption on $side [$host]:", $imap->LastError, "\n" ) ;
- myprint( "$Side: Socket successfuly converted to SSL\n" ) ;
- }
+ $mysync->{h1_special} = special_from_folders_hash( $mysync->{imap1}, 'Host1' ) ;
+ $mysync->{h2_special} = special_from_folders_hash( $mysync->{imap2}, 'Host2' ) ;
- authenticate_imap( $imap, @allargs ) ;
+ build_possible_special( $mysync ) ;
+ build_guess_special( $mysync ) ;
+ build_automap( $mysync ) ;
- myprint( "$Side: success login on [$host] with user [$user] auth [$authmech]\n" ) ;
- return( $imap ) ;
+ return ;
}
-sub authenticate_imap {
- my($imap,
- $host, $port, $user, $domain, $password,
- $mydebugimap, $mytimeout, $fastio,
- $ssl, $tls, $authmech, $authuser, $reconnectretry,
- $proxyauth, $uid, $split, $Side, $h ) = @_ ;
- check_capability( $imap, $authmech, $Side ) ;
+sub build_guess_special {
+ my ( $mysync ) = shift ;
- if ( $proxyauth ) {
- $imap->Authmechanism(q{}) ;
- $imap->User($authuser) ;
- } else {
- $imap->Authmechanism( $authmech ) unless ( $authmech eq 'LOGIN' or $authmech eq 'PREAUTH' ) ;
- $imap->User($user) ;
+ foreach my $h1_fold ( sort keys %{ $mysync->{h1_folders_all} } ) {
+ my $special = guess_special( $h1_fold, $mysync->{possible_special}, $mysync->{h1_prefix} ) ;
+ if ( $special ) {
+ $mysync->{h1_special_guessed}{$h1_fold} = $special ;
+ my $already_guessed = $mysync->{h1_special_guessed}{$special} ;
+ if ( $already_guessed ) {
+ myprint( "Host1: $h1_fold not $special because set to $already_guessed\n" ) ;
+ }else{
+ $mysync->{h1_special_guessed}{$special} = $h1_fold ;
+ }
+ }
}
+ foreach my $h2_fold ( sort keys %{ $mysync->{h2_folders_all} } ) {
+ my $special = guess_special( $h2_fold, $mysync->{possible_special}, $mysync->{h2_prefix} ) ;
+ if ( $special ) {
+ $mysync->{h2_special_guessed}{$h2_fold} = $special ;
+ my $already_guessed = $mysync->{h2_special_guessed}{$special} ;
+ if ( $already_guessed ) {
+ myprint( "Host2: $h2_fold not $special because set to $already_guessed\n" ) ;
+ }else{
+ $mysync->{h2_special_guessed}{$special} = $h2_fold ;
+ }
+ }
+ }
+ return ;
+}
+
+sub guess_special {
+ my( $folder, $possible_special_ref, $prefix ) = @_ ;
+
+ my $folder_no_prefix = $folder ;
+ $folder_no_prefix =~ s/\Q${prefix}\E//xms ;
+ #$debug and myprint( "folder_no_prefix: $folder_no_prefix\n" ) ;
+
+ my $guess_special = $possible_special_ref->{ $folder }
+ || $possible_special_ref->{ $folder_no_prefix }
+ || q{} ;
+
+ return( $guess_special ) ;
+}
+
+sub tests_guess_special {
+ note( 'Entering tests_guess_special()' ) ;
+
+ my $possible_special_ref = build_possible_special( my $mysync ) ;
+ ok( '\Sent' eq guess_special( 'Sent', $possible_special_ref, q{} ) ,'guess_special: Sent => \Sent' ) ;
+ ok( q{} eq guess_special( 'Blabla', $possible_special_ref, q{} ) ,'guess_special: Blabla => q{}' ) ;
+ ok( '\Sent' eq guess_special( 'INBOX.Sent', $possible_special_ref, 'INBOX.' ) ,'guess_special: INBOX.Sent => \Sent' ) ;
+ ok( '\Sent' eq guess_special( 'IN BOX.Sent', $possible_special_ref, 'IN BOX.' ) ,'guess_special: IN BOX.Sent => \Sent' ) ;
+
+ note( 'Leaving tests_guess_special()' ) ;
+ return ;
+}
+
+sub build_automap {
+ my $mysync = shift ;
+ $debug and myprint( "Entering build_automap\n" ) ;
+ foreach my $h1_fold ( @{ $mysync->{h1_folders_wanted} } ) {
+ my $h2_fold ;
+ my $h1_special = $mysync->{h1_special}{$h1_fold} ;
+ my $h1_special_guessed = $mysync->{h1_special_guessed}{$h1_fold} ;
+
+ # Case 1: special on both sides.
+ if ( $h1_special
+ and exists $mysync->{h2_special}{$h1_special} ) {
+ $h2_fold = $mysync->{h2_special}{$h1_special} ;
+ $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ;
+ next ;
+ }
+ # Case 2: special on host1, not on host2
+ if ( $h1_special
+ and ( not exists $mysync->{h2_special}{$h1_special} )
+ and ( exists $mysync->{h2_special_guessed}{$h1_special} )
+ ) {
+ # special_guessed on host2
+ $h2_fold = $mysync->{h2_special_guessed}{$h1_special} ;
+ $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ;
+ next ;
+ }
+ # Case 3: no special on host1, special on host2
+ if ( ( not $h1_special )
+ and ( $h1_special_guessed )
+ and ( exists $mysync->{h2_special}{$h1_special_guessed} )
+ ) {
+ $h2_fold = $mysync->{h2_special}{$h1_special_guessed} ;
+ $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ;
+ next ;
+ }
+ # Case 4: no special on both sides.
+ if ( ( not $h1_special )
+ and ( $h1_special_guessed )
+ and ( not exists $mysync->{h2_special}{$h1_special_guessed} )
+ and ( exists $mysync->{h2_special_guessed}{$h1_special_guessed} )
+ ) {
+ $h2_fold = $mysync->{h2_special_guessed}{$h1_special_guessed} ;
+ $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ;
+ next ;
+ }
+ }
+ return( $mysync->{f1f2auto} ) ;
+}
+
+# I willll probably add what there is at:
+# http://stackoverflow.com/questions/2185391/localized-gmail-imap-folders/2185548#2185548
+sub build_possible_special {
+ my $mysync = shift ;
+ 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', '&BCcENQRABD0EPgQyBDgEOgQ4-' ] ;
+ $possible_special->{'\Flagged'} = [ 'Flagged', 'Starred', '&BB8EPgQ8BDUERwQ1BD0EPQRLBDU-' ] ;
+ $possible_special->{'\Junk'} = [ 'Junk', 'Spam', '&BCEEPwQwBDw-' ] ;
+ $possible_special->{'\Sent'} = [ 'Sent', 'Sent Messages', 'Sent Items',
+ 'Gesendete Elemente', 'Gesendete Objekte',
+ '&AMk-l&AOk-ments envoy&AOk-s', 'Envoy&AOk-', 'Objets envoy&AOk-s',
+ 'Elementos enviados',
+ '&kAFP4W4IMH8wojCkMMYw4A-',
+ '&BB4EQgQ,BEAEMAQyBDsENQQ9BD0ESwQ1-'] ;
+ $possible_special->{'\Trash'} = [ 'Trash', '&BCMENAQwBDsENQQ9BD0ESwQ1-', '&BBoEPgRABDcEOAQ9BDA-' ] ;
+
+ foreach my $special ( qw( \All \Archive \Drafts \Flagged \Junk \Sent \Trash ) ){
+ foreach my $possible_folder ( @{ $possible_special->{$special} } ) {
+ $possible_special->{ $possible_folder } = $special ;
+ } ;
+ }
+ $mysync->{possible_special} = $possible_special ;
+ $debug and myprint( Data::Dumper->Dump( [ $possible_special ], [ 'possible_special' ] ) ) ;
+ return( $possible_special ) ;
+}
+
+sub special_from_folders_hash {
+ my ( $imap, $side ) = @_ ;
+ my %special = ( ) ;
+
+ if ( ! defined $imap ) { return ; }
+ $side = defined $side ? $side : 'Host?' ;
+
+ if ( ! $imap->can( 'folders_hash' ) ) {
+ my $error = "$side: To have automagic rfc6154 folder mapping, upgrade Mail::IMAPClient >= 3.34\n" ;
+ errors_incr( $sync, $error ) ;
+ return( \%special ) ; # empty hash ref
+ }
+ my $folders_hash = $imap->folders_hash( ) ;
+ foreach my $fhash (@{ $folders_hash } ) {
+ my @special = grep { /\\(?:All|Archive|Drafts|Flagged|Junk|Sent|Trash)/x } @{ $fhash->{attrs} } ;
+ if ( @special ) {
+ my $special = $special[0] ; # keep first one. Could be not very good.
+ if ( exists $special{ $special } ) {
+ myprintf( "%s: special %-20s = %s already assigned to %s\n",
+ $side, $fhash->{name}, join( q{ }, @special ), $special{ $special } ) ;
+ }else{
+ myprintf( "%s: special %-20s = %s\n",
+ $side, $fhash->{name}, join( q{ }, @special ) ) ;
+ $special{ $special } = $fhash->{name} ;
+ $special{ $fhash->{name} } = $special ; # double entry value => key
+ }
+ }
+ }
+ myprint( "\n" ) if ( %special ) ;
+ return( \%special ) ;
+}
+
+sub tests_special_from_folders_hash {
+ note( 'Entering tests_special_from_folders_hash()' ) ;
+
+
+ require Test::MockObject ;
+ my $imapT = Test::MockObject->new( ) ;
+
+ is( undef, special_from_folders_hash( ), 'special_from_folders_hash: no args' ) ;
+ is_deeply( {}, special_from_folders_hash( $imapT ), 'special_from_folders_hash: $imap void' ) ;
+
+ $imapT->mock( 'folders_hash', sub { return( [ { name => 'Sent', attrs => [ '\Sent' ] } ] ) } ) ;
+ is_deeply( { Sent => '\Sent', '\Sent' => 'Sent' }, special_from_folders_hash( $imapT ), 'special_from_folders_hash: $imap \Sent' ) ;
+
+ note( 'Leaving tests_special_from_folders_hash()' ) ;
+ return( ) ;
+}
+
+sub errors_incr {
+ my ( $mysync, @error ) = @ARG ;
+ $sync->{nb_errors}++ ;
+
+ if ( @error ) {
+ errors_log( $mysync, @error ) ;
+ myprint( @error ) ;
+ }
+
+ $mysync->{errorsmax} ||= $ERRORS_MAX ;
+ if ( $sync->{nb_errors} >= $mysync->{errorsmax} ) {
+ myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to 100 with --errorsmax 100 ). Exiting.\n" ) ;
+ if ( $mysync->{errorsdump} ) {
+ myprint( errorsdump( $sync->{nb_errors}, errors_log( $mysync ) ) ) ;
+ # again since errorsdump( ) can be very verbose and masq previous warning
+ myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to 100 with --errorsmax 100 ). Exiting.\n" ) ;
+ }
+ exit_clean( $mysync, $EXIT_WITH_ERRORS_MAX ) ;
+ }
+ return ;
+}
+
+sub errors_log {
+ my ( $mysync, @error ) = @ARG ;
+
+ if ( ! $mysync->{errors_log} ) {
+ $mysync->{errors_log} = [] ;
+ }
+
+ if ( @error ) {
+ push @{ $mysync->{errors_log} }, join( q{}, @error ) ;
+ }
+ if ( @{ $mysync->{errors_log} } ) {
+ return @{ $mysync->{errors_log} } ;
+ }
+ else {
+ return ;
+ }
+}
+
+sub tests_errors_log {
+ note( 'Entering tests_errors_log()' ) ;
+
+
+ note( 'Leaving tests_errors_log()' ) ;
+ return ;
+}
+
+
+sub errorsdump {
+ my( $nb_errors, @errors_log ) = @ARG ;
+ my $error_num = 0 ;
+ my $errors_list = q{} ;
+ if ( @errors_log ) {
+ $errors_list = "++++ Listing $nb_errors errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n" ;
+ foreach my $error ( @errors_log ) {
+ $error_num++ ;
+ $errors_list .= "Err $error_num/$nb_errors: $error" ;
+ }
+ }
+ return( $errors_list ) ;
+}
+
+
+sub tests_live_result {
+ note( 'Entering tests_live_result()' ) ;
+
+ my $nb_errors = shift ;
+ if ( $nb_errors ) {
+ myprint( "Live tests failed with $nb_errors errors\n" ) ;
+ } else {
+ myprint( "Live tests ended successfully\n" ) ;
+ }
+ note( 'Leaving tests_live_result()' ) ;
+ return ;
+}
+
+sub foldersizesatend {
+ timenext( ) ;
+ return if ( $imap1->IsUnconnected( ) ) ;
+ return if ( $imap2->IsUnconnected( ) ) ;
+ # Get all folders on host2 again since new were created
+ @h2_folders_all = sort $imap2->folders();
+ for ( @h2_folders_all ) {
+ $h2_folders_all{ $_ } = 1 ;
+ $h2_folders_all_UPPER{ uc $_ } = 1 ;
+ } ;
+ ( $h1_nb_msg_end, $h1_bytes_end ) = foldersizes( 'Host1', $imap1, $search1, $sync->{abletosearch1}, @h1_folders_wanted ) ;
+ ( $h2_nb_msg_end, $h2_bytes_end ) = foldersizes( 'Host2', $imap2, $search2, $sync->{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( $sync, $error ) ;
+ }
+ return ;
+}
+
+sub size_filtered_flag {
+ my $h1_size = shift ;
+
+ if (defined $maxsize and $h1_size >= $maxsize) {
+ return( 1 ) ;
+ }
+ if (defined $minsize and $h1_size <= $minsize) {
+ return( 1 ) ;
+ }
+ return( 0 ) ;
+}
+
+sub sync_flags_fir {
+ my ( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ;
+
+ if ( not defined $h1_msg ) { return } ;
+ if ( not defined $h2_msg ) { return } ;
+
+ my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} ;
+ return if size_filtered_flag( $h1_size ) ;
+
+ # used cached flag values for efficiency
+ my $h1_flags = $h1_fir_ref->{ $h1_msg }->{ 'FLAGS' } || q{} ;
+ my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ 'FLAGS' } || q{} ;
+
+ sync_flags( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ;
+
+ return ;
+}
+
+sub sync_flags_after_copy {
+ my( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $permanentflags2 ) = @_ ;
+
+ my @h2_flags = $imap2->flags( $h2_msg ) ;
+ my $h2_flags = "@h2_flags" ;
+ ( $debug or $debugflags ) and myprint( "Host2 flags before resync by STORE on msg $h2_msg: $h2_flags\n" ) ;
+ sync_flags( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ;
+ return ;
+}
+
+sub sync_flags {
+ my( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) = @_ ;
+
+ ( $debug or $debugflags ) and
+ myprint( "Host1: flags init msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 $h2_fold/$h2_msg flags( $h2_flags )\n" ) ;
+
+ $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ;
+
+ $h2_flags = flagscase( $h2_flags ) ;
+
+ ( $debug or $debugflags ) and
+ myprint( "Host1 flags filt msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 $h2_fold/$h2_msg flags( $h2_flags )\n" ) ;
+
+
+ # compare flags - set flags if there a difference
+ my @h1_flags = sort split(q{ }, $h1_flags );
+ my @h2_flags = sort split(q{ }, $h2_flags );
+ my $diff = compare_lists( \@h1_flags, \@h2_flags );
+
+ $diff and ( $debug or $debugflags )
+ and myprint( "Host2 flags msg $h2_fold/$h2_msg replacing h2 flags( $h2_flags ) with h1 flags( $h1_flags )\n" ) ;
+ # This sets flags so flags can be removed with this
+ # When you remove a \Seen flag on host1 you want to it
+ # to be removed on host2. Just add flags is not what
+ # we need most of the time.
+
+ if ( not $sync->{dry} and $diff and not $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]: ",
+ $imap2->LastError || q{}, "\n" ;
+ errors_incr( $sync, $error_msg ) ;
+ }
+
+ return ;
+}
+
+
+
+sub _filter {
+ my $str = shift or return q{} ;
+ my $sz = $SIZE_MAX_STR ;
+ my $len = length $str ;
+ if ( not $debug and $len > $sz*2 ) {
+ my $beg = substr $str, 0, $sz ;
+ my $end = substr $str, -$sz, $sz ;
+ $str = $beg . '...' . $end ;
+ }
+ $str =~ s/\012?\015$//x ;
+ return "(len=$len) " . $str ;
+}
+
+
+
+sub lost_connection {
+ my( $imap, $error_message ) = @_;
+ if ( $imap->IsUnconnected( ) ) {
+ $sync->{nb_errors}++ ;
+ my $lcomm = $imap->LastIMAPCommand || q{} ;
+ my $einfo = $imap->LastError || @{$imap->History}[$LAST] || q{} ;
+
+ # if string is long try reduce to a more reasonable size
+ $lcomm = _filter( $lcomm ) ;
+ $einfo = _filter( $einfo ) ;
+ myprint( "Failure: last command: $lcomm\n") if ($debug && $lcomm) ;
+ myprint( "Failure: lost connection $error_message: ", $einfo, "\n") ;
+ return( 1 ) ;
+ }
+ else{
+ return( 0 ) ;
+ }
+}
+
+sub max {
+ my @list = @_ ;
+ return( undef ) if ( 0 == scalar @list ) ;
+
+ no warnings 'numeric' ;
+ no warnings 'uninitialized' ;
+
+ my @sorted = sort { $a <=> $b || $a cmp $b } @list ;
+ return( pop @sorted ) ;
+}
+
+sub tests_max {
+ note( 'Entering tests_max()' ) ;
+ is( 0, max( 0 ), 'max 0 => 0' ) ;
+ is( 1, max( 1 ), 'max 1 => 1' ) ;
+ is( $MINUS_ONE, max( $MINUS_ONE ), 'max -1 => -1') ;
+ is( undef, max( ), 'max no arg => undef' ) ;
+ is( $NUMBER_100, max( 1, $NUMBER_100 ), 'max 1 100 => 100' ) ;
+ is( $NUMBER_100, max( $NUMBER_100, 1 ), 'max 100 1 => 100' ) ;
+ is( $NUMBER_100, max( $NUMBER_100, $NUMBER_42, 1 ), 'max 100 42 1 => 100' ) ;
+ is( $NUMBER_100, max( $NUMBER_100, '42', 1 ), 'max 100 42 1 => 100' ) ;
+ is( $NUMBER_100, max( '100', '42', 1 ), 'max 100 42 1 => 100' ) ;
+ is( $NUMBER_100, max( $NUMBER_100, 'haha', 1 ), 'max 100 haha 1 => 100') ;
+ is( 1, max( $MINUS_ONE, 1 ), 'max -1 1 => 1') ;
+ is( 1, max( undef, 1 ), 'max undef 1 => 1' ) ;
+ is( 0, max( undef, 0 ), 'max undef 0 => 0' ) ;
+ is( 'haha', max( 'haha' ), 'max haha => haha') ;
+ is( 'bb', max( 'aa', 'bb' ), 'max aa bb => bb') ;
+ is( 'bb', max( 'bb', 'aa' ), 'max bb aa bb => bb') ;
+ is( 'bb', max( 'bb', 'aa', 'bb' ), 'max bb aa bb => bb') ;
+ note( 'Leaving tests_max()' ) ;
+ return ;
+}
+
+sub min {
+ my @list = @_ ;
+ return( undef ) if ( 0 == scalar @list ) ;
+ no warnings 'numeric' ;
+ no warnings 'uninitialized' ;
+ my @sorted = sort { $a <=> $b || $a cmp $b } @list ;
+ return( shift @sorted ) ;
+}
+
+sub tests_min {
+ note( 'Entering tests_min()' ) ;
+
+ is( 0, min( 0 ), 'min 0 => 0' ) ;
+ is( 1, min( 1 ), 'min 1 => 1' ) ;
+ is( $MINUS_ONE, min( $MINUS_ONE ), 'min -1 => -1' ) ;
+ is( undef, min( ), 'min no arg => undef' ) ;
+ is( 1, min( 1, $NUMBER_100 ), 'min 1 100 => 1' ) ;
+ is( 1, min( $NUMBER_100, 1 ), 'min 100 1 => 1' ) ;
+ is( 1, min( $NUMBER_100, $NUMBER_42, 1 ), 'min 100 42 1 => 1' ) ;
+ is( 1, min( $NUMBER_100, '42', 1 ), 'min 100 42 1 => 1' ) ;
+ is( 1, min( '100', '42', 1 ), 'min 100 42 1 => 1' ) ;
+ is( 'haha', min( 100, 'haha', 1 ), 'min 100 haha 1 => haha') ;
+ is( $MINUS_ONE, min( $MINUS_ONE, 1 ), 'min -1 1 => -1') ;
+
+ is( undef, min( undef, 1 ), 'min undef 1 => undef' ) ;
+ is( undef, min( undef, 0 ), 'min undef 0 => undef' ) ;
+
+ is( 'haha', min( 'haha' ), 'min haha => haha') ;
+ is( 'aa', min( 'aa', 'bb' ), 'min aa bb => aa') ;
+ is( 'aa', min( 'bb', 'aa' ), 'min bb aa bb => aa') ;
+ is( 'aa', min( 'bb', 'aa', 'bb' ), 'min bb aa bb => aa') ;
+
+ note( 'Leaving tests_min()' ) ;
+ return ;
+}
+
+
+sub check_lib_version {
+ $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" ) ;
+ return 0 ;
+ }
+ else{
+ # 3.x.x is no longer buggy with imapsync.
+ # 3.30 or currently superior is imposed in the Perl "use Mail::IMAPClient line".
+ return 1 ;
+ }
+ return ;
+}
+
+sub module_version_str {
+ my( $module_name, $module_version ) = @_ ;
+ my $str = mysprintf( "%-20s %s\n", $module_name, $module_version ) ;
+ return( $str ) ;
+}
+
+sub modulesversion {
+
+ my @list_version;
+
+ my %modulesversion = (
+ 'Authen::NTLM' => sub { $Authen::NTLM::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 },
+ 'File::Copy::Recursive' => sub { $File::Copy::Recursive::VERSION },
+ 'File::Spec' => sub { $File::Spec::VERSION },
+ 'Getopt::Long' => sub { $Getopt::Long::VERSION },
+ 'HTML::Entities' => sub { $HTML::Entities::VERSION },
+ 'IO::Socket::INET6' => sub { $IO::Socket::INET6::VERSION },
+ 'IO::Socket::INET' => sub { $IO::Socket::INET::VERSION },
+ 'IO::Socket::SSL' => sub { $IO::Socket::SSL::VERSION },
+ 'IO::Socket' => sub { $IO::Socket::VERSION },
+ 'IO::Tee' => sub { $IO::Tee::VERSION },
+ 'JSON' => sub { $JSON::VERSION },
+ 'JSON::WebToken' => sub { $JSON::WebToken::VERSION },
+ 'LWP' => sub { $LWP::VERSION },
+ 'Mail::IMAPClient' => sub { $Mail::IMAPClient::VERSION },
+ 'Net::Ping' => sub { $Net::Ping::VERSION },
+ 'Net::SSLeay' => sub { $Net::SSLeay::VERSION },
+ 'Term::ReadKey' => sub { $Term::ReadKey::VERSION },
+ '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 },
+ ) ;
+
+ foreach my $module_name ( sort keys %modulesversion ) {
+ # trick from http://www.perlmonks.org/?node_id=152122
+ my $file_name = $module_name . '.pm' ;
+ $file_name =~s,::,/,xmgs; # Foo::Bar::Baz => Foo/Bar/Baz.pm
+ my $v ;
+ eval {
+ require $file_name ;
+ $v = defined $modulesversion{ $module_name } ? $modulesversion{ $module_name }->() : q{?} ;
+ } or $v = q{Not installed} ;
+
+ push @list_version, module_version_str( $module_name, $v ) ;
+ }
+
+ return( @list_version ) ;
+}
+
+
+# Construct a command line copy with passwords replaced by MASKED.
+sub command_line_nopassword {
+ my @argv = @_ ;
+ my @argv_nopassword ;
+
+ return( "@argv" ) if $sync->{showpasswords} ;
+ while ( @argv ) {
+ my $arg = shift @argv ; # option name or value
+ if ( $arg =~ m/-password[12]/x ) {
+ shift @argv ; # password value
+ push @argv_nopassword, $arg, 'MASKED' ; # option name and fake value
+ }else{
+ push @argv_nopassword, $arg ; # same option or value
+ }
+ }
+ return("@argv_nopassword") ;
+}
+
+sub tests_command_line_nopassword {
+ note( 'Entering tests_command_line_nopassword()' ) ;
+
+ ok(q{} eq command_line_nopassword(), 'command_line_nopassword void');
+ ok('--blabla' eq command_line_nopassword('--blabla'), 'command_line_nopassword --blabla');
+ #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ;
+ ok('--password1 MASKED' eq command_line_nopassword(qw{ --password1 secret1}), 'command_line_nopassword --password1');
+ ok('--blabla --password1 MASKED --blibli'
+ eq command_line_nopassword(qw{ --blabla --password1 secret1 --blibli }), 'command_line_nopassword --password1 --blibli');
+ $sync->{showpasswords} = 1 ;
+ ok(q{} eq command_line_nopassword(), 'command_line_nopassword void');
+ ok('--blabla' eq command_line_nopassword('--blabla'), 'command_line_nopassword --blabla');
+ #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ;
+ ok('--password1 secret1' eq command_line_nopassword(qw{ --password1 secret1}), 'command_line_nopassword --password1');
+ ok('--blabla --password1 secret1 --blibli'
+ eq command_line_nopassword(qw{ --blabla --password1 secret1 --blibli }), 'command_line_nopassword --password1 --blibli');
+
+ note( 'Leaving tests_command_line_nopassword()' ) ;
+ return ;
+}
+
+sub ask_for_password {
+ my ( $user, $host ) = @ARG ;
+ myprint( "What's the password for $user" . '@' . "$host? (not visible while you type, then enter RETURN) " ) ;
+ Term::ReadKey::ReadMode( 2 ) ;
+ my $password = <STDIN> ;
+ chomp $password ;
+ myprint( "\nGot it\n" ) ;
+ Term::ReadKey::ReadMode( 0 ) ;
+ return $password ;
+}
+
+# Have to refactor get_password1() get_password2()
+# to have only get_password() and two calls
+sub get_password1 {
+
+ my $mysync = shift ;
+
+ $mysync->{password1}
+ || $passfile1
+ || 'PREAUTH' eq $authmech1
+ || 'EXTERNAL' eq $authmech1
+ || $ENV{IMAPSYNC_PASSWORD1}
+ || do {
+ myprint( << 'FIN_PASSFILE' ) ;
+
+If you are afraid of giving password on the command line arguments, you can put the
+password of user1 in a file named file1 and use "--passfile1 file1" instead of typing it.
+Then give this file restrictive permissions with the command "chmod 600 file1".
+An other solution is to set the environment variable IMAPSYNC_PASSWORD1
+FIN_PASSFILE
+
+ $mysync->{password1} = ask_for_password( $authuser1 || $mysync->{user1}, $mysync->{host1} ) ;
+ } ;
+
+ if ( defined $passfile1 ) {
+ if ( ! -e -r $passfile1 ) {
+ myprint( "Failure: file from parameter --passfile1 $passfile1 does not exist or is not readable\n" ) ;
+ exit_clean( $mysync, $EX_NOINPUT ) ;
+ }
+ # passfile1 readable
+ $mysync->{password1} = firstline ( $passfile1 ) ;
+ return ;
+ }
+ if ( $ENV{IMAPSYNC_PASSWORD1} ) {
+ $mysync->{password1} = $ENV{IMAPSYNC_PASSWORD1} ;
+ return ;
+ }
+ return ;
+}
+
+sub get_password2 {
+
+ my $mysync = shift ;
+
+ $mysync->{password2}
+ || $passfile2
+ || 'PREAUTH' eq $authmech2
+ || 'EXTERNAL' eq $authmech2
+ || $ENV{IMAPSYNC_PASSWORD2}
+ || do {
+ myprint( << 'FIN_PASSFILE' ) ;
+
+If you are afraid of giving password on the command line arguments, you can put the
+password of user2 in a file named file2 and use "--passfile2 file2" instead of typing it.
+Then give this file restrictive permissions with the command "chmod 600 file2".
+An other solution is to set the environment variable IMAPSYNC_PASSWORD2
+FIN_PASSFILE
+
+ $mysync->{password2} = ask_for_password( $authuser2 || $mysync->{user2}, $mysync->{host2} ) ;
+ } ;
+
+
+ if ( defined $passfile2 ) {
+ if ( ! -e -r $passfile2 ) {
+ myprint( "Failure: file from parameter --passfile2 $passfile2 does not exist or is not readable\n" ) ;
+ exit_clean( $mysync, $EX_NOINPUT ) ;
+ }
+ # passfile2 readable
+ $mysync->{password2} = firstline ( $passfile2 ) ;
+ return ;
+ }
+ if ( $ENV{IMAPSYNC_PASSWORD2} ) {
+ $mysync->{password2} = $ENV{IMAPSYNC_PASSWORD2} ;
+ return ;
+ }
+ return ;
+}
+
+
+
+
+
+sub catch_exit {
+ my $mysync = shift ;
+ my $signame = shift ;
+ if ( $signame ) {
+ myprint( "\nGot a signal $signame\n" ) ;
+ }
+ stats( $mysync ) ;
+ myprint( "Ended by a signal\n" ) ;
+ exit_clean( $mysync, $EXIT_BY_SIGNAL ) ;
+ return ;
+}
+
+sub catch_reconnect {
+ my $mysync = shift ;
+ my $signame = shift ;
+ myprint( "\nGot a signal $signame\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",
+ ) ;
+ if ( here_twice( $mysync ) ) {
+ myprint( "Got two signals $signame within $INTERVAL_TO_EXIT seconds. Exiting...\n" ) ;
+ catch_exit( $mysync ) ;
+ }
+ else{
+ myprint( "For now only one signal $signame within $INTERVAL_TO_EXIT seconds.\n" ) ;
+ }
+
+ if ( ! defined $mysync->{imap1} ) { return ; }
+ if ( ! defined $mysync->{imap2} ) { return ; }
+
+
+ myprint( "Info: reconnecting to host1 imap server\n" ) ;
+ $mysync->{imap1}->State( Mail::IMAPClient::Unconnected ) ;
+ $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT} += 1 ;
+ $mysync->{imap1}->reconnect( ) ;
+ myprint( "Info: reconnecting to host2 imap server\n" ) ;
+ $mysync->{imap2}->State( Mail::IMAPClient::Unconnected ) ;
+ $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT} += 1 ;
+ $mysync->{imap2}->reconnect( ) ;
+ myprint( "Info: reconnected to both imap servers\n" ) ;
+ return ;
+}
+
+sub tests_reconnect_12_if_needed {
+ note( 'Entering 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' ) ;
+ 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' ) ;
+
+ note( 'Leaving tests_reconnect_12_if_needed()' ) ;
+ return ;
+}
+
+sub reconnect_12_if_needed {
+ my $mysync = shift ;
+ #return 2 ;
+ if ( ! reconnect_if_needed( $mysync->{imap1} ) ) {
+ return ;
+ }
+ if ( ! reconnect_if_needed( $mysync->{imap2} ) ) {
+ return ;
+ }
+ # both were good
+ return 2 ;
+}
+
+
+sub tests_reconnect_if_needed {
+ note( 'Entering tests_reconnect_if_needed()' ) ;
+
+
+ my $myimap ;
+
+ is( undef, reconnect_if_needed( ), 'reconnect_if_needed: no args => undef' ) ;
+ is( undef, reconnect_if_needed( $myimap ), 'reconnect_if_needed: undef arg => undef' ) ;
+
+ $myimap = Mail::IMAPClient->new( ) ;
+ $myimap->Debug( 1 ) ;
+ is( undef, reconnect_if_needed( $myimap ), 'reconnect_if_needed: empty new Mail::IMAPClient => undef' ) ;
+ $myimap->Server( 'test.lamiral.info' ) ;
+ is( 1, reconnect_if_needed( $myimap ), 'reconnect_if_needed: test.lamiral.info => 1' ) ;
+ is( 1, $myimap->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_if_needed: test.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ;
+
+ note( 'Leaving tests_reconnect_if_needed()' ) ;
+ return ;
+}
+
+sub reconnect_if_needed {
+ # return undef upon failure.
+ # return 1 upon connection success, with or without reconnection.
+
+ my $imap = shift ;
+
+ if ( ! defined $imap ) { return ; }
+ if ( ! $imap->Server( ) ) { return ; }
+
+ if ( $imap->IsUnconnected( ) ) {
+ $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ;
+ if ( $imap->reconnect( ) ) {
+ return 1 ;
+ }
+ }else{
+ return 1 ;
+ }
+
+ # A last forced one
+ $imap->State( Mail::IMAPClient::Unconnected ) ;
+ $imap->reconnect( ) ;
+ $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ;
+ if ( $imap->noop ) {
+ # NOOP is ok
+ return 1 ;
+ }
+
+ return ;
+}
+
+
+
+sub here_twice {
+ my $mysync = shift ;
+ my $now = time ;
+ my $previous = $mysync->{lastcatch} || 0 ;
+ $mysync->{lastcatch} = $now ;
+
+ if ( $INTERVAL_TO_EXIT >= $now - $previous ) {
+ return $TRUE ;
+ }else{
+ return $FALSE ;
+ }
+}
+
+
+sub justconnect {
+
+ $imap1 = connect_imap( $sync->{host1}, $sync->{port1}, $debugimap1, $sync->{ssl1}, $sync->{tls1}, 'Host1', $sync->{h1}->{timeout}, $sync->{h1} ) ;
+ $imap2 = connect_imap( $sync->{host2}, $sync->{port2}, $debugimap2, $sync->{ssl2}, $sync->{tls2}, 'Host2', $sync->{h2}->{timeout}, $sync->{h2} ) ;
+ $imap1->logout( ) ;
+ $imap2->logout( ) ;
+ return ;
+}
+
+
+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' ) ;
+ SKIP: {
+
+ if ( 'macosx' eq hostname() ) { skip( 'Tests avoided on macosx get stuck', 1 ) ; }
+ is( undef, $imap->connect( ), '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( 3, $imap->Timeout( 3 ), 'mailimapclient_connect ipv4: setting Timout( 30 )' ) ;
+ like( ref( $imap->connect( ) ), qr/IO::Socket::INET/, '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' ) ;
+
+ # 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 ] ), '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' ) ;
+ is( $imap->logout( ), undef, 'mailimapclient_connect ipv4 + ssl: logout in ssl causes failure' ) ;
+ is( undef, undef $imap, 'mailimapclient_connect ipv4 + ssl: free variable' ) ;
+
+ # ipv6 + ssl
+ ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv6 + ssl: new' ) ;
+ is( 'ks2ipv6.lamiral.info', $imap->Server( 'ks2ipv6.lamiral.info' ), 'mailimapclient_connect ipv6 + ssl: setting Server(ks2ipv6.lamiral.info)' ) ;
+ ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE ] ), 'mailimapclient_connect ipv6 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ;
+ is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv6 + ssl: setting Port( 993 )' ) ;
+ SKIP: {
+ if ( 'CUILLERE' eq hostname() ) { skip( 'Tests avoided on CUILLERE can not do ipv6', 2 ) ; }
+ like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv6 + ssl: connect to ks2ipv6.lamiral.info' ) ;
+ is( $imap->logout( ), undef, 'mailimapclient_connect ipv6 + ssl: logout in ssl causes failure' ) ;
+ }
+ is( undef, undef $imap, 'mailimapclient_connect ipv6 + ssl: free variable' ) ;
+
+
+ note( 'Leaving tests_mailimapclient_connect()' ) ;
+ return ;
+}
+
+sub tests_mailimapclient_connect_bug {
+ note( 'Entering tests_mailimapclient_connect_bug()' ) ;
+ my $imap ;
+
+ # ipv6
+ ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv6: new' ) ;
+ is( 'ks2ipv6.lamiral.info', $imap->Server( 'ks2ipv6.lamiral.info' ), 'mailimapclient_connect ipv6: setting Server(ks2ipv6.lamiral.info)' ) ;
+ is( 143, $imap->Port( 143 ), 'mailimapclient_connect ipv6: setting Port( 993 )' ) ;
+
+ SKIP: {
+ if ( 'CUILLERE' eq hostname() ) { skip( 'Tests avoided on CUILLERE can not do ipv6', 1 ) ; }
+ like( ref( $imap->connect( ) ), qr/IO::Socket::INET/, 'mailimapclient_connect ipv6: connect to ks2ipv6.lamiral.info' )
+ or diag( 'mailimapclient_connect ipv6: ', $imap->LastError( ), $!, ) ;
+ }
+ #is( $imap->logout( ), undef, 'mailimapclient_connect ipv6: logout in ssl causes failure' ) ;
+ is( undef, undef $imap, 'mailimapclient_connect ipv6: free variable' ) ;
+
+ note( 'Leaving tests_mailimapclient_connect_bug()' ) ;
+ return ;
+}
+
+sub mailimapclient_connect {
+
+
+ return ;
+}
+
+
+
+sub tests_connect_socket {
+ note( 'Entering tests_connect_socket()' ) ;
+
+ is( undef, connect_socket( ), 'connect_socket: no args' ) ;
+
+ my $socket ;
+ my $imap ;
+ SKIP: {
+ if ( 'CUILLERE' eq hostname() ) { skip( 'Tests avoided on CUILLERE cannot do ipv6', 2 ) ; }
+
+ $socket = IO::Socket::INET6->new(
+ PeerAddr => 'ks2ipv6.lamiral.info',
+ PeerPort => 143,
+ ) ;
+
+
+ ok( $imap = connect_socket( $socket ), 'connect_socket: ks2ipv6.lamiral.info port 143 IO::Socket::INET6' ) ;
+ #$imap->Debug( 1 ) ;
+ #print $imap->capability( ) ;
+ if ( $imap ) {
+ $imap->logout( ) ;
+ }
+
+ #$IO::Socket::SSL::DEBUG = 4 ;
+ $socket = IO::Socket::SSL->new(
+ PeerHost => 'ks2ipv6.lamiral.info',
+ PeerPort => 993,
+ SSL_verify_mode => SSL_VERIFY_NONE,
+ ) ;
+ #print $socket ;
+ ok( $imap = connect_socket( $socket ), 'connect_socket: ks2ipv6.lamiral.info port 993 IO::Socket::SSL' ) ;
+ #$imap->Debug( 1 ) ;
+ #print $imap->capability( ) ;
+ $socket->close( ) ;
+ if ( $imap ) {
+ $socket->close( ) ;
+ }
+ #$socket->close(SSL_no_shutdown => 1) ;
+ #$imap->logout( ) ;
+ #print "\n" ;
+ #$imap->logout( ) ;
+ }
+
+ note( 'Leaving tests_connect_socket()' ) ;
+ return ;
+}
+
+sub connect_socket {
+ my( $socket ) = @ARG ;
+
+ if ( ! defined $socket ) { return ; }
+
+ my $host = $socket->peerhost( ) ;
+ my $port = $socket->peerport( ) ;
+ #print "socket->peerhost: ", $socket->peerhost( ), "\n" ;
+ #print "socket->peerport: ", $socket->peerport( ), "\n" ;
+ my $imap = Mail::IMAPClient->new( ) ;
+ $imap->Socket( $socket ) ;
+ my $banner = $imap->Results()->[0] ;
+ #myprint( "banner: $banner" ) ;
+ return $imap ;
+}
+
+
+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' ) ;
+
+ SKIP: {
+ if ( 'CUILLERE' eq hostname() ) { skip( 'Tests avoided on CUILLERE cannot do ipv6', 1 ) ; }
+ like( probe_imapssl( 'ks2ipv6.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: ks2ipv6.lamiral.info matches "* OK"' ) ;
+ } ;
+
+ like( probe_imapssl( 'test1.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: test1.lamiral.info matches "* OK"' ) ;
+ like( probe_imapssl( 'imap.gmail.com' ), qr/^\* OK/, 'probe_imapssl: imap.gmail.com matches "* OK"' ) ;
+
+ note( 'Leaving tests_probe_imapssl()' ) ;
+ return ;
+}
+
+sub probe_imapssl {
+ my $host = shift ;
+
+ if ( ! $host ) { return ; }
+
+ my $socket = IO::Socket::SSL->new(
+ PeerHost => $host,
+ PeerPort => $IMAP_SSL_PORT,
+ SSL_verify_mode => SSL_VERIFY_NONE,
+ ) ;
+ #print "$socket\n" ;
+ if ( ! $socket ) { return ; }
+
+ my $banner ;
+ $socket->sysread( $banner, 65_536 ) ;
+ #print "$banner" ;
+ $socket->close( ) ;
+ return $banner ;
+
+}
+
+sub connect_imap {
+ my( $host, $port, $mydebugimap, $ssl, $tls, $Side, $mytimeout, $h ) = @_ ;
+ my $imap = Mail::IMAPClient->new( ) ;
+ if ( $ssl ) { set_ssl( $imap, $h ) }
+ $imap->Server( $host ) ;
+ $imap->Port( $port ) ;
+ $imap->Debug( $mydebugimap ) ;
+ $imap->Timeout( $mytimeout ) ;
+
+ my $side = lc $Side ;
+ myprint( "$Side: connecting on $side [$host] port [$port]\n" ) ;
+
+ $imap->connect( )
+ or die_clean( "$Side: Can not open imap connection on [$host]: " . $imap->LastError . " $OS_ERROR\n" ) ;
+ myprint( "$Side IP address: ", $imap->Socket->peerhost(), "\n" ) ;
+ my $banner = $imap->Results()->[0] ;
+
+ myprint( "$Side banner: $banner" ) ;
+ myprint( "$Side capability: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ;
+
+ if ( $tls ) {
+ set_tls( $imap, $h ) ;
+ $imap->starttls( )
+ or die_clean("$Side: Can not go to tls encryption on $side [$host]:", $imap->LastError, "\n" ) ;
+ myprint( "$Side: Socket successfuly converted to SSL\n" ) ;
+ }
+ return( $imap ) ;
+}
+
+
+sub login_imap {
+
+ my @allargs = @_ ;
+ my(
+ $host, $port, $user, $domain, $password,
+ $mydebugimap, $mytimeout, $fastio,
+ $ssl, $tls, $authmech, $authuser, $reconnectretry,
+ $proxyauth, $uid, $split, $Side, $h, $mysync ) = @allargs ;
+
+ my $side = lc $Side ;
+ myprint( "$Side: connecting and login on $side [$host] port [$port] with user [$user]\n" ) ;
+
+ my $imap = init_imap( @allargs ) ;
+
+ $imap->connect()
+ or die_clean("$Side failure: can not open imap connection on $side [$host] with user [$user]: " . $imap->LastError . " $OS_ERROR\n" ) ;
+ myprint( "$Side IP address: ", $imap->Socket->peerhost(), "\n" ) ;
+ my $banner = $imap->Results()->[0] ;
+
+ myprint( "$Side banner: $banner" ) ;
+ myprint( "$Side capability before authentication: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ;
+
+ if ( (! $ssl) and (! defined $tls ) and $imap->has_capability( 'STARTTLS' ) ) {
+ myprint( "$Side: going to ssl because STARTTLS is in CAPABILITY. Use --notls1 or --notls2 to avoid that behavior\n" ) ;
+ $tls = 1 ;
+ }
+
+ if ( $authmech eq 'PREAUTH' ) {
+ if ( $imap->IsAuthenticated( ) ) {
+ $imap->Socket ;
+ myprintf("%s: Assuming PREAUTH for %s\n", $Side, $imap->Server ) ;
+ }else{
+ die_clean( "$Side failure: error login on $side [$host] with user [$user] auth [PREAUTH]" ) ;
+ }
+ }
+
+ if ( $tls ) {
+ set_tls( $imap, $h ) ;
+ $imap->starttls( )
+ or die_clean("$Side failure: Can not go to tls encryption on $side [$host]:", $imap->LastError, "\n" ) ;
+ myprint( "$Side: Socket successfuly converted to SSL\n" ) ;
+ }
+
+ authenticate_imap( $imap, @allargs ) ;
+
+ myprint( "$Side: success login on [$host] with user [$user] auth [$authmech]\n" ) ;
+ return( $imap ) ;
+}
- $imap->Authcallback(\&xoauth) if ( 'XOAUTH' eq $authmech ) ;
- $imap->Authcallback(\&xoauth2) if ( 'XOAUTH2' eq $authmech ) ;
- $imap->Authcallback(\&plainauth) if ( ( 'PLAIN' eq $authmech ) or ( 'EXTERNAL' eq $authmech ) ) ;
+
+sub authenticate_imap {
+
+ my($imap,
+ $host, $port, $user, $domain, $password,
+ $mydebugimap, $mytimeout, $fastio,
+ $ssl, $tls, $authmech, $authuser, $reconnectretry,
+ $proxyauth, $uid, $split, $Side, $h, $mysync ) = @_ ;
+
+ check_capability( $imap, $authmech, $Side ) ;
+
+ if ( $proxyauth ) {
+ $imap->Authmechanism(q{}) ;
+ $imap->User($authuser) ;
+ } else {
+ $imap->Authmechanism( $authmech ) unless ( $authmech eq 'LOGIN' or $authmech eq 'PREAUTH' ) ;
+ $imap->User($user) ;
+ }
+
+ $imap->Authcallback(\&xoauth) if ( 'XOAUTH' eq $authmech ) ;
+ $imap->Authcallback(\&xoauth2) if ( 'XOAUTH2' eq $authmech ) ;
+ $imap->Authcallback(\&plainauth) if ( ( 'PLAIN' eq $authmech ) or ( 'EXTERNAL' eq $authmech ) ) ;
$imap->Domain($domain) if (defined $domain) ;
$imap->Authuser($authuser) ;
$imap->Password($password) ;
- unless ( $authmech eq 'PREAUTH' or $imap->login( ) ) {
- my $info = "$Side failure: Error login on [$host] with user [$user] auth" ;
- my $einfo = $imap->LastError || @{$imap->History}[$LAST] ;
- chomp $einfo ;
- my $error = "$info [$authmech]: $einfo\n" ;
+ unless ( $authmech eq 'PREAUTH' or $imap->login( ) ) {
+ my $info = "$Side failure: Error login on [$host] with user [$user] auth" ;
+ my $einfo = $imap->LastError || @{$imap->History}[$LAST] ;
+ chomp $einfo ;
+ my $error = "$info [$authmech]: $einfo\n" ;
if ( $authmech eq 'LOGIN' or $imap->IsUnconnected( ) or $authuser ) {
- die_clean( $error ) ;
+ die_clean( $error ) ;
}else{
- myprint( $error ) ;
+ myprint( $error ) ;
}
- myprint( "$Side info: trying LOGIN Auth mechanism on [$host] with user [$user]\n" ) ;
- $imap->Authmechanism(q{}) ;
- $imap->login() or
- die_clean("$info [LOGIN]: ", $imap->LastError, "\n") ;
- }
+ myprint( "$Side info: trying LOGIN Auth mechanism on [$host] with user [$user]\n" ) ;
+ $imap->Authmechanism(q{}) ;
+ $imap->login() or
+ die_clean("$info [LOGIN]: ", $imap->LastError, "\n") ;
+ }
if ( $proxyauth ) {
if ( ! $imap->proxyauth( $user ) ) {
@@ -3192,41 +4168,50 @@ sub authenticate_imap {
}
}
- return ;
+ return ;
}
-sub check_capability {
+sub check_capability {
- my( $imap, $authmech, $Side ) = @_ ;
+ my( $imap, $authmech, $Side ) = @_ ;
- if ($imap->has_capability("AUTH=$authmech")
- or $imap->has_capability($authmech)
- ) {
- myprintf("%s: %s says it has CAPABILITY for AUTHENTICATE %s\n",
- $Side, $imap->Server, $authmech);
- }
- else {
- myprintf("%s: %s says it has NO CAPABILITY for AUTHENTICATE %s\n",
- $Side, $imap->Server, $authmech);
- if ($authmech eq 'PLAIN') {
- myprint( "$Side: frequently PLAIN is only supported with SSL, ",
- "try --ssl or --tls options\n" ) ;
- }
+
+ if ($imap->has_capability( "AUTH=$authmech" )
+ or $imap->has_capability( $authmech ) ) {
+ myprintf("%s: %s says it has CAPABILITY for AUTHENTICATE %s\n",
+ $Side, $imap->Server, $authmech) ;
+ return ;
+ }
+
+ if ( $authmech eq 'LOGIN' ) {
+ # Well, the warning is so common and useless that I prefer to remove it
+ # No more "... says it has NO CAPABILITY for AUTHENTICATE LOGIN"
+ return ;
}
- return ;
+
+
+ myprintf( "%s: %s says it has NO CAPABILITY for AUTHENTICATE %s\n",
+ $Side, $imap->Server, $authmech ) ;
+
+ if ($authmech eq 'PLAIN') {
+ myprint( "$Side: frequently PLAIN is only supported with SSL, try --ssl or --tls options\n" ) ;
+ }
+
+ return ;
}
sub set_ssl {
- my ( $imap, $h ) = @_ ;
+ my ( $imap, $h ) = @_ ;
# SSL_version can be
# SSLv3 SSLv2 SSLv23 SSLv23:!SSLv2 (last one is the default in IO-Socket-SSL-1.953)
#
my $sslargs_hash = $h->{sslargs} ;
- my $sslargs_default = {
- SSL_verify_mode => $DEFAULT_SSL_VERIFY,
- SSL_verifycn_scheme => 'imap',
+ my $sslargs_default = {
+ SSL_verify_mode => $DEFAULT_SSL_VERIFY,
+ SSL_verifycn_scheme => 'imap',
+ SSL_cipher_list => 'DEFAULT:!DH',
} ;
# initiate with default values
@@ -3241,16 +4226,17 @@ sub set_ssl {
my @sslargs_mix = %sslargs_mix ;
#myprint( Data::Dumper->Dump( [ $sslargs_hash, $sslargs_default, \%sslargs_mix, \@sslargs_mix ] ) ) ;
$imap->Ssl( \@sslargs_mix ) ;
- return ;
+ return ;
}
sub set_tls {
- my ( $imap, $h ) = @_ ;
+ my ( $imap, $h ) = @_ ;
my $sslargs_hash = $h->{sslargs} ;
- my $sslargs_default = {
- SSL_verify_mode => $DEFAULT_SSL_VERIFY,
+ my $sslargs_default = {
+ SSL_verify_mode => $DEFAULT_SSL_VERIFY,
+ SSL_cipher_list => 'DEFAULT:!DH',
} ;
# initiate with default values
@@ -3265,42 +4251,47 @@ sub set_tls {
my @sslargs_mix = %sslargs_mix ;
$imap->Starttls( \@sslargs_mix ) ;
- return ;
+ return ;
}
sub init_imap {
- my(
- $host, $port, $user, $domain, $password,
- $mydebugimap, $mytimeout, $fastio,
- $ssl, $tls, $authmech, $authuser, $reconnectretry,
- $proxyauth, $uid, $split, $Side, $h ) = @_ ;
+ my(
+ $host, $port, $user, $domain, $password,
+ $mydebugimap, $mytimeout, $fastio,
+ $ssl, $tls, $authmech, $authuser, $reconnectretry,
+ $proxyauth, $uid, $split, $Side, $h, $mysync ) = @_ ;
- my ( $imap ) ;
+ my ( $imap ) ;
- $imap = Mail::IMAPClient->new() ;
+ $imap = Mail::IMAPClient->new() ;
- if ( $ssl ) { set_ssl( $imap, $h ) }
- if ( $tls ) { $imap->Tls( 1 ) } # can not do set_tls() here because connect() will directly do a STARTTLS
- $imap->Clear(1);
- $imap->Server($host);
- $imap->Port($port);
- $imap->Fast_io($fastio);
- $imap->Buffer($buffersize || $DEFAULT_BUFFER_SIZE);
- $imap->Uid($uid);
+ if ( $ssl ) { set_ssl( $imap, $h ) }
+ if ( $tls ) { } # can not do set_tls() here because connect() will directly do a STARTTLS
+ $imap->Clear(1);
+ $imap->Server($host);
+ $imap->Port($port);
+ $imap->Fast_io($fastio);
+ $imap->Buffer($buffersize || $DEFAULT_BUFFER_SIZE);
+ $imap->Uid($uid);
- $imap->Peek(1);
- $imap->Debug($mydebugimap);
- defined $mytimeout and $imap->Timeout( $mytimeout ) ;
- $imap->Reconnectretry( $reconnectretry ) if ( $reconnectretry ) ;
- $imap->Ignoresizeerrors( $allowsizemismatch ) ;
- $split and $imap->Maxcommandlength( $SPLIT_FACTOR * $split ) ;
+ $imap->Peek(1);
+ $imap->Debug($mydebugimap);
+ if ( $mysync->{ showpasswords } ) {
+ $imap->Showcredentials( 1 ) ;
+ }
+ defined $mytimeout and $imap->Timeout( $mytimeout ) ;
+
+ $imap->Reconnectretry( $reconnectretry ) if ( $reconnectretry ) ;
+ $imap->{IMAPSYNC_RECONNECT_COUNT} = 0 ;
+ $imap->Ignoresizeerrors( $allowsizemismatch ) ;
+ $split and $imap->Maxcommandlength( $SPLIT_FACTOR * $split ) ;
- return( $imap ) ;
+ return( $imap ) ;
}
@@ -3341,12 +4332,12 @@ sub plainauth {
# If the password arg ends in .json, it will assume this new json method, otherwise it
# will fallback to the "oauth client id;.p12" format it was previously using.
sub xoauth2 {
- require JSON::WebToken ;
- require LWP::UserAgent ;
- require HTML::Entities ;
- require JSON ;
- require JSON::WebToken::Crypt::RSA ;
- require Crypt::OpenSSL::RSA ;
+ require JSON::WebToken ;
+ require LWP::UserAgent ;
+ require HTML::Entities ;
+ require JSON ;
+ require JSON::WebToken::Crypt::RSA ;
+ require Crypt::OpenSSL::RSA ;
require Encode::Byte ;
require IO::Socket::SSL ;
@@ -3355,11 +4346,11 @@ sub xoauth2 {
my ($iss,$key);
- if( $imap->Password =~ /^(.*\.json)$/ ) {
+ if( $imap->Password =~ /^(.*\.json)$/x ) {
my $json = JSON->new( ) ;
my $filename = $1;
$debug and myprint( "XOAUTH2 json file: $filename\n" ) ;
- open( my $FILE, '<', $filename ) or die_clean( "error [$filename]: $! " ) ;
+ open( my $FILE, '<', $filename ) or die_clean( "error [$filename]: $OS_ERROR " ) ;
my $jsonfile = $json->decode( join q{}, <$FILE> ) ;
close $FILE ;
@@ -3370,7 +4361,7 @@ sub xoauth2 {
}
else {
# Get iss (service account address), keyfile name, and keypassword if necessary
- ( $iss, my $keyfile, my $keypass ) = $imap->Password =~ /([\-\d\w\@\.]+);([a-zA-Z0-9 \_\-\.\/]+);?(.*)?/ ;
+ ( $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;
@@ -3494,211 +4485,224 @@ sub xoauth {
return encode_base64("$string", q{});
}
-sub server_banner {
- my $imap = shift;
- my $banner = $imap->Banner() || "No banner\n";
- return $banner;
- }
sub banner_imapsync {
- my @argv = @_ ;
+ my @argv = @_ ;
- my $banner_imapsync = join q{},
- q{$RCSfile: imapsync,v $ },
- q{$Revision: 1.727 $ },
- q{$Date: 2016/08/19 10:30:36 $ },
- "\n", localhost_info(), "\n",
- "Command line used:\n",
- "$0 ", command_line_nopassword( @argv ), "\n" ;
+ my $banner_imapsync = join q{},
+ q{$RCSfile: imapsync,v $ },
+ q{$Revision: 1.836 $ },
+ q{$Date: 2017/09/05 16:14:53 $ },
+ "\n", localhost_info(), "\n",
+ "Command line used:\n",
+ "$PROGRAM_NAME ", command_line_nopassword( @argv ), "\n" ;
return( $banner_imapsync ) ;
}
-sub is_valid_directory {
- my $dir = shift;
+sub do_valid_directory {
+ my $dir = shift;
- # all good => return ok.
- return( 1 ) if ( -d $dir and -r _ and -w _ ) ;
+ # all good => return ok.
+ return( 1 ) if ( -d $dir and -r _ and -w _ ) ;
- # exist but bad
- if ( -e $dir and not -d _ ) {
- myprint( "Error: $dir exists but 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 ) ;
- }
- # Trying to create it
- myprint( "Creating directory $dir\n" ) ;
- eval { mkpath( $dir ) } ;
- myprint( "$@" ) if ( $@ ) ;
- return( 1 ) if ( -d $dir and -r _ and -w _ ) ;
- return( 0 ) ;
+ # exist but bad
+ if ( -e $dir and not -d _ ) {
+ myprint( "Error: $dir exists but 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 ) ;
+ }
+ # Trying to create it
+ myprint( "Creating directory $dir\n" ) ;
+ if ( ! eval { mkpath( $dir ) } ) {
+ myprint( "$EVAL_ERROR" ) if ( $EVAL_ERROR ) ;
+ }
+ return( 1 ) if ( -d $dir and -r _ and -w _ ) ;
+ return( 0 ) ;
}
-sub tests_is_valid_directory {
- Readonly my $NB_UNIX_tests_is_valid_directory => 4 ;
- SKIP: {
- skip( 'Tests only for Unix', $NB_UNIX_tests_is_valid_directory ) if ( 'MSWin32' eq $OSNAME ) ;
- ok( 1 == is_valid_directory( '.'), 'is_valid_directory: . good' ) ;
- ok( 1 == is_valid_directory( './tmp/tests/valid/sub'), 'is_valid_directory: ./tmp/tests/valid/sub good' ) ;
- diag( 'Error / not writable is on purpose' ) ;
- ok( 0 == is_valid_directory( '/'), 'is_valid_directory: / bad' ) ;
- diag( 'Error permission denied on /noway is on purpose' ) ;
- ok( 0 == is_valid_directory( '/noway'), 'is_valid_directory: /noway bad' ) ;
- }
- return ;
+sub tests_do_valid_directory {
+ note( 'Entering tests_do_valid_directory()' ) ;
+
+ Readonly my $NB_UNIX_tests_do_valid_directory => 4 ;
+ SKIP: {
+ skip( 'Tests only for Unix', $NB_UNIX_tests_do_valid_directory ) if ( 'MSWin32' eq $OSNAME ) ;
+ ok( 1 == do_valid_directory( '.'), 'do_valid_directory: . good' ) ;
+ ok( 1 == do_valid_directory( './W/tmp/tests/valid/sub'), 'do_valid_directory: ./W/tmp/tests/valid/sub good' ) ;
+ diag( 'Error / not writable is on purpose' ) ;
+ ok( 0 == do_valid_directory( '/'), 'do_valid_directory: / bad' ) ;
+ diag( 'Error permission denied on /noway is on purpose' ) ;
+ ok( 0 == do_valid_directory( '/noway'), 'do_valid_directory: /noway bad' ) ;
+ }
+ note( 'Leaving tests_do_valid_directory()' ) ;
+ return ;
}
sub write_pidfile {
- my $pid_filename = shift ;
+ my $pid_filename = shift ;
my $lock = shift ;
-
- myprint( "PID file is $pid_filename ( to change it use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ;
- if ( -e $pid_filename and $lock ) {
- myprint( "$pid_filename already exists, another imapsync may be curently running. Aborting imapsync.\n" ) ;
+
+ myprint( "PID file is $pid_filename ( to change it use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ;
+ if ( -e $pid_filename and $lock ) {
+ myprint( "$pid_filename already exists, another imapsync may be curently running. Aborting imapsync.\n" ) ;
exit $EXIT_PID_FILE_ALREADY_EXIST ;
- }
- if ( -e $pid_filename ) {
- myprint( "$pid_filename already exists, overwriting it ( use --pidfilelocking to avoid concurrent runs )\n" ) ;
- }
+ }
+ if ( -e $pid_filename ) {
+ myprint( "$pid_filename already exists, overwriting it ( use --pidfilelocking to avoid concurrent runs )\n" ) ;
+ }
- open my $FILE_HANDLE, '>', $pid_filename
- or do {
- myprint( "Could not open $pid_filename for writing. Check permissions or disk space." ) ;
- return ;
- } ;
- myprint( "Wrinting my PID $PROCESS_ID in $pid_filename\n" ) ;
- print $FILE_HANDLE $PROCESS_ID ;
- close $FILE_HANDLE ;
+ open my $FILE_HANDLE, '>', $pid_filename
+ or do {
+ myprint( "Could not open $pid_filename for writing. Check permissions or disk space." ) ;
+ return ;
+ } ;
+ myprint( "Writing my PID $PROCESS_ID in $pid_filename\n" ) ;
+ print $FILE_HANDLE $PROCESS_ID ;
+ close $FILE_HANDLE ;
- return( $PROCESS_ID ) ;
+ return( $PROCESS_ID ) ;
}
sub remove_tmp_files {
- my $mysync = shift ;
- unlink $mysync->{pidfile} ;
- return ;
+ my $mysync = shift or return ;
+ $mysync->{pidfile} or return ;
+ if ( -e $mysync->{pidfile} ) {
+ unlink $mysync->{pidfile} ;
+ }
+ return ;
}
sub exit_clean {
my $mysync = shift ;
- my $status = shift ;
- $status = defined $status ? $status : $EXIT_UNKNOWN ;
+ my $status = shift ;
+ $status = defined $status ? $status : $EXIT_UNKNOWN ;
remove_tmp_files( $mysync ) ;
myprint( "Exiting with return value $status\n" ) ;
if ( $mysync->{log} ) {
myprint( "Log file is $mysync->{logfile} ( to change it, use --logfile filepath ; or use --nolog to turn off logging )\n" ) ;
close $mysync->{logfile_handle} ;
}
- exit $status ;
+ exit $status ;
}
sub die_clean {
- my @messages = @_ ;
+ my @messages = @_ ;
remove_tmp_files( $sync ) ;
- die @messages ;
+ myprint( @messages ) ;
+ exit 255 ;
}
sub missing_option {
- my ( $option ) = @_ ;
- die_clean( "$option option is mandatory, for help run $0 --help\n" ) ;
- return ;
+ my ( $option ) = @_ ;
+ die_clean( "$option option is mandatory, for help run $PROGRAM_NAME --help\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 ; } ;
- } ;
+ 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 ) ;
- $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' ) ;
+ my( $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' ) ;
+ $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' ) ;
- $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' ) ;
+ $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' ) ;
- $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' ) ;
+ $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' ) ;
- $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' ) ;
+ $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' ) ;
- $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' ) ;
+ $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' ) ;
- return ;
+ $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' ) ;
+
+ note( 'Leaving tests_fix_Inbox_INBOX_mapping()' ) ;
+ return ;
}
sub jux_utf8_list {
- my @s_inp = @_ ;
- my $s_out = q{} ;
- foreach my $s ( @s_inp ) {
- $s_out .= jux_utf8( $s ) . "\n" ;
- }
- return( $s_out ) ;
+ my @s_inp = @_ ;
+ my $s_out = q{} ;
+ foreach my $s ( @s_inp ) {
+ $s_out .= jux_utf8( $s ) . "\n" ;
+ }
+ return( $s_out ) ;
}
sub tests_jux_utf8_list {
- ok( q{} eq jux_utf8_list( ), 'jux_utf8_list: void' ) ;
- ok( "[]\n" eq jux_utf8_list( q{} ), 'jux_utf8_list: empty string' ) ;
- ok( "[INBOX]\n" eq jux_utf8_list( 'INBOX' ), 'jux_utf8_list: INBOX' ) ;
- ok( "[&ANY-] = [Ö]\n" eq jux_utf8_list( '&ANY-' ), 'jux_utf8_list: &ANY-' ) ;
- return( 0 ) ;
+ note( 'Entering tests_jux_utf8_list()' ) ;
+
+ ok( q{} eq jux_utf8_list( ), 'jux_utf8_list: void' ) ;
+ ok( "[]\n" eq jux_utf8_list( q{} ), 'jux_utf8_list: empty string' ) ;
+ ok( "[INBOX]\n" eq jux_utf8_list( 'INBOX' ), 'jux_utf8_list: INBOX' ) ;
+ ok( "[&ANY-] = [Ö]\n" eq jux_utf8_list( '&ANY-' ), 'jux_utf8_list: &ANY-' ) ;
+
+ note( 'Leaving tests_jux_utf8_list()' ) ;
+ return( 0 ) ;
}
sub jux_utf8 {
- # juxtapose utf8 at the right if different
+ # juxtapose utf8 at the right if different
my ( $s_utf7 ) = shift ;
my ( $s_utf8 ) = imap_utf7_decode( $s_utf7 ) ;
if ( $s_utf7 eq $s_utf8 ) {
- #myprint( "[$s_utf7]\n" ) ;
- return( "[$s_utf7]" ) ;
+ #myprint( "[$s_utf7]\n" ) ;
+ return( "[$s_utf7]" ) ;
}else{
- #myprint( "[$s_utf7] = [$s_utf8]\n" ) ;
- return( "[$s_utf7] = [$s_utf8]" ) ;
+ #myprint( "[$s_utf7] = [$s_utf8]\n" ) ;
+ return( "[$s_utf7] = [$s_utf8]" ) ;
}
}
# editing utf8 can be tricky without an utf8 editor
sub tests_jux_utf8 {
- ok( '[INBOX]' eq jux_utf8( 'INBOX'), 'jux_utf8: INBOX => [INBOX]' ) ;
- ok( '[&ZTZO9nux-] = [收件箱]' eq jux_utf8( '&ZTZO9nux-'), 'jux_utf8: => [&ZTZO9nux-] = [收件箱]' ) ;
- ok( '[&ANY-] = [Ö]' eq jux_utf8( '&ANY-'), 'jux_utf8: &ANY- => [&ANY-] = [Ö]' ) ;
+ note( 'Entering tests_jux_utf8()' ) ;
+
+ ok( '[INBOX]' eq jux_utf8( 'INBOX'), 'jux_utf8: INBOX => [INBOX]' ) ;
+ ok( '[&ZTZO9nux-] = [收件箱]' eq jux_utf8( '&ZTZO9nux-'), 'jux_utf8: => [&ZTZO9nux-] = [收件箱]' ) ;
+ ok( '[&ANY-] = [Ö]' eq jux_utf8( '&ANY-'), 'jux_utf8: &ANY- => [&ANY-] = [Ö]' ) ;
ok( '[]' eq jux_utf8( q{} ), 'jux_utf8: void => []' ) ;
ok( '[+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' eq jux_utf8( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8: => [+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' ) ;
ok( '[&BB8EQAQ+BDUEOgRC-] = [Проект]' eq jux_utf8( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ;
- return( 0 ) ;
+ note( 'Leaving tests_jux_utf8()' ) ;
+ return ;
}
# Copied from http://cpansearch.perl.org/src/FABPOT/Unicode-IMAPUtf7-2.01/lib/Unicode/IMAPUtf7.pm
@@ -3711,64 +4715,64 @@ sub imap_utf7_decode {
# On remplace , par / dans les BASE 64 (, entre & et -)
# On remplace les &, non suivi d'un - par +
# On remplace les &- par &
- $s =~ s/&([^,&\-]*),([^,\-&]*)\-/&$1\/$2\-/g ;
- $s =~ s/&(?!\-)/\+/g ;
- $s =~ s/&\-/&/g ;
+ $s =~ s/&([^,&\-]*),([^,\-&]*)\-/&$1\/$2\-/xg ;
+ $s =~ s/&(?!\-)/\+/xg ;
+ $s =~ s/&\-/&/xg ;
return( Unicode::String::utf7( $s )->utf8 ) ;
}
sub imap_utf7_encode {
- my ( $s ) = @_ ;
+ my ( $s ) = @_ ;
- $s = Unicode::String::utf8( $s )->utf7 ;
+ $s = Unicode::String::utf8( $s )->utf7 ;
- $s =~ s/\+([^\/&\-]*)\/([^\/\-&]*)\-/\+$1,$2\-/g ;
- $s =~ s/&/&\-/g ;
- $s =~ s/\+([^+\-]+)?\-/&$1\-/g ;
- return( $s ) ;
+ $s =~ s/\+([^\/&\-]*)\/([^\/\-&]*)\-/\+$1,$2\-/xg ;
+ $s =~ s/&/&\-/xg ;
+ $s =~ s/\+([^+\-]+)?\-/&$1\-/xg ;
+ return( $s ) ;
}
sub select_folder {
- my ( $imap, $folder, $hostside ) = @_ ;
- if ( ! $imap->select( $folder ) ) {
- my $error = join q{},
- "$hostside folder $folder: Could not select: ",
- $imap->LastError, "\n" ;
- errors_incr( $sync, $error ) ;
- return( 0 ) ;
- }else{
- # ok select succeeded
- return( 1 ) ;
- }
+ my ( $imap, $folder, $hostside ) = @_ ;
+ if ( ! $imap->select( $folder ) ) {
+ my $error = join q{},
+ "$hostside folder $folder: Could not select: ",
+ $imap->LastError, "\n" ;
+ errors_incr( $sync, $error ) ;
+ return( 0 ) ;
+ }else{
+ # ok select succeeded
+ return( 1 ) ;
+ }
}
sub examine_folder {
- my ( $imap, $folder, $hostside ) = @_ ;
- if ( ! $imap->examine( $folder ) ) {
- my $error = join q{},
- "$hostside folder $folder: Could not examine: ",
- $imap->LastError, "\n" ;
- errors_incr( $sync, $error ) ;
- return( 0 ) ;
- }else{
- # ok select succeeded
- return( 1 ) ;
- }
+ my ( $imap, $folder, $hostside ) = @_ ;
+ if ( ! $imap->examine( $folder ) ) {
+ my $error = join q{},
+ "$hostside folder $folder: Could not examine: ",
+ $imap->LastError, "\n" ;
+ errors_incr( $sync, $error ) ;
+ return( 0 ) ;
+ }else{
+ # ok select succeeded
+ return( 1 ) ;
+ }
}
sub count_from_select {
- my @lines = @_ ;
+ my @lines = @_ ;
my $count ;
foreach my $line ( @lines ) {
- #myprint( "line = [$line]\n" ) ;
- if ( $line =~ m/^\*\s+(\d+)\s+EXISTS/ ) {
- $count = $1 ;
+ #myprint( "line = [$line]\n" ) ;
+ if ( $line =~ m/^\*\s+(\d+)\s+EXISTS/x ) {
+ $count = $1 ;
return( $count ) ;
}
}
@@ -3793,34 +4797,34 @@ sub count_from_select {
sub create_folder_old {
- my( $imap, $h2_fold, $h1_fold ) = @_ ;
+ my( $imap, $h2_fold, $h1_fold ) = @_ ;
- myprint( "Creating (old way) folder [$h2_fold] on host2\n" ) ;
+ myprint( "Creating (old way) folder [$h2_fold] on host2\n" ) ;
if ( ( 'INBOX' eq uc $h2_fold )
and ( $imap->exists( $h2_fold ) ) ) {
myprint( "Folder [$h2_fold] already exists\n" ) ;
return( 1 ) ;
}
- if ( ! $dry ){
- if ( ! $imap->create( $h2_fold ) ) {
- my $error = join q{},
- "Could not create folder [$h2_fold] from [$h1_fold]: ",
- $imap->LastError( ), "\n" ;
- errors_incr( $sync, $error ) ;
+ if ( ! $sync->{dry} ){
+ if ( ! $imap->create( $h2_fold ) ) {
+ my $error = join q{},
+ "Could not create folder [$h2_fold] from [$h1_fold]: ",
+ $imap->LastError( ), "\n" ;
+ errors_incr( $sync, $error ) ;
# success if folder exists ("already exists" error)
return( 1 ) if $imap->exists( $h2_fold ) ;
# failure since create failed
- return( 0 ) ;
- }else{
- #create succeeded
+ return( 0 ) ;
+ }else{
+ #create succeeded
myprint( "Created ( the old way ) folder [$h2_fold] on host2\n" ) ;
- return( 1 ) ;
- }
- }else{
- # dry mode, no folder so many imap will fail, assuming failure
- myprint( "Created ( the old way ) folder [$h2_fold] on host2 $dry_message\n" ) ;
- return( 0 ) ;
- }
+ return( 1 ) ;
+ }
+ }else{
+ # dry mode, no folder so many imap will fail, assuming failure
+ myprint( "Created ( the old way ) folder [$h2_fold] on host2 $sync->{dry_message}\n" ) ;
+ return( 0 ) ;
+ }
}
@@ -3833,9 +4837,9 @@ sub create_folder {
return( 0 ) ;
}
- if ( $create_folder_old ) {
- return( create_folder_old( $imap2 , $h2_fold , $h1_fold ) ) ;
- }
+ if ( $create_folder_old ) {
+ return( create_folder_old( $imap2 , $h2_fold , $h1_fold ) ) ;
+ }
myprint( "Creating folder [$h2_fold] on host2\n" ) ;
if ( ( 'INBOX' eq uc $h2_fold )
and ( $imap2->exists( $h2_fold ) ) ) {
@@ -3854,20 +4858,20 @@ sub create_folder {
return( 0 ) ;
}
- @parts = split /\Q$h2_sep\E/, $h2_fold ;
+ @parts = split /\Q$h2_sep\E/x, $h2_fold ;
pop @parts ;
$parent = join $h2_sep, @parts ;
- $parent =~ s/^\s+|\s+$//g ;
+ $parent =~ s/^\s+|\s+$//xg ;
if ( ( $parent ne q{} ) and ( ! $imap2->exists( $parent ) ) ) {
create_folder( $imap2 , $parent , $h1_fold ) ;
}
- if ( ! $dry ) {
+ if ( ! $sync->{dry} ) {
if ( ! $imap2->create( $h2_fold ) ) {
- my $error = join q{},
- "Could not create folder [$h2_fold] from [$h1_fold]: " ,
- $imap2->LastError( ), "\n" ;
- errors_incr( $sync, $error ) ;
+ my $error = join q{},
+ "Could not create folder [$h2_fold] from [$h1_fold]: " ,
+ $imap2->LastError( ), "\n" ;
+ errors_incr( $sync, $error ) ;
# success if folder exists ("already exists" error)
return( 1 ) if $imap2->exists( $h2_fold ) ;
# failure since create failed
@@ -3879,395 +4883,412 @@ sub create_folder {
}
}else{
# dry mode, no folder so many imap will fail, assuming failure
- myprint( "Created folder [$h2_fold] on host2 $dry_message\n" ) ;
+ myprint( "Created folder [$h2_fold] on host2 $sync->{dry_message}\n" ) ;
if ( ! $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" ) ;
+ 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" ) ;
}
- return( 0 ) ;
+ return( 0 ) ;
}
}
sub tests_folder_routines {
- ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 1' );
- ok( add_to_requested_folders('folder_foo'), 'add_to_requested_folders folder_foo' );
- ok( is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 2' );
- ok( !is_requested_folder('folder_NO_EXIST'), 'is_requested_folder folder_NO_EXIST' );
- ok( !remove_from_requested_folders('folder_foo'), 'removed folder_foo' );
- ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 3' );
- my @f ;
- ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f" );
- ok( is_requested_folder('folder_bar'), 'is_requested_folder 4' );
- ok( is_requested_folder('folder_toto'), 'is_requested_folder 5' );
- ok( remove_from_requested_folders('folder_toto'), 'remove_from_requested_folders: ' );
- ok( !is_requested_folder('folder_toto'), 'is_requested_folder 6' );
- ok( !remove_from_requested_folders('folder_bar'), 'remove_from_requested_folders: empty' ) ;
+ note( 'Entering tests_folder_routines()' ) ;
+
+ ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 1' );
+ ok( add_to_requested_folders('folder_foo'), 'add_to_requested_folders folder_foo' );
+ ok( is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 2' );
+ ok( !is_requested_folder('folder_NO_EXIST'), 'is_requested_folder folder_NO_EXIST' );
+ ok( !remove_from_requested_folders('folder_foo'), 'removed folder_foo' );
+ ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 3' );
+ my @f ;
+ ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f" );
+ ok( is_requested_folder('folder_bar'), 'is_requested_folder 4' );
+ ok( is_requested_folder('folder_toto'), 'is_requested_folder 5' );
+ ok( remove_from_requested_folders('folder_toto'), 'remove_from_requested_folders: ' );
+ ok( !is_requested_folder('folder_toto'), 'is_requested_folder 6' );
+ ok( !remove_from_requested_folders('folder_bar'), 'remove_from_requested_folders: empty' ) ;
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [] ), 'sort_requested_folders: all empty' ) ;
- ok( add_to_requested_folders('M_55'), 'add_to_requested_folders M_55' );
+ ok( add_to_requested_folders('M_55'), 'add_to_requested_folders M_55' );
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'M_55' ] ), 'sort_requested_folders: middle' ) ;
- @folderfirst = ( 'Z_11' ) ;
+ @folderfirst = ( 'Z_11' ) ;
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_55' ] ), 'sort_requested_folders: first+middle' ) ;
- @folderlast = ( 'A_99' ) ;
+ @folderlast = ( 'A_99' ) ;
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_55', 'A_99' ] ), 'sort_requested_folders: first+middle+last 1' ) ;
- ok( add_to_requested_folders('M_55', 'M_44',), 'add_to_requested_folders M_55 M_44' );
+ ok( add_to_requested_folders('M_55', 'M_44',), 'add_to_requested_folders M_55 M_44' );
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_44', 'M_55', 'A_99' ] ), 'sort_requested_folders: first+middle+last 2' ) ;
- @folderfirst = qw( Z_22 Z_11 ) ;
- @folderlast = qw( A_99 A_88 ) ;
+ @folderfirst = qw( Z_22 Z_11 ) ;
+ @folderlast = qw( A_99 A_88 ) ;
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_22', 'Z_11', 'M_44', 'M_55', 'A_99', 'A_88' ] ), 'sort_requested_folders: first+middle+last 3' ) ;
- return ;
+ note( 'Leaving tests_folder_routines()' ) ;
+ return ;
}
sub sort_requested_folders {
- my @requested_folders_sorted = () ;
+ my @requested_folders_sorted = () ;
- foreach my $folder ( @folderfirst ) {
- remove_from_requested_folders( $folder ) ;
+ foreach my $folder ( @folderfirst ) {
+ remove_from_requested_folders( $folder ) ;
}
- foreach my $folder ( @folderlast ) {
- remove_from_requested_folders( $folder ) ;
+ foreach my $folder ( @folderlast ) {
+ remove_from_requested_folders( $folder ) ;
}
- my @middle = sort keys %requested_folder ;
+ my @middle = sort keys %requested_folder ;
@requested_folders_sorted = ( @folderfirst, @middle, @folderlast ) ;
- return( @requested_folders_sorted ) ;
+ return( @requested_folders_sorted ) ;
}
sub is_requested_folder {
- my ( $folder ) = @_;
+ my ( $folder ) = @_;
- return( defined $requested_folder{ $folder } ) ;
+ return( defined $requested_folder{ $folder } ) ;
}
sub add_to_requested_folders {
- my @wanted_folders = @_ ;
+ my @wanted_folders = @_ ;
- foreach my $folder ( @wanted_folders ) {
- ++$requested_folder{ $folder } ;
- }
- return( keys %requested_folder ) ;
+ foreach my $folder ( @wanted_folders ) {
+ ++$requested_folder{ $folder } ;
+ }
+ return( keys %requested_folder ) ;
}
sub remove_from_requested_folders {
- my @wanted_folders = @_ ;
+ my @wanted_folders = @_ ;
- foreach my $folder ( @wanted_folders ) {
- delete $requested_folder{ $folder } ;
- }
- return( keys %requested_folder ) ;
+ foreach my $folder ( @wanted_folders ) {
+ delete $requested_folder{ $folder } ;
+ }
+ return( keys %requested_folder ) ;
}
sub compare_lists {
- my ($list_1_ref, $list_2_ref) = @_;
+ my ($list_1_ref, $list_2_ref) = @_;
- 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
- return(1) if (not defined $list_2_ref); # end if only one list
+ 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
+ return(1) if (not defined $list_2_ref); # end if only one list
- if (not ref $list_1_ref ) {$list_1_ref = [$list_1_ref]};
- if (not ref $list_2_ref ) {$list_2_ref = [$list_2_ref]};
+ if (not ref $list_1_ref ) {$list_1_ref = [$list_1_ref]};
+ if (not ref $list_2_ref ) {$list_2_ref = [$list_2_ref]};
- my $last_used_indice = $MINUS_ONE;
+ my $last_used_indice = $MINUS_ONE;
- ELEMENT:
- foreach my $indice ( 0 .. $#{ $list_1_ref } ) {
- $last_used_indice = $indice ;
+ ELEMENT:
+ foreach my $indice ( 0 .. $#{ $list_1_ref } ) {
+ $last_used_indice = $indice ;
- # End of list_2
- return 1 if ($indice > $#{ $list_2_ref } ) ;
+ # End of list_2
+ return 1 if ($indice > $#{ $list_2_ref } ) ;
- my $element_list_1 = $list_1_ref->[$indice] ;
- my $element_list_2 = $list_2_ref->[$indice] ;
- my $balance = $element_list_1 cmp $element_list_2 ;
- next ELEMENT if ($balance == 0) ;
- return $balance ;
- }
- # each element equal until last indice of list_1
- return $MINUS_ONE if ($last_used_indice < $#{ $list_2_ref } ) ;
+ my $element_list_1 = $list_1_ref->[$indice] ;
+ my $element_list_2 = $list_2_ref->[$indice] ;
+ my $balance = $element_list_1 cmp $element_list_2 ;
+ next ELEMENT if ($balance == 0) ;
+ return $balance ;
+ }
+ # each element equal until last indice of list_1
+ return $MINUS_ONE if ($last_used_indice < $#{ $list_2_ref } ) ;
- # same size, each element equal
- return 0 ;
+ # same size, each element equal
+ return 0 ;
}
sub tests_compare_lists {
+ note( 'Entering tests_compare_lists()' ) ;
+ my $empty_list_ref = [];
- my $empty_list_ref = [];
-
- ok( 0 == compare_lists() , 'compare_lists, no args');
- ok( 0 == compare_lists(undef) , 'compare_lists, undef = nothing');
- ok( 0 == compare_lists(undef, undef) , 'compare_lists, undef = undef');
- ok($MINUS_ONE == compare_lists(undef , []) , 'compare_lists, undef < []');
- ok($MINUS_ONE == compare_lists(undef , [1]) , 'compare_lists, undef < [1]');
- ok($MINUS_ONE == compare_lists(undef , [0]) , 'compare_lists, undef < [0]');
- ok(+1 == compare_lists([]) , 'compare_lists, [] > nothing');
+ ok( 0 == compare_lists() , 'compare_lists, no args');
+ ok( 0 == compare_lists(undef) , 'compare_lists, undef = nothing');
+ ok( 0 == compare_lists(undef, undef) , 'compare_lists, undef = undef');
+ ok($MINUS_ONE == compare_lists(undef , []) , 'compare_lists, undef < []');
+ ok($MINUS_ONE == compare_lists(undef , [1]) , 'compare_lists, undef < [1]');
+ ok($MINUS_ONE == compare_lists(undef , [0]) , 'compare_lists, undef < [0]');
+ ok(+1 == compare_lists([]) , 'compare_lists, [] > nothing');
ok(+1 == compare_lists([], undef) , 'compare_lists, [] > undef');
- ok( 0 == compare_lists([] , []) , 'compare_lists, [] = []');
+ ok( 0 == compare_lists([] , []) , 'compare_lists, [] = []');
- ok($MINUS_ONE == compare_lists([] , [1]) , 'compare_lists, [] < [1]');
- ok(+1 == compare_lists([1] , []) , 'compare_lists, [1] > []');
+ ok($MINUS_ONE == compare_lists([] , [1]) , 'compare_lists, [] < [1]');
+ ok(+1 == compare_lists([1] , []) , 'compare_lists, [1] > []');
- ok( 0 == compare_lists([1], 1 ) , 'compare_lists, [1] = 1 ') ;
- ok( 0 == compare_lists( 1 , [1]) , 'compare_lists, 1 = [1]') ;
- ok( 0 == compare_lists( 1 , 1 ) , 'compare_lists, 1 = 1 ') ;
- ok($MINUS_ONE == compare_lists( 0 , 1 ) , 'compare_lists, 0 < 1 ') ;
- ok($MINUS_ONE == compare_lists($MINUS_ONE , 0 ) , 'compare_lists, -1 < 0 ') ;
- ok($MINUS_ONE == compare_lists( 1 , 2 ) , 'compare_lists, 1 < 2 ') ;
- ok(+1 == compare_lists( 2 , 1 ) , 'compare_lists, 2 > 1 ') ;
+ ok( 0 == compare_lists([1], 1 ) , 'compare_lists, [1] = 1 ') ;
+ ok( 0 == compare_lists( 1 , [1]) , 'compare_lists, 1 = [1]') ;
+ ok( 0 == compare_lists( 1 , 1 ) , 'compare_lists, 1 = 1 ') ;
+ ok($MINUS_ONE == compare_lists( 0 , 1 ) , 'compare_lists, 0 < 1 ') ;
+ ok($MINUS_ONE == compare_lists($MINUS_ONE , 0 ) , 'compare_lists, -1 < 0 ') ;
+ ok($MINUS_ONE == compare_lists( 1 , 2 ) , 'compare_lists, 1 < 2 ') ;
+ ok(+1 == compare_lists( 2 , 1 ) , 'compare_lists, 2 > 1 ') ;
- ok( 0 == compare_lists([1,2], [1,2]) , 'compare_lists, [1,2] = [1,2]' ) ;
- ok($MINUS_ONE == compare_lists([1], [1,2]) , 'compare_lists, [1] < [1,2]' ) ;
- ok(+1 == compare_lists([2], [1,2]) , 'compare_lists, [2] > [1,2]' ) ;
- ok($MINUS_ONE == compare_lists([1], [1,1]) , 'compare_lists, [1] < [1,1]' ) ;
- ok(+1 == compare_lists([1, 1], [1]) , 'compare_lists, [1, 1] > [1]' ) ;
- ok( 0 == compare_lists([1 .. $NUMBER_20_000] , [1 .. $NUMBER_20_000])
+ ok( 0 == compare_lists([1,2], [1,2]) , 'compare_lists, [1,2] = [1,2]' ) ;
+ ok($MINUS_ONE == compare_lists([1], [1,2]) , 'compare_lists, [1] < [1,2]' ) ;
+ ok(+1 == compare_lists([2], [1,2]) , 'compare_lists, [2] > [1,2]' ) ;
+ ok($MINUS_ONE == compare_lists([1], [1,1]) , 'compare_lists, [1] < [1,1]' ) ;
+ ok(+1 == compare_lists([1, 1], [1]) , 'compare_lists, [1, 1] > [1]' ) ;
+ ok( 0 == compare_lists([1 .. $NUMBER_20_000] , [1 .. $NUMBER_20_000])
, 'compare_lists, [1..20_000] = [1..20_000]' ) ;
- ok($MINUS_ONE == compare_lists([1], [2]) , 'compare_lists, [1] < [2]') ;
- ok( 0 == compare_lists([2], [2]) , 'compare_lists, [0] = [2]') ;
- ok(+1 == compare_lists([2], [1]) , 'compare_lists, [2] > [1]') ;
-
- ok($MINUS_ONE == compare_lists(['a'], ['b']) , 'compare_lists, ["a"] < ["b"]') ;
- ok( 0 == compare_lists(['a'], ['a']) , 'compare_lists, ["a"] = ["a"]') ;
- ok( 0 == compare_lists(['ab'], ['ab']) , 'compare_lists, ["ab"] = ["ab"]') ;
- ok(+1 == compare_lists(['b'], ['a']) , 'compare_lists, ["b"] > ["a"]') ;
- ok($MINUS_ONE == compare_lists(['a'], ['aa']) , 'compare_lists, ["a"] < ["aa"]') ;
- ok($MINUS_ONE == compare_lists(['a'], ['a', 'a']), 'compare_lists, ["a"] < ["a", "a"]') ;
- ok( 0 == compare_lists([split q{ }, 'a b' ], ['a', 'b']), 'compare_lists, split') ;
- ok( 0 == compare_lists([sort split q{ }, 'b a' ], ['a', 'b']), 'compare_lists, sort split') ;
+ ok($MINUS_ONE == compare_lists([1], [2]) , 'compare_lists, [1] < [2]') ;
+ ok( 0 == compare_lists([2], [2]) , 'compare_lists, [0] = [2]') ;
+ ok(+1 == compare_lists([2], [1]) , 'compare_lists, [2] > [1]') ;
+
+ ok($MINUS_ONE == compare_lists(['a'], ['b']) , 'compare_lists, ["a"] < ["b"]') ;
+ ok( 0 == compare_lists(['a'], ['a']) , 'compare_lists, ["a"] = ["a"]') ;
+ ok( 0 == compare_lists(['ab'], ['ab']) , 'compare_lists, ["ab"] = ["ab"]') ;
+ ok(+1 == compare_lists(['b'], ['a']) , 'compare_lists, ["b"] > ["a"]') ;
+ ok($MINUS_ONE == compare_lists(['a'], ['aa']) , 'compare_lists, ["a"] < ["aa"]') ;
+ ok($MINUS_ONE == compare_lists(['a'], ['a', 'a']), 'compare_lists, ["a"] < ["a", "a"]') ;
+ ok( 0 == compare_lists([split q{ }, 'a b' ], ['a', 'b']), 'compare_lists, split') ;
+ ok( 0 == compare_lists([sort split q{ }, 'b a' ], ['a', 'b']), 'compare_lists, sort split') ;
+
+ note( 'Leaving tests_compare_lists()' ) ;
return ;
}
-sub guess_prefix {
- my @foldernames = @_ ;
+sub guess_prefix {
+ my @foldernames = @_ ;
- return( undef ) unless ( @foldernames ) ;
-
- my $prefix_guessed = q{} ;
- foreach my $folder ( @foldernames ) {
- next if ( $folder =~ m{^INBOX$}i ) ; # no guessing from INBOX
- if ( $folder !~ m{^INBOX}i ) {
- $prefix_guessed = q{} ; # prefix empty guessed
- last ;
- }
- if ( $folder =~ m{^(INBOX(?:\.|\/))}i ) {
- $prefix_guessed = $1 ; # prefix Inbox/ or INBOX. guessed
- }
- }
- return( $prefix_guessed ) ;
+ my $prefix_guessed = q{} ;
+ foreach my $folder ( @foldernames ) {
+ next if ( $folder =~ m{^INBOX$}xi ) ; # no guessing from INBOX
+ if ( $folder !~ m{^INBOX}xi ) {
+ $prefix_guessed = q{} ; # prefix empty guessed
+ last ;
+ }
+ if ( $folder =~ m{^(INBOX(?:\.|\/))}xi ) {
+ $prefix_guessed = $1 ; # prefix Inbox/ or INBOX. guessed
+ }
+ }
+ return( $prefix_guessed ) ;
}
sub tests_guess_prefix {
-
- ok( not( defined guess_prefix( ) ), 'guess_prefix: no args' ) ;
- ok( q{} eq guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ;
- ok( q{} eq guess_prefix( 'Inbox' ), 'guess_prefix: Inbox alone' ) ;
- ok( q{} eq guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ;
- ok( 'INBOX/' eq guess_prefix( 'INBOX', 'INBOX/Junk' ), 'guess_prefix: INBOX INBOX/Junk' ) ;
- ok( 'INBOX.' eq guess_prefix( 'INBOX', 'INBOX.Junk' ), 'guess_prefix: INBOX INBOX.Junk' ) ;
- ok( 'Inbox/' eq guess_prefix( 'Inbox', 'Inbox/Junk' ), 'guess_prefix: Inbox Inbox/Junk' ) ;
- ok( 'Inbox.' eq guess_prefix( 'Inbox', 'Inbox.Junk' ), 'guess_prefix: Inbox Inbox.Junk' ) ;
- ok( 'INBOX/' eq guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr' ) ;
- ok( q{} eq guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr', 'zzz' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr zzz' ) ;
- ok( q{} eq guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ;
- ok( q{} eq guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ;
-
- return ;
+ note( 'Entering tests_guess_prefix()' ) ;
+
+ is( guess_prefix( ), q{}, 'guess_prefix: no args => empty string' ) ;
+ is( q{} , guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ;
+ is( q{} , guess_prefix( 'Inbox' ), 'guess_prefix: Inbox alone' ) ;
+ is( q{} , guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ;
+ is( 'INBOX/' , guess_prefix( 'INBOX', 'INBOX/Junk' ), 'guess_prefix: INBOX INBOX/Junk' ) ;
+ is( 'INBOX.' , guess_prefix( 'INBOX', 'INBOX.Junk' ), 'guess_prefix: INBOX INBOX.Junk' ) ;
+ is( 'Inbox/' , guess_prefix( 'Inbox', 'Inbox/Junk' ), 'guess_prefix: Inbox Inbox/Junk' ) ;
+ is( 'Inbox.' , guess_prefix( 'Inbox', 'Inbox.Junk' ), 'guess_prefix: Inbox Inbox.Junk' ) ;
+ is( 'INBOX/' , guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr' ) ;
+ is( q{} , guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr', 'zzz' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr zzz' ) ;
+ is( q{} , guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ;
+ is( q{} , guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ;
+
+ note( 'Leaving tests_guess_prefix()' ) ;
+ return ;
}
sub get_prefix {
- my( $imap, $prefix_in, $prefix_opt, $Side, $folders_ref ) = @_ ;
- my( $prefix_out, $prefix_guessed ) ;
-
- ( $debug or $sync->{debugfolders} ) and myprint( "$Side: Getting prefix\n" ) ;
- $prefix_guessed = guess_prefix( @{ $folders_ref } ) ;
- myprint( "$Side: guessing prefix from folder listing: [$prefix_guessed]\n" ) ;
- ( $debug or $sync->{debugfolders} ) and myprint( "$Side: Calling namespace capability\n" ) ;
- if ( $imap->has_capability( 'namespace' ) ) {
- my $r_namespace = $imap->namespace( ) ;
- $prefix_out = $r_namespace->[0][0][0] ;
+ my( $imap, $prefix_in, $prefix_opt, $Side, $folders_ref ) = @_ ;
+ my( $prefix_out, $prefix_guessed ) ;
+
+ ( $debug or $sync->{debugfolders} ) and myprint( "$Side: Getting prefix\n" ) ;
+ $prefix_guessed = guess_prefix( @{ $folders_ref } ) ;
+ myprint( "$Side: guessing prefix from folder listing: [$prefix_guessed]\n" ) ;
+ ( $debug or $sync->{debugfolders} ) and myprint( "$Side: Calling namespace capability\n" ) ;
+ if ( $imap->has_capability( 'namespace' ) ) {
+ my $r_namespace = $imap->namespace( ) ;
+ $prefix_out = $r_namespace->[0][0][0] ;
myprint( "$Side: prefix given by NAMESPACE: [$prefix_out]\n" ) ;
- if ( defined $prefix_in ) {
- myprint( "$Side: but using [$prefix_in] given by $prefix_opt\n" ) ;
- $prefix_out = $prefix_in ;
- return( $prefix_out ) ;
+ if ( defined $prefix_in ) {
+ myprint( "$Side: but using [$prefix_in] given by $prefix_opt\n" ) ;
+ $prefix_out = $prefix_in ;
+ return( $prefix_out ) ;
}else{
- # all good
- return( $prefix_out ) ;
+ # all good
+ return( $prefix_out ) ;
}
- }
- else{
- if ( defined $prefix_in ) {
- myprint( "$Side: using [$prefix_in] given by $prefix_opt\n" ) ;
- $prefix_out = $prefix_in ;
- return( $prefix_out ) ;
+ }
+ else{
+ if ( defined $prefix_in ) {
+ myprint( "$Side: using [$prefix_in] given by $prefix_opt\n" ) ;
+ $prefix_out = $prefix_in ;
+ return( $prefix_out ) ;
}else{
- myprint(
- "$Side: No NAMESPACE capability so using guessed prefix [$prefix_guessed]\n",
- help_to_guess_prefix( $imap, $prefix_opt ) ) ;
- return( $prefix_guessed ) ;
+ myprint(
+ "$Side: No NAMESPACE capability so using guessed prefix [$prefix_guessed]\n",
+ help_to_guess_prefix( $imap, $prefix_opt ) ) ;
+ return( $prefix_guessed ) ;
}
- }
+ }
return ;
}
sub guess_separator {
- my @foldernames = @_ ;
+ my @foldernames = @_ ;
- #return( undef ) unless ( @foldernames ) ;
+ #return( undef ) unless ( @foldernames ) ;
- my $sep_guessed ;
- my %counter ;
- foreach my $folder ( @foldernames ) {
- $counter{'/'}++ while ( $folder =~ m{/}g ) ; # count /
- $counter{'.'}++ while ( $folder =~ m{\.}g ) ; # count .
- $counter{'\\\\'}++ while ( $folder =~ m{(\\){2}}g ) ; # count \\
- }
- my @race_sorted = sort { $counter{ $b } <=> $counter{ $a } } keys %counter ;
- #myprint( "@race_sorted\n" ) ;
- $sep_guessed = shift @race_sorted || $LAST_RESSORT_SEPARATOR ; # / when nothing found.
- return( $sep_guessed ) ;
+ 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 \
+ }
+ my @race_sorted = sort { $counter{ $b } <=> $counter{ $a } } keys %counter ;
+ $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 {
- ok( '/' eq guess_separator( ), 'guess_separator: no args' ) ;
- ok( '/' eq guess_separator( 'abcd' ), 'guess_separator: abcd' ) ;
- ok( '/' eq guess_separator( 'a/b/c.d' ), 'guess_separator: a/b/c.d' ) ;
- ok( '.' eq guess_separator( 'a.b/c.d' ), 'guess_separator: a.b/c.d' ) ;
- ok( '\\\\' eq guess_separator( 'a\\\\b\\\\c.c\\\\d/e/f' ), 'guess_separator: a\\\\b\\\\c.c\\\\d/e/f' ) ;
- return ;
+ note( 'Entering tests_guess_separator()' ) ;
+
+ ok( '/' eq guess_separator( ), 'guess_separator: no args' ) ;
+ ok( '/' eq guess_separator( 'abcd' ), 'guess_separator: abcd' ) ;
+ ok( '/' eq guess_separator( 'a/b/c.d' ), 'guess_separator: a/b/c.d' ) ;
+ ok( '.' eq guess_separator( 'a.b/c.d' ), 'guess_separator: a.b/c.d' ) ;
+ ok( '\\\\' eq guess_separator( 'a\\\\b\\\\c.c\\\\d/e/f' ), 'guess_separator: a\\\\b\\\\c.c\\\\d/e/f' ) ;
+ ok( '\\' eq guess_separator( 'a\\b\\c.c\\d/e/f' ), 'guess_separator: a\\b\\c.c\\d/e/f' ) ;
+ ok( '\\' eq guess_separator( 'a\\b' ), 'guess_separator: a\\b' ) ;
+ ok( '\\' eq guess_separator( 'a\\b\\c' ), 'guess_separator: a\\b\\c' ) ;
+
+ note( 'Leaving tests_guess_separator()' ) ;
+ return ;
}
sub get_separator {
- my( $imap, $sep_in, $sep_opt, $Side, $folders_ref ) = @_ ;
- my( $sep_out, $sep_guessed ) ;
-
- ( $debug or $sync->{debugfolders} ) and myprint( "$Side: Getting separator\n" ) ;
- $sep_guessed = guess_separator( @{ $folders_ref } ) ;
- myprint( "$Side: guessing separator from folder listing: [$sep_guessed]\n" ) ;
-
- ( $debug or $sync->{debugfolders} ) and myprint( "$Side: calling namespace capability\n" ) ;
- if ( $imap->has_capability( 'namespace' ) ) {
- $sep_out = $imap->separator( ) ;
- if ( defined $sep_out ) {
- myprint( "$Side: separator given by NAMESPACE: [$sep_out]\n" ) ;
+ my( $imap, $sep_in, $sep_opt, $Side, $folders_ref ) = @_ ;
+ my( $sep_out, $sep_guessed ) ;
+
+ ( $debug or $sync->{debugfolders} ) and myprint( "$Side: Getting separator\n" ) ;
+ $sep_guessed = guess_separator( @{ $folders_ref } ) ;
+ myprint( "$Side: guessing separator from folder listing: [$sep_guessed]\n" ) ;
+
+ ( $debug or $sync->{debugfolders} ) and myprint( "$Side: calling namespace capability\n" ) ;
+ if ( $imap->has_capability( 'namespace' ) ) {
+ $sep_out = $imap->separator( ) ;
+ if ( defined $sep_out ) {
+ myprint( "$Side: separator given by NAMESPACE: [$sep_out]\n" ) ;
if ( defined $sep_in ) {
- myprint( "$Side: but using [$sep_in] given by $sep_opt\n" ) ;
- $sep_out = $sep_in ;
- return( $sep_out ) ;
+ myprint( "$Side: but using [$sep_in] given by $sep_opt\n" ) ;
+ $sep_out = $sep_in ;
+ return( $sep_out ) ;
}else{
- return( $sep_out ) ;
+ return( $sep_out ) ;
}
- }else{
- if ( defined $sep_in ) {
- myprint( "$Side: NAMESPACE request failed but using [$sep_in] given by $sep_opt\n" ) ;
- $sep_out = $sep_in ;
- return( $sep_out ) ;
+ }else{
+ if ( defined $sep_in ) {
+ myprint( "$Side: NAMESPACE request failed but using [$sep_in] given by $sep_opt\n" ) ;
+ $sep_out = $sep_in ;
+ return( $sep_out ) ;
}else{
- myprint(
- "$Side: NAMESPACE request failed so using guessed separator [$sep_guessed]\n",
- help_to_guess_sep( $imap, $sep_opt ) ) ;
- return( $sep_guessed ) ;
+ myprint(
+ "$Side: NAMESPACE request failed so using guessed separator [$sep_guessed]\n",
+ help_to_guess_sep( $imap, $sep_opt ) ) ;
+ return( $sep_guessed ) ;
}
}
- }
- else{
- if ( defined $sep_in ) {
- myprint( "$Side: No NAMESPACE capability but using [$sep_in] given by $sep_opt\n" ) ;
- $sep_out = $sep_in ;
- return( $sep_out ) ;
+ }
+ else{
+ if ( defined $sep_in ) {
+ myprint( "$Side: No NAMESPACE capability but using [$sep_in] given by $sep_opt\n" ) ;
+ $sep_out = $sep_in ;
+ return( $sep_out ) ;
}else{
- myprint(
- "$Side: No NAMESPACE capability, so using guessed separator [$sep_guessed]\n",
- help_to_guess_sep( $imap, $sep_opt ) ) ;
- return( $sep_guessed ) ;
+ myprint(
+ "$Side: No NAMESPACE capability, so using guessed separator [$sep_guessed]\n",
+ help_to_guess_sep( $imap, $sep_opt ) ) ;
+ return( $sep_guessed ) ;
}
- }
+ }
return ;
}
sub help_to_guess_sep {
- my( $imap, $sep_opt ) = @_ ;
+ my( $imap, $sep_opt ) = @_ ;
- 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"
- . folders_list_to_help( $imap ) ;
+ 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"
+ . folders_list_to_help( $imap ) ;
- return( $help_to_guess_sep ) ;
+ return( $help_to_guess_sep ) ;
}
sub help_to_guess_prefix {
- my( $imap, $prefix_opt ) = @_ ;
+ my( $imap, $prefix_opt ) = @_ ;
- 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"
- . folders_list_to_help( $imap ) ;
+ 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"
+ . folders_list_to_help( $imap ) ;
- return( $help_to_guess_prefix ) ;
+ return( $help_to_guess_prefix ) ;
}
sub folders_list_to_help {
- my($imap) = @_ ;
+ my($imap) = @_ ;
- my @folders = $imap->folders ;
- my $listing = join q{}, map { "[$_]\n" } @folders ;
- return( $listing ) ;
+ my @folders = $imap->folders ;
+ my $listing = join q{}, map { "[$_]\n" } @folders ;
+ return( $listing ) ;
}
sub tests_separator_invert {
- $fixslash2 = 0 ;
- ok( not( defined separator_invert( ) ), 'separator_invert: no args' ) ;
- ok( not( defined separator_invert( q{} ) ), 'separator_invert: not enough args' ) ;
- ok( not( defined separator_invert( q{}, q{} ) ), 'separator_invert: not enough args' ) ;
-
- ok( q{} eq separator_invert( q{}, q{}, q{} ), 'separator_invert: 3 empty strings' ) ;
- ok( 'lalala' eq separator_invert( 'lalala', q{}, q{} ), 'separator_invert: empty separator' ) ;
- ok( 'lalala' eq separator_invert( 'lalala', '/', '/' ), 'separator_invert: same separator /' ) ;
- ok( 'lal/ala' eq separator_invert( 'lal/ala', '/', '/' ), 'separator_invert: same separator / 2' ) ;
- ok( 'lal.ala' eq separator_invert( 'lal/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
- ok( 'lal/ala' eq separator_invert( 'lal.ala', '.', '/' ), 'separator_invert: separators ./' ) ;
- ok( 'la.l/ala' eq separator_invert( 'la/l.ala', '.', '/' ), 'separator_invert: separators ./' ) ;
-
- ok( 'l/al.ala' eq separator_invert( 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
+ note( 'Entering tests_separator_invert()' ) ;
+
+ $fixslash2 = 0 ;
+ ok( not( defined separator_invert( ) ), 'separator_invert: no args' ) ;
+ ok( not( defined separator_invert( q{} ) ), 'separator_invert: not enough args' ) ;
+ ok( not( defined separator_invert( q{}, q{} ) ), 'separator_invert: not enough args' ) ;
+
+ ok( q{} eq separator_invert( q{}, q{}, q{} ), 'separator_invert: 3 empty strings' ) ;
+ ok( 'lalala' eq separator_invert( 'lalala', q{}, q{} ), 'separator_invert: empty separator' ) ;
+ ok( 'lalala' eq separator_invert( 'lalala', '/', '/' ), 'separator_invert: same separator /' ) ;
+ ok( 'lal/ala' eq separator_invert( 'lal/ala', '/', '/' ), 'separator_invert: same separator / 2' ) ;
+ ok( 'lal.ala' eq separator_invert( 'lal/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
+ ok( 'lal/ala' eq separator_invert( 'lal.ala', '.', '/' ), 'separator_invert: separators ./' ) ;
+ ok( 'la.l/ala' eq separator_invert( 'la/l.ala', '.', '/' ), 'separator_invert: separators ./' ) ;
+
+ ok( 'l/al.ala' eq separator_invert( 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
$fixslash2 = 1 ;
- ok( 'l_al.ala' eq separator_invert( 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
+ ok( 'l_al.ala' eq separator_invert( 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
- return ;
+ note( 'Leaving tests_separator_invert()' ) ;
+ return ;
}
sub separator_invert {
- my( $h1_fold, $h1_separator, $h2_separator ) = @_ ;
+ my( $h1_fold, $h1_separator, $h2_separator ) = @_ ;
- return( undef ) if ( not defined $h1_fold or not defined $h1_separator or not defined $h2_separator ) ;
- # The separator we hope we'll never encounter: 00000000 == 0x00
- my $o_sep = "\000" ;
+ return( undef ) if ( not defined $h1_fold or not defined $h1_separator or not defined $h2_separator ) ;
+ # The separator we hope we'll never encounter: 00000000 == 0x00
+ my $o_sep = "\000" ;
- my $h2_fold = $h1_fold ;
- $h2_fold =~ s,\Q$h2_separator,$o_sep,xg ;
- $h2_fold =~ s,\Q$h1_separator,$h2_separator,xg ;
- $h2_fold =~ s,\Q$o_sep,$h1_separator,xg ;
+ my $h2_fold = $h1_fold ;
+ $h2_fold =~ s,\Q$h2_separator,$o_sep,xg ;
+ $h2_fold =~ s,\Q$h1_separator,$h2_separator,xg ;
+ $h2_fold =~ s,\Q$o_sep,$h1_separator,xg ;
$h2_fold =~ s,/,_,xg if( $fixslash2 and '/' ne $h2_separator and '/' eq $h1_separator ) ;
- return( $h2_fold ) ;
+ return( $h2_fold ) ;
}
sub tests_imap2_folder_name {
+ note( 'Entering tests_imap2_folder_name()' ) ;
$h1_prefix = $h2_prefix = q{};
$h1_sep = '/';
@@ -4344,459 +5365,480 @@ ok( 'TEST/TEST/TEST/TEST' eq imap2_folder_name( 'INBOX.TEST.test.Test.tesT' ), '
ok( 'test/test/test/test' eq imap2_folder_name( 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ;
-return ;
+ note( 'Leaving tests_imap2_folder_name()' ) ;
+ return ;
}
sub imap2_folder_name {
- my ( $h1_fold ) = @_ ;
- my ( $h2_fold ) ;
- if ( $sync->{f1f2}{ $h1_fold } ) {
- $h2_fold = $sync->{f1f2}{ $h1_fold } ;
- ( $debug or $sync->{debugfolders} ) and myprint( "f1f2 [$h1_fold] -> [$h2_fold]\n" ) ;
- return( $h2_fold ) ;
- }
- if ( $sync->{f1f2auto}{ $h1_fold } ) {
- $h2_fold = $sync->{f1f2auto}{ $h1_fold } ;
- ( $debug or $sync->{debugfolders} ) and myprint( "automap [$h1_fold] -> [$h2_fold]\n" ) ;
- return( $h2_fold ) ;
- }
+ my ( $h1_fold ) = @_ ;
+ my ( $h2_fold ) ;
+ if ( $sync->{f1f2}{ $h1_fold } ) {
+ $h2_fold = $sync->{f1f2}{ $h1_fold } ;
+ ( $debug or $sync->{debugfolders} ) and myprint( "f1f2 [$h1_fold] -> [$h2_fold]\n" ) ;
+ return( $h2_fold ) ;
+ }
+ if ( $sync->{f1f2auto}{ $h1_fold } ) {
+ $h2_fold = $sync->{f1f2auto}{ $h1_fold } ;
+ ( $debug or $sync->{debugfolders} ) and myprint( "automap [$h1_fold] -> [$h2_fold]\n" ) ;
+ return( $h2_fold ) ;
+ }
- $h2_fold = prefix_seperator_invertion( $h1_fold ) ;
- $h2_fold = regextrans2( $h2_fold ) ;
- return( $h2_fold ) ;
+ $h2_fold = prefix_seperator_invertion( $h1_fold ) ;
+ $h2_fold = regextrans2( $h2_fold ) ;
+ return( $h2_fold ) ;
}
sub prefix_seperator_invertion {
- my ( $h1_fold ) = @_ ;
- my ( $h2_fold ) ;
+ my ( $h1_fold ) = @_ ;
+ my ( $h2_fold ) ;
- # first we remove the prefix
- $h1_fold =~ s/^\Q$h1_prefix\E//x ;
- ( $debug or $sync->{debugfolders} ) and myprint( "removed host1 prefix: [$h1_fold]\n" ) ;
- $h2_fold = separator_invert( $h1_fold, $h1_sep, $h2_sep ) ;
- ( $debug or $sync->{debugfolders} ) and myprint( "inverted separators: [$h2_fold]\n" ) ;
- # Adding the prefix supplied by namespace or the --prefix2 option
- $h2_fold = $h2_prefix . $h2_fold
- unless( ( $h2_prefix eq 'INBOX' . $h2_sep ) and ( $h2_fold =~ m/^INBOX$/xi ) ) ;
- ( $debug or $sync->{debugfolders} ) and myprint( "added host2 prefix: [$h2_fold]\n" ) ;
- return( $h2_fold ) ;
+ # first we remove the prefix
+ $h1_fold =~ s/^\Q$h1_prefix\E//x ;
+ ( $debug or $sync->{debugfolders} ) and myprint( "removed host1 prefix: [$h1_fold]\n" ) ;
+ $h2_fold = separator_invert( $h1_fold, $h1_sep, $h2_sep ) ;
+ ( $debug or $sync->{debugfolders} ) and myprint( "inverted separators: [$h2_fold]\n" ) ;
+ # Adding the prefix supplied by namespace or the --prefix2 option
+ $h2_fold = $h2_prefix . $h2_fold
+ unless( ( $h2_prefix eq 'INBOX' . $h2_sep ) and ( $h2_fold =~ m/^INBOX$/xi ) ) ;
+ ( $debug or $sync->{debugfolders} ) and myprint( "added host2 prefix: [$h2_fold]\n" ) ;
+ return( $h2_fold ) ;
}
sub regextrans2 {
- my( $h2_fold ) = @_ ;
- # Transforming the folder name by the --regextrans2 option(s)
- foreach my $regextrans2 ( @regextrans2 ) {
- my $h2_fold_before = $h2_fold ;
- my $ret = eval "\$h2_fold =~ $regextrans2 ; 1 " ;
- ( $debug or $sync->{debugfolders} ) and myprint( "[$h2_fold_before] -> [$h2_fold] using regextrans2 [$regextrans2]\n" ) ;
- if ( not ( defined $ret ) or $@ ) {
- die_clean( "error: eval regextrans2 '$regextrans2': $@\n" ) ;
+ my( $h2_fold ) = @_ ;
+ # Transforming the folder name by the --regextrans2 option(s)
+ foreach my $regextrans2 ( @regextrans2 ) {
+ my $h2_fold_before = $h2_fold ;
+ my $ret = eval "\$h2_fold =~ $regextrans2 ; 1 " ;
+ ( $debug or $sync->{debugfolders} ) and myprint( "[$h2_fold_before] -> [$h2_fold] using regextrans2 [$regextrans2]\n" ) ;
+ if ( not ( defined $ret ) or $EVAL_ERROR ) {
+ die_clean( "error: eval regextrans2 '$regextrans2': $EVAL_ERROR\n" ) ;
}
- }
- return( $h2_fold ) ;
+ }
+ return( $h2_fold ) ;
}
sub tests_decompose_regex {
- ok( 1, 'decompose_regex 1' ) ;
- ok( 0 == compare_lists( [ q{}, q{} ], [ decompose_regex( q{} ) ] ), 'decompose_regex empty string' ) ;
- ok( 0 == compare_lists( [ '.*', 'lala' ], [ decompose_regex( 's/.*/lala/' ) ] ), 'decompose_regex s/.*/lala/' ) ;
- return ;
+ note( 'Entering tests_decompose_regex()' ) ;
+
+ ok( 1, 'decompose_regex 1' ) ;
+ ok( 0 == compare_lists( [ q{}, q{} ], [ decompose_regex( q{} ) ] ), 'decompose_regex empty string' ) ;
+ ok( 0 == compare_lists( [ '.*', 'lala' ], [ decompose_regex( 's/.*/lala/' ) ] ), 'decompose_regex s/.*/lala/' ) ;
+
+ note( 'Leaving tests_decompose_regex()' ) ;
+ return ;
}
sub decompose_regex {
- my $regex = shift ;
- my( $left_part, $right_part ) ;
+ my $regex = shift ;
+ my( $left_part, $right_part ) ;
- ( $left_part, $right_part ) = $regex =~ m{^s/((?:[^/]|\\/)+)/((?:[^/]|\\/)+)/}x;
+ ( $left_part, $right_part ) = $regex =~ m{^s/((?:[^/]|\\/)+)/((?:[^/]|\\/)+)/}x;
return( q{}, q{} ) if not $left_part ;
- return( $left_part, $right_part ) ;
+ return( $left_part, $right_part ) ;
}
sub foldersizes {
- my ( $side, $imap, $search_cmd, @folders ) = @_ ;
- my $total_size = 0 ;
- my $total_nb = 0 ;
- my $biggest_in_all = 0 ;
-
- my $nb_folders = scalar @folders ;
- my $ct_folders = 0 ; # folder counter.
- myprint( "++++ Calculating sizes of $nb_folders folders on $side\n" ) ;
- foreach my $folder ( @folders ) {
- my $stot = 0 ;
- my $nb_msgs = 0 ;
- $ct_folders++ ;
- myprintf( "$side folder %7s %-35s", "$ct_folders/$nb_folders", jux_utf8( $folder ) ) ;
+ my ( $side, $imap, $search_cmd, $abletosearch, @folders ) = @_ ;
+ my $total_size = 0 ;
+ my $total_nb = 0 ;
+ my $biggest_in_all = 0 ;
+
+ my $nb_folders = scalar @folders ;
+ my $ct_folders = 0 ; # folder counter.
+ myprint( "++++ Calculating sizes of $nb_folders folders on $side\n" ) ;
+ foreach my $folder ( @folders ) {
+ my $stot = 0 ;
+ my $nb_msgs = 0 ;
+ $ct_folders++ ;
+ myprintf( "$side folder %7s %-35s", "$ct_folders/$nb_folders", jux_utf8( $folder ) ) ;
if ( 'Host2' eq $side and not exists $h2_folders_all_UPPER{ uc $folder } ) {
- myprint( " does not exist yet\n") ;
- next ;
- }
+ myprint( " does not exist yet\n") ;
+ next ;
+ }
if ( 'Host1' eq $side and not exists $h1_folders_all{ $folder } ) {
- myprint( " does not exist\n" ) ;
- next ;
- }
+ myprint( " does not exist\n" ) ;
+ next ;
+ }
- last if $imap->IsUnconnected( ) ;
- # FTGate is RFC buggy with EXAMINE it does not act as SELECT
- #unless ( $imap->examine( $folder ) ) {
- unless ( $imap->select( $folder ) ) {
- my $error = join q{},
- "$side Folder $folder: Could not select: ",
- $imap->LastError, "\n" ;
- errors_incr( $sync, $error ) ;
- next ;
- }
- last if $imap->IsUnconnected( ) ;
-
- my $hash_ref = { } ;
- my @msgs = select_msgs( $imap, undef, $search_cmd, $folder ) ;
- $nb_msgs = scalar @msgs ;
- my $biggest_in_folder = 0 ;
- @{ $hash_ref }{ @msgs } = ( undef ) if @msgs ;
-
- last if $imap->IsUnconnected( ) ;
- if ( $nb_msgs > 0 and @msgs ) {
- if ( $abletosearch ) {
- if ( ! $imap->fetch_hash( \@msgs, 'RFC822.SIZE', $hash_ref) ) {
- my $error = "$side failure with fetch_hash: $@" ;
+ last if $imap->IsUnconnected( ) ;
+ # FTGate is RFC buggy with EXAMINE it does not act as SELECT
+ #unless ( $imap->examine( $folder ) ) {
+ unless ( $imap->select( $folder ) ) {
+ my $error = join q{},
+ "$side Folder $folder: Could not select: ",
+ $imap->LastError, "\n" ;
+ errors_incr( $sync, $error ) ;
+ next ;
+ }
+ last if $imap->IsUnconnected( ) ;
+
+ my $hash_ref = { } ;
+ my @msgs = select_msgs( $imap, undef, $search_cmd, $abletosearch, $folder ) ;
+ $nb_msgs = scalar @msgs ;
+ my $biggest_in_folder = 0 ;
+ @{ $hash_ref }{ @msgs } = ( undef ) if @msgs ;
+
+ last if $imap->IsUnconnected( ) ;
+ if ( $nb_msgs > 0 and @msgs ) {
+ if ( $abletosearch ) {
+ if ( ! $imap->fetch_hash( \@msgs, 'RFC822.SIZE', $hash_ref) ) {
+ my $error = "$side failure with fetch_hash: $EVAL_ERROR" ;
errors_incr( $sync, $error ) ;
return ;
}
}else{
- my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ;
- my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
- if ( ! $imap->fetch_hash( $fetch_hash_uids, 'RFC822.SIZE', $hash_ref ) ) {
- my $error = "$side failure with fetch_hash: $@" ;
+ my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ;
+ my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
+ if ( ! $imap->fetch_hash( $fetch_hash_uids, 'RFC822.SIZE', $hash_ref ) ) {
+ my $error = "$side failure with fetch_hash: $EVAL_ERROR" ;
errors_incr( $sync, $error ) ;
return ;
}
}
- for ( keys %{ $hash_ref } ) {
- my $size = $hash_ref->{ $_ }->{ 'RFC822.SIZE' } ;
- $stot += $size ;
+ for ( keys %{ $hash_ref } ) {
+ my $size = $hash_ref->{ $_ }->{ 'RFC822.SIZE' } ;
+ $stot += $size ;
$biggest_in_folder = max( $biggest_in_folder, $size ) ;
}
- }
+ }
- myprintf( ' Size: %9s', $stot ) ;
- myprintf( ' Messages: %5s', $nb_msgs ) ;
- myprintf( " Biggest: %9s\n", $biggest_in_folder ) ;
- $total_size += $stot ;
- $total_nb += $nb_msgs ;
+ myprintf( ' Size: %9s', $stot ) ;
+ myprintf( ' Messages: %5s', $nb_msgs ) ;
+ myprintf( " Biggest: %9s\n", $biggest_in_folder ) ;
+ $total_size += $stot ;
+ $total_nb += $nb_msgs ;
$biggest_in_all = max( $biggest_in_all, $biggest_in_folder ) ;
- }
- myprintf( "%s Nb folders: %11s folders\n", $side, $nb_folders ) ;
- myprintf( "%s Nb messages: %11s messages\n", $side, $total_nb ) ;
- myprintf( "%s Total size: %11s bytes (%s)\n", $side, $total_size, bytes_display_string( $total_size ) ) ;
- myprintf( "%s Biggest message: %11s bytes (%s)\n", $side, $biggest_in_all, bytes_display_string( $biggest_in_all ) ) ;
- myprintf( "%s Time spent: %11.1f seconds\n", $side, timenext( ) ) ;
+ }
+ myprintf( "%s Nb folders: %11s folders\n", $side, $nb_folders ) ;
+ myprintf( "%s Nb messages: %11s messages\n", $side, $total_nb ) ;
+ myprintf( "%s Total size: %11s bytes (%s)\n", $side, $total_size, bytes_display_string( $total_size ) ) ;
+ myprintf( "%s Biggest message: %11s bytes (%s)\n", $side, $biggest_in_all, bytes_display_string( $biggest_in_all ) ) ;
+ myprintf( "%s Time spent: %11.1f seconds\n", $side, timenext( ) ) ;
return( $total_nb, $total_size ) ;
}
sub timenext {
- my ( $timenow, $timediff ) ;
- # $timebefore is global, beurk !
- $timenow = time ;
- $timediff = $timenow - $timebefore ;
- $timebefore = $timenow ;
- return( $timediff ) ;
+ my ( $timenow, $timediff ) ;
+ # $timebefore is global, beurk !
+ $timenow = time ;
+ $timediff = $timenow - $timebefore ;
+ $timebefore = $timenow ;
+ return( $timediff ) ;
}
sub timesince {
- my $timeinit = shift ;
- my ( $timenow, $timediff ) ;
- $timenow = time ;
- $timediff = $timenow - $timeinit ;
- return( $timediff ) ;
+ my $timeinit = shift || 0 ;
+ my ( $timenow, $timediff ) ;
+ $timenow = time ;
+ $timediff = $timenow - $timeinit ;
+ # Often used in a division so no 0
+ return( max( 1, $timediff) ) ;
}
sub tests_flags_regex {
+ note( 'Entering tests_flags_regex()' ) ;
- ok( q{} eq flags_regex(q{} ), 'flags_regex, null string q{}' ) ;
- ok( q'\Seen NonJunk $Spam' eq flags_regex( q'\Seen NonJunk $Spam' ), 'flags_regex, nothing to do');
+ ok( q{} eq flags_regex(q{} ), 'flags_regex, null string q{}' ) ;
+ ok( q{\Seen NonJunk $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, nothing to do} ) ;
- @regexflag = ('I am BAD' ) ;
+ @regexflag = ('I am BAD' ) ;
ok( not ( defined flags_regex( q{} ) ), 'flags_regex, bad regex' ) ;
- @regexflag = ( 's/NonJunk//g' ) ;
- ok( q'\Seen $Spam' eq flags_regex( q'\Seen NonJunk $Spam' ), q{flags_regex, remove NonJunk: 's/NonJunk//g'} ) ;
- @regexflag = ( q's/\$Spam//g' ) ;
- ok( '\Seen NonJunk ' eq flags_regex( q'\Seen NonJunk $Spam' ), q{flags_regex, remove $Spam: 's/\$Spam//g'} ) ;
-
- @regexflag = ( 's/\\\\Seen//g' ) ;
-
- ok( q' NonJunk $Spam' eq flags_regex( q'\Seen NonJunk $Spam' ), q{flags_regex, remove \Seen: 's/\\\\\\\\Seen//g'} ) ;
-
- @regexflag = ( 's/(\s|^)[^\\\\]\w+//g' ) ;
- ok( '\Seen \Middle \End' eq flags_regex( q'\Seen NonJunk \Middle $Spam \End' ), q{flags_regex: only \word among \Seen NonJunk \Middle $Spam \End} ) ;
- ok( ' \Seen \Middle \End1' eq flags_regex( q'Begin \Seen NonJunk \Middle $Spam \End1 End' ),
- q'flags_regex: only \word among Begin \Seen NonJunk \Middle $Spam \End1 End' ) ;
-
- @regexflag = ( q's/.*?(Keep1|Keep2|Keep3)/$1 /g' ) ;
- ok('Keep1 Keep2 ReB' eq flags_regex('ReA Keep1 REM Keep2 ReB'), 'Keep only regex' ) ;
-
- ok('Keep1 Keep2 ' eq flags_regex( 'REM REM Keep1 Keep2'), 'Keep only regex' ) ;
- ok('Keep1 Keep2 ' eq flags_regex( 'Keep1 REM REM Keep2'), 'Keep only regex' ) ;
- ok('Keep1 Keep2 ' eq flags_regex( 'REM Keep1 REM REM Keep2'), 'Keep only regex' ) ;
- ok('Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2'), 'Keep only regex' ) ;
- ok('Keep1 ' eq flags_regex( 'REM Keep1'), 'Keep only regex' ) ;
-
- @regexflag = ( q's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g' ) ;
- ok('Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 ReB'), 'Keep only regex' ) ;
- ok('Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 REM REM REM'), 'Keep only regex' ) ;
- ok('Keep2 ' eq flags_regex('Keep2 REM REM REM'), 'Keep only regex' ) ;
-
-
- @regexflag = ( q's/.*?(Keep1|Keep2|Keep3)/$1 /g',
- 's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g');
- ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), 'Keep only regex');
- ok('Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), 'Keep only regex');
- ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), 'Keep only regex');
- ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), 'Keep only regex');
- ok('Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), 'Keep only regex');
- ok('Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), 'Keep only regex');
- ok('Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), 'Keep only regex');
-
- @regexflag = ('s/(.*)/$1 jrdH8u/');
- ok('REM REM REM REM REM jrdH8u' eq flags_regex('REM REM REM REM REM'), q{Keep only regex 's/(.*)/\$1 jrdH8u/'} ) ;
- @regexflag = ('s/jrdH8u *//');
- ok('REM REM REM REM REM ' eq flags_regex('REM REM REM REM REM jrdH8u'), q{Keep only regex s/jrdH8u *//} ) ;
-
- @regexflag = (
- 's/(.*)/$1 jrdH8u/',
- 's/.*?(Keep1|Keep2|Keep3|jrdH8u)/$1 /g',
- 's/(Keep1|Keep2|Keep3|jrdH8u) (?!(Keep1|Keep2|Keep3|jrdH8u)).*/$1 /g',
- 's/jrdH8u *//'
- );
-
- ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), q{Keep only regex 'REM Keep1 REM Keep2 REM'} ) ;
- ok('Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), 'Keep only regex');
- ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), 'Keep only regex');
- ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), 'Keep only regex');
- ok('Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), 'Keep only regex');
- ok('Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), 'Keep only regex');
- ok('Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), 'Keep only regex');
- ok(q{} eq flags_regex('REM REM REM REM REM'), 'Keep only regex');
-
- @regexflag = (
- 's/(.*)/$1 jrdH8u/',
- 's/.*?(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u)/$1 /g',
- 's/(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u) (?!(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u)).*/$1 /g',
- 's/jrdH8u *//'
- );
-
- ok('\\Deleted \\Answered '
- eq flags_regex('Blabla $Junk \\Deleted machin \\Answered truc'), 'Keep only regex: Exchange case' ) ;
- ok( q{} eq flags_regex( q{} ), 'Keep only regex: Exchange case, null string' ) ;
- ok( q{}
- eq flags_regex('Blabla $Junk machin truc'), 'Keep only regex: Exchange case, no accepted flags' ) ;
- ok( '\\Deleted \\Answered \\Draft \\Flagged '
- eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), 'Keep only regex: Exchange case' ) ;
-
-
- @regexflag = (
- 's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg'
- );
-
- ok( '\\Deleted \\Answered '
- eq flags_regex('Blabla \$Junk \\Deleted machin \\Answered truc'),
- 'Keep only regex: Exchange case (Phil)' ) ;
-
- ok( q{} eq flags_regex( q{} ), 'Keep only regex: Exchange case, null string (Phil)' ) ;
-
- ok( q{}
- eq flags_regex('Blabla $Junk machin truc'),
- 'Keep only regex: Exchange case, no accepted flags (Phil)' ) ;
-
- ok('\\Deleted \\Answered \\Draft \\Flagged '
- eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '),
- 'Keep only regex: Exchange case (Phil)' ) ;
-
- return ;
+ @regexflag = ( 's/NonJunk//g' ) ;
+ ok( q{\Seen $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove NonJunk: 's/NonJunk//g'} ) ;
+ @regexflag = ( q's/\$Spam//g' ) ;
+ ok( q{\Seen NonJunk } eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove $Spam: 's/\$Spam//g'} ) ;
+
+ @regexflag = ( 's/\\\\Seen//g' ) ;
+
+ ok( q{ NonJunk $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove \Seen: 's/\\\\\\\\Seen//g'} ) ;
+
+ @regexflag = ( 's/(\s|^)[^\\\\]\w+//g' ) ;
+ ok( q{\Seen \Middle \End} eq flags_regex( q{\Seen NonJunk \Middle $Spam \End} ), q{flags_regex: only \word among \Seen NonJunk \Middle $Spam \End} ) ;
+ ok( q{ \Seen \Middle \End1} eq flags_regex( q{Begin \Seen NonJunk \Middle $Spam \End1 End} ),
+ q{flags_regex: only \word among Begin \Seen NonJunk \Middle $Spam \End1 End} ) ;
+
+ @regexflag = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g} ) ;
+ ok( 'Keep1 Keep2 ReB' eq flags_regex('ReA Keep1 REM Keep2 ReB'), 'Keep only regex' ) ;
+
+ ok( 'Keep1 Keep2 ' eq flags_regex( 'REM REM Keep1 Keep2'), 'Keep only regex' ) ;
+ ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 REM REM Keep2'), 'Keep only regex' ) ;
+ ok( 'Keep1 Keep2 ' eq flags_regex( 'REM Keep1 REM REM Keep2'), 'Keep only regex' ) ;
+ ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2'), 'Keep only regex' ) ;
+ ok( 'Keep1 ' eq flags_regex( 'REM Keep1'), 'Keep only regex' ) ;
+
+ @regexflag = ( q{s/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g} ) ;
+ ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 ReB'), 'Keep only regex' ) ;
+ ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 REM REM REM'), 'Keep only regex' ) ;
+ ok( 'Keep2 ' eq flags_regex('Keep2 REM REM REM'), 'Keep only regex' ) ;
+
+
+ @regexflag = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g},
+ 's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g' ) ;
+ ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), 'Keep only regex' ) ;
+ ok( 'Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), 'Keep only regex' ) ;
+ ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), 'Keep only regex' ) ;
+ ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), 'Keep only regex' ) ;
+ ok( 'Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), 'Keep only regex' ) ;
+ ok( 'Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), 'Keep only regex' ) ;
+ ok( 'Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), 'Keep only regex' ) ;
+
+ @regexflag = ( 's/(.*)/$1 jrdH8u/' ) ;
+ ok('REM REM REM REM REM jrdH8u' eq flags_regex('REM REM REM REM REM'), q{Keep only regex 's/(.*)/\$1 jrdH8u/'} ) ;
+ @regexflag = ('s/jrdH8u *//');
+ ok('REM REM REM REM REM ' eq flags_regex('REM REM REM REM REM jrdH8u'), q{Keep only regex s/jrdH8u *//} ) ;
+
+ @regexflag = (
+ 's/(.*)/$1 jrdH8u/',
+ 's/.*?(Keep1|Keep2|Keep3|jrdH8u)/$1 /g',
+ 's/(Keep1|Keep2|Keep3|jrdH8u) (?!(Keep1|Keep2|Keep3|jrdH8u)).*/$1 /g',
+ 's/jrdH8u *//'
+ );
+
+ ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), q{Keep only regex 'REM Keep1 REM Keep2 REM'} ) ;
+ ok('Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), 'Keep only regex');
+ ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), 'Keep only regex');
+ ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), 'Keep only regex');
+ ok('Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), 'Keep only regex');
+ ok('Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), 'Keep only regex');
+ ok('Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), 'Keep only regex');
+ ok(q{} eq flags_regex('REM REM REM REM REM'), 'Keep only regex');
+
+ @regexflag = (
+ 's/(.*)/$1 jrdH8u/',
+ 's/.*?(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u)/$1 /g',
+ 's/(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u) (?!(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u)).*/$1 /g',
+ 's/jrdH8u *//'
+ );
+
+ ok('\\Deleted \\Answered '
+ eq flags_regex('Blabla $Junk \\Deleted machin \\Answered truc'), 'Keep only regex: Exchange case' ) ;
+ ok( q{} eq flags_regex( q{} ), 'Keep only regex: Exchange case, null string' ) ;
+ ok( q{}
+ eq flags_regex('Blabla $Junk machin truc'), 'Keep only regex: Exchange case, no accepted flags' ) ;
+ ok( '\\Deleted \\Answered \\Draft \\Flagged '
+ eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), 'Keep only regex: Exchange case' ) ;
+
+
+ @regexflag = (
+ 's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg'
+ );
+
+ ok( '\\Deleted \\Answered '
+ eq flags_regex('Blabla \$Junk \\Deleted machin \\Answered truc'),
+ 'Keep only regex: Exchange case (Phil)' ) ;
+
+ ok( q{} eq flags_regex( q{} ), 'Keep only regex: Exchange case, null string (Phil)' ) ;
+
+ ok( q{}
+ eq flags_regex('Blabla $Junk machin truc'),
+ 'Keep only regex: Exchange case, no accepted flags (Phil)' ) ;
+
+ ok('\\Deleted \\Answered \\Draft \\Flagged '
+ eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '),
+ 'Keep only regex: Exchange case (Phil)' ) ;
+
+ note( 'Leaving tests_flags_regex()' ) ;
+ return ;
}
sub flags_regex {
- my ( $h1_flags ) = @_ ;
- foreach my $regexflag ( @regexflag ) {
- my $h1_flags_orig = $h1_flags ;
- $debugflags and myprint( "eval \$h1_flags =~ $regexflag\n" ) ;
- my $ret = eval "\$h1_flags =~ $regexflag ; 1 " ;
- $debugflags and myprint( "regexflag $regexflag [$h1_flags_orig] -> [$h1_flags]\n" ) ;
- if( not ( defined $ret ) or $@ ) {
- myprint( "Error: eval regexflag '$regexflag': $@\n" ) ;
+ my ( $h1_flags ) = @_ ;
+ foreach my $regexflag ( @regexflag ) {
+ my $h1_flags_orig = $h1_flags ;
+ $debugflags and myprint( "eval \$h1_flags =~ $regexflag\n" ) ;
+ my $ret = eval "\$h1_flags =~ $regexflag ; 1 " ;
+ $debugflags and myprint( "regexflag $regexflag [$h1_flags_orig] -> [$h1_flags]\n" ) ;
+ if( not ( defined $ret ) or $EVAL_ERROR ) {
+ myprint( "Error: eval regexflag '$regexflag': $EVAL_ERROR\n" ) ;
return( undef ) ;
}
- }
- return( $h1_flags ) ;
+ }
+ return( $h1_flags ) ;
}
sub acls_sync {
- my($h1_fold, $h2_fold) = @_ ;
- if ( $syncacls ) {
- my $h1_hash = $imap1->getacl($h1_fold)
- or myprint( "Could not getacl for $h1_fold: $@\n" ) ;
- my $h2_hash = $imap2->getacl($h2_fold)
- or myprint( "Could not getacl for $h2_fold: $@\n" ) ;
- my %users = map { ($_, 1) } ( keys %{ $h1_hash} , keys %{ $h2_hash } ) ;
- foreach my $user (sort keys %users ) {
- my $acl = $h1_hash->{$user} || 'none' ;
- myprint( "acl $user: [$acl]\n" ) ;
- next if ($h1_hash->{$user} && $h2_hash->{$user} &&
- $h1_hash->{$user} eq $h2_hash->{$user});
- unless ($dry) {
- myprint( "setting acl $h2_fold $user $acl\n" ) ;
- $imap2->setacl($h2_fold, $user, $acl)
- or myprint( "Could not set acl: $@\n" ) ;
- }
- }
- }
+ my($h1_fold, $h2_fold) = @_ ;
+ if ( $syncacls ) {
+ my $h1_hash = $imap1->getacl($h1_fold)
+ or myprint( "Could not getacl for $h1_fold: $EVAL_ERROR\n" ) ;
+ my $h2_hash = $imap2->getacl($h2_fold)
+ or myprint( "Could not getacl for $h2_fold: $EVAL_ERROR\n" ) ;
+ my %users = map { ($_, 1) } ( keys %{ $h1_hash} , keys %{ $h2_hash } ) ;
+ foreach my $user (sort keys %users ) {
+ my $acl = $h1_hash->{$user} || 'none' ;
+ myprint( "acl $user: [$acl]\n" ) ;
+ next if ($h1_hash->{$user} && $h2_hash->{$user} &&
+ $h1_hash->{$user} eq $h2_hash->{$user});
+ unless ($sync->{dry}) {
+ myprint( "setting acl $h2_fold $user $acl\n" ) ;
+ $imap2->setacl($h2_fold, $user, $acl)
+ or myprint( "Could not set acl: $EVAL_ERROR\n" ) ;
+ }
+ }
+ }
return ;
}
sub tests_permanentflags {
-
- my $string;
- ok(q{} eq permanentflags(' * OK [PERMANENTFLAGS (\* \Draft \Answered)] Limited'),
- 'permanentflags \*');
- ok('\Draft \Answered' eq permanentflags(' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited'),
- 'permanentflags \Draft \Answered');
- ok('\Draft \Answered'
- eq permanentflags('Blabla',
- ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited',
- 'Blabla'),
- 'permanentflags \Draft \Answered'
- );
- ok(q{} eq permanentflags('Blabla'), 'permanentflags nothing');
+ note( 'Entering tests_permanentflags()' ) ;
+
+ my $string;
+ ok(q{} eq permanentflags(' * OK [PERMANENTFLAGS (\* \Draft \Answered)] Limited'),
+ 'permanentflags \*');
+ ok('\Draft \Answered' eq permanentflags(' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited'),
+ 'permanentflags \Draft \Answered');
+ ok('\Draft \Answered'
+ eq permanentflags('Blabla',
+ ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited',
+ 'Blabla'),
+ 'permanentflags \Draft \Answered'
+ );
+ ok(q{} eq permanentflags('Blabla'), 'permanentflags nothing');
+
+ note( 'Leaving tests_permanentflags()' ) ;
return ;
}
sub permanentflags {
- my @lines = @_ ;
-
- foreach my $line (@lines) {
- if ( $line =~ m{\[PERMANENTFLAGS\s\(([^)]+?)\)\]}x ) {
- ( $debugflags or $debug ) and myprint( "permanentflags: $line" ) ;
- my $permanentflags = $1 ;
- if ( $permanentflags =~ m{\\\*}x ) {
- $permanentflags = q{} ;
- }
- return($permanentflags) ;
- } ;
- }
+ my @lines = @_ ;
+
+ foreach my $line (@lines) {
+ if ( $line =~ m{\[PERMANENTFLAGS\s\(([^)]+?)\)\]}x ) {
+ ( $debugflags or $debug ) and myprint( "permanentflags: $line" ) ;
+ my $permanentflags = $1 ;
+ if ( $permanentflags =~ m{\\\*}x ) {
+ $permanentflags = q{} ;
+ }
+ return($permanentflags) ;
+ } ;
+ }
return( q{} ) ;
}
sub tests_flags_filter {
-
- ok( '\Seen' eq flags_filter('\Seen', '\Draft \Seen \Answered'), 'flags_filter ' );
- ok( q{} eq flags_filter('\Seen', '\Draft \Answered'), 'flags_filter ' );
- ok( '\Seen' eq flags_filter('\Seen', '\Seen'), 'flags_filter ' );
- ok( '\Seen' eq flags_filter('\Seen', ' \Seen '), 'flags_filter ' );
- ok( '\Seen \Draft'
- eq flags_filter('\Seen \Draft', '\Draft \Seen \Answered'), 'flags_filter ' );
- ok( '\Seen \Draft'
- eq flags_filter('\Seen \Draft', ' \Draft \Seen \Answered '), 'flags_filter ' );
- return ;
+ note( 'Entering tests_flags_filter()' ) ;
+
+ ok( '\Seen' eq flags_filter('\Seen', '\Draft \Seen \Answered'), 'flags_filter ' );
+ ok( q{} eq flags_filter('\Seen', '\Draft \Answered'), 'flags_filter ' );
+ ok( '\Seen' eq flags_filter('\Seen', '\Seen'), 'flags_filter ' );
+ ok( '\Seen' eq flags_filter('\Seen', ' \Seen '), 'flags_filter ' );
+ ok( '\Seen \Draft'
+ eq flags_filter('\Seen \Draft', '\Draft \Seen \Answered'), 'flags_filter ' );
+ ok( '\Seen \Draft'
+ eq flags_filter('\Seen \Draft', ' \Draft \Seen \Answered '), 'flags_filter ' );
+
+ note( 'Leaving tests_flags_filter()' ) ;
+ return ;
}
sub flags_filter {
- my( $flags, $allowed_flags ) = @_ ;
+ my( $flags, $allowed_flags ) = @_ ;
- my @flags = split /\s+/x, $flags ;
- my %allowed_flags = map { $_ => 1 } split q{ }, $allowed_flags ;
- my @flags_out = map { exists $allowed_flags{$_} ? $_ : () } @flags ;
+ my @flags = split /\s+/x, $flags ;
+ my %allowed_flags = map { $_ => 1 } split q{ }, $allowed_flags ;
+ my @flags_out = map { exists $allowed_flags{$_} ? $_ : () } @flags ;
- my $flags_out = join q{ }, @flags_out ;
+ my $flags_out = join q{ }, @flags_out ;
- return( $flags_out ) ;
+ return( $flags_out ) ;
}
sub flagscase {
- my $flags = shift ;
+ my $flags = shift ;
- my @flags = split /\s+/x, $flags ;
- my %rfc_flags = map { $_ => 1 } split q{ }, '\Answered \Flagged \Deleted \Seen \Draft' ;
- my @flags_out = map { exists $rfc_flags{ ucsecond( lc $_ ) } ? ucsecond( lc $_ ) : $_ } @flags ;
+ my @flags = split /\s+/x, $flags ;
+ my %rfc_flags = map { $_ => 1 } split q{ }, '\Answered \Flagged \Deleted \Seen \Draft' ;
+ my @flags_out = map { exists $rfc_flags{ ucsecond( lc $_ ) } ? ucsecond( lc $_ ) : $_ } @flags ;
- my $flags_out = join q{ }, @flags_out ;
+ my $flags_out = join q{ }, @flags_out ;
- return( $flags_out ) ;
+ return( $flags_out ) ;
}
sub tests_flagscase {
- ok( '\Seen' eq flagscase( '\Seen' ), 'flagscase: \Seen -> \Seen' ) ;
- ok( '\Seen' eq flagscase( '\SEEN' ), 'flagscase: \SEEN -> \Seen' ) ;
+ note( 'Entering tests_flagscase()' ) ;
+
+ ok( '\Seen' eq flagscase( '\Seen' ), 'flagscase: \Seen -> \Seen' ) ;
+ ok( '\Seen' eq flagscase( '\SEEN' ), 'flagscase: \SEEN -> \Seen' ) ;
+
+ ok( '\Seen \Draft' eq flagscase( '\SEEN \DRAFT' ), 'flagscase: \SEEN \DRAFT -> \Seen \Draft' ) ;
+ ok( '\Draft \Seen' eq flagscase( '\DRAFT \SEEN' ), 'flagscase: \DRAFT \SEEN -> \Draft \Seen' ) ;
- ok( '\Seen \Draft' eq flagscase( '\SEEN \DRAFT' ), 'flagscase: \SEEN \DRAFT -> \Seen \Draft' ) ;
- ok( '\Draft \Seen' eq flagscase( '\DRAFT \SEEN' ), 'flagscase: \DRAFT \SEEN -> \Draft \Seen' ) ;
+ ok( '\Draft LALA \Seen' eq flagscase( '\DRAFT LALA \SEEN' ), 'flagscase: \DRAFT LALA \SEEN -> \Draft LALA \Seen' ) ;
+ ok( '\Draft lala \Seen' eq flagscase( '\DRAFT lala \SEEN' ), 'flagscase: \DRAFT lala \SEEN -> \Draft lala \Seen' ) ;
- ok( '\Draft LALA \Seen' eq flagscase( '\DRAFT LALA \SEEN' ), 'flagscase: \DRAFT LALA \SEEN -> \Draft LALA \Seen' ) ;
- ok( '\Draft lala \Seen' eq flagscase( '\DRAFT lala \SEEN' ), 'flagscase: \DRAFT lala \SEEN -> \Draft lala \Seen' ) ;
+ note( 'Leaving tests_flagscase()' ) ;
return ;
}
sub ucsecond {
- my $string = shift ;
- my $output ;
+ my $string = shift ;
+ my $output ;
- return( $string ) if ( 1 >= length $string ) ;
-
- $output = ( substr( $string, 0, 1) ) . ( uc substr $string, 1, 1 ) . ( substr $string, 2 ) ;
- #myprint( "UUU $string -> $output\n" ) ;
- return( $output ) ;
+ return( $string ) if ( 1 >= length $string ) ;
+
+ $output = ( substr( $string, 0, 1) ) . ( uc substr $string, 1, 1 ) . ( substr $string, 2 ) ;
+ #myprint( "UUU $string -> $output\n" ) ;
+ return( $output ) ;
}
sub tests_ucsecond {
- ok( 'aBcde' eq ucsecond( 'abcde' ), 'ucsecond: abcde -> aBcde' ) ;
- ok( 'ABCDE' eq ucsecond( 'ABCDE' ), 'ucsecond: ABCDE -> ABCDE' ) ;
- ok( 'ABCDE' eq ucsecond( 'AbCDE' ), 'ucsecond: AbCDE -> ABCDE' ) ;
- ok( 'ABCde' eq ucsecond( 'AbCde' ), 'ucsecond: AbCde -> ABCde' ) ;
- ok( 'A' eq ucsecond( 'A' ), 'ucsecond: A -> A' ) ;
- ok( 'AB' eq ucsecond( 'Ab' ), 'ucsecond: Ab -> AB' ) ;
- ok( '\B' eq ucsecond( '\b' ), 'ucsecond: \b -> \B' ) ;
- ok( '\Bcde' eq ucsecond( '\bcde' ), 'ucsecond: \bcde -> \Bcde' ) ;
+ note( 'Entering tests_ucsecond()' ) ;
+ ok( 'aBcde' eq ucsecond( 'abcde' ), 'ucsecond: abcde -> aBcde' ) ;
+ ok( 'ABCDE' eq ucsecond( 'ABCDE' ), 'ucsecond: ABCDE -> ABCDE' ) ;
+ ok( 'ABCDE' eq ucsecond( 'AbCDE' ), 'ucsecond: AbCDE -> ABCDE' ) ;
+ ok( 'ABCde' eq ucsecond( 'AbCde' ), 'ucsecond: AbCde -> ABCde' ) ;
+ ok( 'A' eq ucsecond( 'A' ), 'ucsecond: A -> A' ) ;
+ ok( 'AB' eq ucsecond( 'Ab' ), 'ucsecond: Ab -> AB' ) ;
+ ok( '\B' eq ucsecond( '\b' ), 'ucsecond: \b -> \B' ) ;
+ ok( '\Bcde' eq ucsecond( '\bcde' ), 'ucsecond: \bcde -> \Bcde' ) ;
+
+ note( 'Leaving tests_ucsecond()' ) ;
return ;
}
sub select_msgs {
- my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ;
- my ( @msgs ) ;
+ my ( $imap, $msgs_all_hash_ref, $search_cmd, $abletosearch, $folder ) = @_ ;
+ my ( @msgs ) ;
- if ( $abletosearch ) {
- @msgs = select_msgs_by_search( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ;
- }else{
- @msgs = select_msgs_by_fetch( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ;
- }
- return( @msgs ) ;
+ if ( $abletosearch ) {
+ @msgs = select_msgs_by_search( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ;
+ }else{
+ @msgs = select_msgs_by_fetch( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ;
+ }
+ return( @msgs ) ;
}
sub select_msgs_by_search {
- my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ;
- my ( @msgs, @msgs_all ) ;
+ my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ;
+ my ( @msgs, @msgs_all ) ;
# Need to have the whole list in msgs_all_hash_ref
# without calling messages() several times.
# 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 )
+ 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" ) ;
- @msgs_all = $imap->messages( ) ;
+ $debugdev and myprint( "Calling messages()\n" ) ;
+ @msgs_all = $imap->messages( ) ;
return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ;
@@ -4807,22 +5849,22 @@ sub select_msgs_by_search {
if ( not defined $maxage and not defined $minage and not defined $search_cmd ) {
return( @msgs_all ) ;
}
- }
+ }
if ( defined $search_cmd ) {
- @msgs = $imap->search( $search_cmd ) ;
+ @msgs = $imap->search( $search_cmd ) ;
return( @msgs ) ;
}
- # we are here only if $maxage or $minage is defined
+ # we are here only if $maxage or $minage is defined
@msgs = select_msgs_by_age( $imap ) ;
- return( @msgs );
+ return( @msgs );
}
sub select_msgs_by_fetch {
- my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ;
- my ( @msgs, @msgs_all, %fetch ) ;
+ my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ;
+ my ( @msgs, @msgs_all, %fetch ) ;
# Need to have the whole list in msgs_all_hash_ref
# without calling messages() several times.
@@ -4830,10 +5872,10 @@ sub select_msgs_by_fetch {
# in case of --search or --minage or --maxage
- $debugdev and myprint( "Calling fetch_hash()\n" ) ;
- my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ;
- my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
- %fetch = %{$imap->fetch_hash( $fetch_hash_uids, 'INTERNALDATE' ) } ;
+ $debugdev and myprint( "Calling fetch_hash()\n" ) ;
+ my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ;
+ my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
+ %fetch = %{$imap->fetch_hash( $fetch_hash_uids, 'INTERNALDATE' ) } ;
@msgs_all = sort { $a <=> $b } keys %fetch ;
$debugdev and myprint( "Done fetch_hash()\n" ) ;
@@ -4849,138 +5891,142 @@ sub select_msgs_by_fetch {
}
if ( defined $search_cmd ) {
- myprint( "Warning: strange to see --search with --noabletosearch, an error can happen\n" ) ;
- @msgs = $imap->search( $search_cmd ) ;
+ myprint( "Warning: strange to see --search with --noabletosearch, an error can happen\n" ) ;
+ @msgs = $imap->search( $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 ; }
- foreach my $msg ( @msgs_all ) {
- my $idate = $fetch{ $msg }->{'INTERNALDATE'} ;
- #myprint( "$idate\n" ) ;
- if ( defined $maxage and ( epoch( $idate ) >= $maxage_epoch ) ) {
- push @max, $msg ;
- }
- if ( defined $minage and ( epoch( $idate ) <= $minage_epoch ) ) {
- push @min, $msg ;
- }
- }
+ # 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 ; }
+ foreach my $msg ( @msgs_all ) {
+ my $idate = $fetch{ $msg }->{'INTERNALDATE'} ;
+ #myprint( "$idate\n" ) ;
+ if ( defined $maxage and ( epoch( $idate ) >= $maxage_epoch ) ) {
+ push @max, $msg ;
+ }
+ if ( defined $minage and ( epoch( $idate ) <= $minage_epoch ) ) {
+ push @min, $msg ;
+ }
+ }
@msgs = msgs_from_maxmin( \@max, \@min ) ;
- return( @msgs ) ;
+ return( @msgs ) ;
}
sub select_msgs_by_age {
- my( $imap ) = @_ ;
+ my( $imap ) = @_ ;
- my( @max, @min, @msgs, @inter, @union ) ;
+ my( @max, @min, @msgs, @inter, @union ) ;
- if ( defined $maxage ) {
- @max = $imap->sentsince( $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ) ;
- }
- if ( defined $minage ) {
- @min = $imap->sentbefore( $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ) ;
- }
+ if ( defined $maxage ) {
+ @max = $imap->sentsince( $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ) ;
+ }
+ if ( defined $minage ) {
+ @min = $imap->sentbefore( $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ) ;
+ }
- @msgs = msgs_from_maxmin( \@max, \@min ) ;
- return( @msgs ) ;
+ @msgs = msgs_from_maxmin( \@max, \@min ) ;
+ return( @msgs ) ;
}
sub msgs_from_maxmin {
- my( $max_ref, $min_ref ) = @_ ;
- my( @max, @min, @msgs, @inter, @union ) ;
-
- @max = @{ $max_ref } ;
- @min = @{ $min_ref } ;
-
- SWITCH: {
- unless( defined $minage ) { @msgs = @max ; last SWITCH } ;
- unless( defined $maxage ) { @msgs = @min ; last SWITCH } ;
- my ( %union, %inter ) ;
- foreach my $m ( @min, @max ) { $union{ $m }++ && $inter{ $m }++ }
- @inter = sort { $a <=> $b } keys %inter ;
- @union = sort { $a <=> $b } keys %union ;
- # normal case
- if ( $minage <= $maxage ) { @msgs = @inter ; last SWITCH } ;
- # just exclude messages between
- if ( $minage > $maxage ) { @msgs = @union ; last SWITCH } ;
+ my( $max_ref, $min_ref ) = @_ ;
+ my( @max, @min, @msgs, @inter, @union ) ;
+
+ @max = @{ $max_ref } ;
+ @min = @{ $min_ref } ;
+
+ SWITCH: {
+ unless( defined $minage ) { @msgs = @max ; last SWITCH } ;
+ unless( defined $maxage ) { @msgs = @min ; last SWITCH } ;
+ my ( %union, %inter ) ;
+ foreach my $m ( @min, @max ) { $union{ $m }++ && $inter{ $m }++ }
+ @inter = sort { $a <=> $b } keys %inter ;
+ @union = sort { $a <=> $b } keys %union ;
+ # normal case
+ if ( $minage <= $maxage ) { @msgs = @inter ; last SWITCH } ;
+ # just exclude messages between
+ if ( $minage > $maxage ) { @msgs = @union ; last SWITCH } ;
- }
- return( @msgs ) ;
+ }
+ return( @msgs ) ;
}
sub tests_msgs_from_maxmin {
- my @msgs ;
- $maxage = $NUMBER_200 ;
- @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
- ok( 0 == compare_lists( [ '1', '2' ], \@msgs ), 'msgs_from_maxmin: maxage++' ) ;
- $minage = $NUMBER_100 ;
- @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
- ok( 0 == compare_lists( [ '2' ], \@msgs ), 'msgs_from_maxmin: -maxage++minage-' ) ;
- $minage = $NUMBER_300 ;
- @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
- ok( 0 == compare_lists( [ '1', '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++maxage-minage++' ) ;
- $maxage = undef ;
- @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
- ok( 0 == compare_lists( [ '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++minage-' ) ;
- return ;
+ note( 'Entering tests_msgs_from_maxmin()' ) ;
+
+ my @msgs ;
+ $maxage = $NUMBER_200 ;
+ @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
+ ok( 0 == compare_lists( [ '1', '2' ], \@msgs ), 'msgs_from_maxmin: maxage++' ) ;
+ $minage = $NUMBER_100 ;
+ @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
+ ok( 0 == compare_lists( [ '2' ], \@msgs ), 'msgs_from_maxmin: -maxage++minage-' ) ;
+ $minage = $NUMBER_300 ;
+ @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
+ ok( 0 == compare_lists( [ '1', '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++maxage-minage++' ) ;
+ $maxage = undef ;
+ @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
+ ok( 0 == compare_lists( [ '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++minage-' ) ;
+
+ note( 'Leaving tests_msgs_from_maxmin()' ) ;
+ return ;
}
sub lastuid {
- my $imap = shift ;
- my $folder = shift ;
- my $lastuid_guess = shift ;
- my $lastuid ;
-
- # rfc3501: The only reliable way to identify recent messages is to
- # look at message flags to see which have the \Recent flag
- # set, or to do a SEARCH RECENT.
- # SEARCH RECENT doesn't work this way on courrier.
-
- my @recent_messages ;
- # SEARCH RECENT for each transfer can be expensive with a big folder
- # Call commented for now
- #@recent_messages = $imap->recent( ) ;
- #myprint( "Recent: @recent_messages\n" ) ;
-
- my $max_recent ;
- $max_recent = max( @recent_messages ) ;
-
- if ( defined $max_recent and ($lastuid_guess <= $max_recent ) ) {
- $lastuid = $max_recent ;
- }else{
- $lastuid = $lastuid_guess
- }
- return( $lastuid ) ;
+ my $imap = shift ;
+ my $folder = shift ;
+ my $lastuid_guess = shift ;
+ my $lastuid ;
+
+ # rfc3501: The only reliable way to identify recent messages is to
+ # look at message flags to see which have the \Recent flag
+ # set, or to do a SEARCH RECENT.
+ # SEARCH RECENT doesn't work this way on courrier.
+
+ my @recent_messages ;
+ # SEARCH RECENT for each transfer can be expensive with a big folder
+ # Call commented for now
+ #@recent_messages = $imap->recent( ) ;
+ #myprint( "Recent: @recent_messages\n" ) ;
+
+ my $max_recent ;
+ $max_recent = max( @recent_messages ) ;
+
+ if ( defined $max_recent and ($lastuid_guess <= $max_recent ) ) {
+ $lastuid = $max_recent ;
+ }else{
+ $lastuid = $lastuid_guess
+ }
+ return( $lastuid ) ;
}
sub size_filtered {
- my( $h1_size, $h1_msg, $h1_fold, $h2_fold ) = @_ ;
+ my( $h1_size, $h1_msg, $h1_fold, $h2_fold ) = @_ ;
$h1_size = 0 if ( ! $h1_size ) ; # null if empty or undef
- if (defined $maxsize and $h1_size > $maxsize) {
- myprint( "msg $h1_fold/$h1_msg skipped ($h1_size exceeds maxsize limit $maxsize bytes)\n" ) ;
- $total_bytes_skipped += $h1_size;
- $nb_msg_skipped += 1;
- return( 1 ) ;
- }
- if (defined $minsize and $h1_size <= $minsize) {
- myprint( "msg $h1_fold/$h1_msg skipped ($h1_size smaller than minsize $minsize bytes)\n" ) ;
- $total_bytes_skipped += $h1_size;
- $nb_msg_skipped += 1;
- return( 1 ) ;
- }
- return( 0 ) ;
+ if (defined $maxsize and $h1_size > $maxsize) {
+ myprint( "msg $h1_fold/$h1_msg skipped ($h1_size exceeds maxsize limit $maxsize bytes)\n" ) ;
+ $total_bytes_skipped += $h1_size;
+ $nb_msg_skipped += 1;
+ return( 1 ) ;
+ }
+ if (defined $minsize and $h1_size <= $minsize) {
+ myprint( "msg $h1_fold/$h1_msg skipped ($h1_size smaller than minsize $minsize bytes)\n" ) ;
+ $total_bytes_skipped += $h1_size;
+ $nb_msg_skipped += 1;
+ return( 1 ) ;
+ }
+ return( 0 ) ;
}
sub message_exists {
- my( $imap, $msg ) = @_ ;
- return( 1 ) if not $imap->Uid( ) ;
+ my( $imap, $msg ) = @_ ;
+ return( 1 ) if not $imap->Uid( ) ;
- my $search_uid ;
+ my $search_uid ;
( $search_uid ) = $imap->search( "UID $msg" ) ;
#myprint( "$search ? $msg\n" ) ;
return( 1 ) if ( $search_uid eq $msg ) ;
@@ -4988,82 +6034,82 @@ sub message_exists {
}
sub copy_message {
- # copy
+ # copy
- my ( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) = @_ ;
- ( $debug or $dry) and myprint( "msg $h1_fold/$h1_msg copying to $h2_fold $dry_message\n" ) ;
+ my ( $mysync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) = @_ ;
+ ( $debug or $mysync->{dry}) and myprint( "msg $h1_fold/$h1_msg copying to $h2_fold $mysync->{dry_message}\n" ) ;
- my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} || 0 ;
- my $h1_flags = $h1_fir_ref->{$h1_msg}->{'FLAGS'} || q{} ;
- my $h1_idate = $h1_fir_ref->{$h1_msg}->{'INTERNALDATE'} || q{} ;
+ my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} || 0 ;
+ my $h1_flags = $h1_fir_ref->{$h1_msg}->{'FLAGS'} || q{} ;
+ my $h1_idate = $h1_fir_ref->{$h1_msg}->{'INTERNALDATE'} || q{} ;
if ( size_filtered( $h1_size, $h1_msg, $h1_fold, $h2_fold ) ) {
- $h1_nb_msg_processed +=1 ;
+ $h1_nb_msg_processed +=1 ;
return ;
}
- debugsleep( $sync ) ;
- myprint( "- msg $h1_fold/$h1_msg S[$h1_size] F[$h1_flags] I[$h1_idate] has RFC822.SIZE null!\n" ) if ( ! $h1_size ) ;
+ 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( $imap1, $h1_msg ) ) {
- $total_bytes_skipped += $h1_size;
- $nb_msg_skipped += 1;
- $h1_nb_msg_processed +=1 ;
+ $total_bytes_skipped += $h1_size;
+ $nb_msg_skipped += 1;
+ $h1_nb_msg_processed +=1 ;
return ;
}
- if ( $sync->{debugmemory} ) {
+ if ( $mysync->{debugmemory} ) {
myprintf("C1: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
}
- my ( $string, $string_len ) ;
- ( $string_len ) = message_for_host2( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, \$string ) ;
+ my ( $string, $string_len ) ;
+ ( $string_len ) = message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, \$string ) ;
- if ( $sync->{debugmemory} ) {
+ if ( $mysync->{debugmemory} ) {
myprintf("C2: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
}
# not defined or empty $string
- if ( ( not $string ) and ( not $string_len ) ) {
- myprint( "- msg $h1_fold/$h1_msg skipped.\n" ) ;
- $total_bytes_skipped += $h1_size;
- $nb_msg_skipped += 1;
- $h1_nb_msg_processed +=1 ;
+ if ( ( not $string ) or ( not $string_len ) ) {
+ myprint( "- msg $h1_fold/$h1_msg skipped.\n" ) ;
+ $total_bytes_skipped += $h1_size;
+ $nb_msg_skipped += 1;
+ $h1_nb_msg_processed += 1 ;
return ;
}
# Lines too long (or not enough) => do no copy or fix
if ( ( defined $maxlinelength ) or ( defined $minmaxlinelength ) ) {
- $string = linelengthstuff( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) ;
- if ( not defined $string ) {
- $h1_nb_msg_processed +=1 ;
- $total_bytes_skipped += $h1_size ;
- $nb_msg_skipped += 1 ;
- return ;
- }
- }
+ $string = linelengthstuff( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) ;
+ if ( not defined $string ) {
+ $h1_nb_msg_processed +=1 ;
+ $total_bytes_skipped += $h1_size ;
+ $nb_msg_skipped += 1 ;
+ return ;
+ }
+ }
- my $h1_date = date_for_host2( $h1_msg, $h1_idate ) ;
+ my $h1_date = date_for_host2( $h1_msg, $h1_idate ) ;
- ( $debug or $debugflags ) and
+ ( $debug or $debugflags ) and
myprint( "Host1 flags init msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ;
- $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ;
+ $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ;
- ( $debug or $debugflags ) and
+ ( $debug or $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{});
+ $h1_date = undef if ($h1_date eq q{});
- my $new_id = append_message_on_host2( \$string, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) ;
+ my $new_id = append_message_on_host2( \$string, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) ;
- if ( $new_id and $syncflagsaftercopy ) {
- sync_flags_after_copy( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $new_id, $permanentflags2 ) ;
+ if ( $new_id and $syncflagsaftercopy ) {
+ sync_flags_after_copy( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $new_id, $permanentflags2 ) ;
}
- if ( $sync->{debugmemory} ) {
- myprintf("C3: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
+ if ( $mysync->{debugmemory} ) {
+ myprintf("C3: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
}
return $new_id ;
@@ -5072,51 +6118,51 @@ sub copy_message {
sub linelengthstuff {
- my( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) = @_ ;
- my $maxlinelength_string = max_line_length( $string ) ;
+ my( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) = @_ ;
+ 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 ;
+ 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] "
+ 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 ;
- }
- return $string ;
+ return ;
+ }
+ return $string ;
}
sub message_for_host2 {
-# global variable list:
+# global variable list:
# @skipmess
# @regexmess
# @pipemess
# $addheader
# $debugcontent
# $debug
-#
+#
# API current
#
-# at failure:
+# at failure:
# * return nothing ( will then be undef or () )
# * $string_ref content is undef or empty
# at success:
@@ -5124,78 +6170,78 @@ sub message_for_host2 {
# * $string_ref content filled with message
# API future
-#
-#
- my ( $sync, $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 ) = @_ ;
# abort when missing a parameter
- if ( (!$sync) or (!$h1_msg) or (!$h1_fold) or (!$h1_size) or (!defined $h1_flags) or (!$h1_idate) or (!$h1_fir_ref) or (!$string_ref) ) {
+ if ( (!$sync) or (!$h1_msg) or (!$h1_fold) or (!$h1_size) or (!defined $h1_flags) or (!defined $h1_idate) or (!$h1_fir_ref) or (!$string_ref) ) {
return ;
}
- if ( $sync->{debugmemory} ) {
+ if ( $mysync->{debugmemory} ) {
myprintf("M1: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
}
- my $imap1 = $sync->{imap1} ;
- my $string_ok = $imap1->message_to_file( $string_ref, $h1_msg ) ;
+ my $imap1 = $mysync->{imap1} ;
+ my $string_ok = $imap1->message_to_file( $string_ref, $h1_msg ) ;
- if ( $sync->{debugmemory} ) {
+ if ( $mysync->{debugmemory} ) {
myprintf("M2: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
}
- my $string_len = length_ref( $string_ref ) ;
+ my $string_len = length_ref( $string_ref ) ;
- unless ( defined $string_ok and $string_len ) {
- # 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: ",
- $imap1->LastError || q{}, "\n" ;
- errors_incr( $sync, $error ) ;
- $total_bytes_error += $h1_size if ( $h1_size ) ;
+ unless ( defined $string_ok and $string_len ) {
+ # 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: ",
+ $imap1->LastError || q{}, "\n" ;
+ errors_incr( $mysync, $error ) ;
+ $total_bytes_error += $h1_size if ( $h1_size ) ;
$h1_nb_msg_processed +=1 ;
- return ;
- }
+ return ;
+ }
- if ( @skipmess ) {
- my $match = skipmess( ${ $string_ref } ) ;
+ if ( @skipmess ) {
+ my $match = skipmess( ${ $string_ref } ) ;
# string undef means the eval regex was bad.
if ( not ( defined $match ) ) {
- myprint(
- "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]"
+ myprint(
+ "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]"
. " could not be skipped by --skipmess option, bad regex\n" ) ;
- return ;
+ return ;
}
if ( $match ) {
my $subject = subject( ${ $string_ref } ) ;
myprint( "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]"
. " (Subject:[$subject]) skipped by --skipmess\n" ) ;
- return ;
+ return ;
}
- }
+ }
- if ( @regexmess ) {
- ${ $string_ref } = regexmess( ${ $string_ref } ) ;
+ if ( @regexmess ) {
+ ${ $string_ref } = regexmess( ${ $string_ref } ) ;
# string undef means the eval regex was bad.
if ( not ( defined ${ $string_ref } ) ) {
- myprint(
- "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]"
+ myprint(
+ "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]"
. " could not be transformed by --regexmess\n" ) ;
- return ;
+ return ;
}
- }
+ }
- if ( @pipemess ) {
- ${ $string_ref } = pipemess( ${ $string_ref }, @pipemess ) ;
+ if ( @pipemess ) {
+ ${ $string_ref } = pipemess( ${ $string_ref }, @pipemess ) ;
# string undef means something was bad.
if ( not ( defined ${ $string_ref } ) ) {
- myprint(
- "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]"
+ myprint(
+ "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]"
. " could not be successfully transformed by --pipemess option\n" ) ;
- return ;
+ return ;
}
- }
+ }
if ( $addheader and defined $h1_fir_ref->{$h1_msg}->{'NO_HEADER'} ) {
my $header = add_header( $h1_msg ) ;
@@ -5205,85 +6251,89 @@ sub message_for_host2 {
$string_len = length_ref( $string_ref ) ;
- $debugcontent and myprint(
- q{=} x $STD_CHAR_PER_LINE, "\n",
- "F message content begin next line ($string_len characters long)\n",
- ${ $string_ref },
- "F message content ended on previous line\n", q{=} x $STD_CHAR_PER_LINE, "\n" ) ;
+ $debugcontent and myprint(
+ q{=} x $STD_CHAR_PER_LINE, "\n",
+ "F message content begin next line ($string_len characters long)\n",
+ ${ $string_ref },
+ "F message content ended on previous line\n", q{=} x $STD_CHAR_PER_LINE, "\n" ) ;
- if ( $sync->{debugmemory} ) {
+ if ( $mysync->{debugmemory} ) {
myprintf("M3: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
}
- return $string_len ;
+ return $string_len ;
}
sub tests_message_for_host2 {
-
- my ( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) ;
-
+ note( 'Entering tests_message_for_host2()' ) ;
+
+
+ my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) ;
+
is( undef, message_for_host2( ), q{message_for_host2: no args} ) ;
- is( undef, message_for_host2( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), q{message_for_host2: undef args} ) ;
+ is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), q{message_for_host2: undef args} ) ;
require Test::MockObject ;
my $imapT = Test::MockObject->new( ) ;
- $sync->{imap1} = $imapT ;
+ $mysync->{imap1} = $imapT ;
my $string ;
-
+
$h1_msg = 1 ;
$h1_fold = 'FoldFoo';
- $h1_size = 9 ;
- $h1_flags = '' ;
+ $h1_size = 9 ;
+ $h1_flags = '' ;
$h1_idate = '10-Jul-2015 09:00:00 +0200' ;
$h1_fir_ref = {} ;
$string_ref = \$string ;
- $imapT->mock( 'message_to_file',
+ $imapT->mock( 'message_to_file',
sub {
- my ( $imap, $string_ref, $msg ) = @_ ;
- ${$string_ref} = 'blablabla' ;
- return length ${$string_ref} ;
+ my ( $imap, $mystring_ref, $msg ) = @_ ;
+ ${$mystring_ref} = 'blablabla' ;
+ return length ${$mystring_ref} ;
}
) ;
- is( 9, message_for_host2( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
+ is( 9, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
q{message_for_host2: msg 1 == "blablabla", length} ) ;
is( 'blablabla', $string, q{message_for_host2: msg 1 == "blablabla", value} ) ;
-
+
# so far so good
# now the --pipemess stuff
- SKIP: {
+ SKIP: {
Readonly my $NB_WIN_tests_message_for_host2 => 0 ;
- skip( 'Not on MSWin32', $NB_WIN_tests_message_for_host2 ) if ('MSWin32' ne $OSNAME) ;
- # Windows
- # "type" command does not accept redirection of STDIN with <
- # "sort" does
+ skip( 'Not on MSWin32', $NB_WIN_tests_message_for_host2 ) if ('MSWin32' ne $OSNAME) ;
+ # Windows
+ # "type" command does not accept redirection of STDIN with <
+ # "sort" does
- } ;
+ } ;
- SKIP: {
+ SKIP: {
Readonly my $NB_UNX_tests_message_for_host2 => 6 ;
- skip( 'Not on Unix', $NB_UNX_tests_message_for_host2 ) if ('MSWin32' eq $OSNAME) ;
- # Unix
-
+ skip( 'Not on Unix', $NB_UNX_tests_message_for_host2 ) if ('MSWin32' eq $OSNAME) ;
+ # Unix
+
# no change by cat
@pipemess = ( 'cat' ) ;
- is( 9, message_for_host2( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
+ is( 9, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
q{message_for_host2: --pipemess 'cat', length} ) ;
is( 'blablabla', $string, q{message_for_host2: --pipemess 'cat', value} ) ;
-
+
# failure by false
@pipemess = ( 'false' ) ;
- is( undef, message_for_host2( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
+ is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
q{message_for_host2: --pipemess 'false', length} ) ;
is( undef, $string, q{message_for_host2: --pipemess 'false', value} ) ;
# failure by true since no output
@pipemess = ( 'true' ) ;
- is( undef, message_for_host2( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
+ is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
q{message_for_host2: --pipemess 'true', length} ) ;
is( undef, $string, q{message_for_host2: --pipemess 'true', value} ) ;
}
+
+ note( 'Leaving tests_message_for_host2()' ) ;
return ;
}
@@ -5294,6 +6344,8 @@ sub length_ref {
}
sub tests_length_ref {
+ note( 'Entering tests_length_ref()' ) ;
+
my $notdefined ;
is( q{}, length_ref( \$notdefined ), q{length_ref: value not defined} ) ;
my $notref ;
@@ -5302,200 +6354,257 @@ sub tests_length_ref {
my $lala = 'lala' ;
is( 4, length_ref( \$lala ), q{length_ref: lala length == 4} ) ;
is( 4, length_ref( \'lili' ), q{length_ref: lili length == 4} ) ;
+
+ note( 'Leaving tests_length_ref()' ) ;
return ;
}
sub date_for_host2 {
- my( $h1_msg, $h1_idate ) = @_ ;
+ my( $h1_msg, $h1_idate ) = @_ ;
- my $h1_date = q{} ;
+ my $h1_date = q{} ;
- if ( $syncinternaldates ) {
- $h1_date = $h1_idate ;
- $debug and myprint( "internal date from host1: [$h1_date]\n" ) ;
- $h1_date = good_date( $h1_date ) ;
- $debug and myprint( "internal date from host1: [$h1_date] (fixed)\n" ) ;
- }
+ if ( $syncinternaldates ) {
+ $h1_date = $h1_idate ;
+ $debug and myprint( "internal date from host1: [$h1_date]\n" ) ;
+ $h1_date = good_date( $h1_date ) ;
+ $debug and myprint( "internal date from host1: [$h1_date] (fixed)\n" ) ;
+ }
- if ( $idatefromheader ) {
- $h1_date = $imap1->get_header( $h1_msg, 'Date' ) ;
- $debug and myprint( "header date from host1: [$h1_date]\n" ) ;
- $h1_date = good_date( $h1_date ) ;
- $debug and myprint( "header date from host1: [$h1_date] (fixed)\n" ) ;
- }
+ if ( $idatefromheader ) {
+ $h1_date = $imap1->get_header( $h1_msg, 'Date' ) ;
+ $debug and myprint( "header date from host1: [$h1_date]\n" ) ;
+ $h1_date = good_date( $h1_date ) ;
+ $debug and myprint( "header date from host1: [$h1_date] (fixed)\n" ) ;
+ }
- return( $h1_date ) ;
+ return( $h1_date ) ;
}
sub flags_for_host2 {
- my( $h1_flags, $permanentflags2 ) = @_ ;
- # RFC 2060: This flag can not be altered by any client
- $h1_flags =~ s@\\Recent\s?@@xgi ;
+ my( $h1_flags, $permanentflags2 ) = @_ ;
+ # RFC 2060: This flag can not be altered by any client
+ $h1_flags =~ s@\\Recent\s?@@xgi ;
my $h1_flags_re ;
if ( @regexflag and defined( $h1_flags_re = flags_regex( $h1_flags ) ) ) {
$h1_flags = $h1_flags_re ;
}
- $h1_flags = flagscase( $h1_flags ) if $flagscase ;
+ $h1_flags = flagscase( $h1_flags ) if $flagscase ;
$h1_flags = flags_filter( $h1_flags, $permanentflags2) if ( $permanentflags2 and $filterflags ) ;
- return( $h1_flags ) ;
+ return( $h1_flags ) ;
}
sub subject {
- my $string = shift ;
- my $subject = q{} ;
+ my $string = shift ;
+ my $subject = q{} ;
my $header = extract_header( $string ) ;
if( $header =~ m/^Subject:\s*([^\n\r]*)\r?$/msx ) {
- #myprint( "MMM[$1]\n" ) ;
- $subject = $1 ;
+ #myprint( "MMM[$1]\n" ) ;
+ $subject = $1 ;
}
- return( $subject ) ;
+ return( $subject ) ;
}
sub tests_subject {
- ok( q{} eq subject( q{} ), 'subject: null') ;
- ok( 'toto le hero' eq subject( 'Subject: toto le hero' ), 'subject: toto le hero') ;
- ok( 'toto le hero' eq subject( 'Subject:toto le hero' ), 'subject: toto le hero blank') ;
- ok( 'toto le hero' eq subject( "Subject:toto le hero\r\n" ), 'subject: toto le hero\r\n') ;
+ note( 'Entering tests_subject()' ) ;
+
+ ok( q{} eq subject( q{} ), 'subject: null') ;
+ ok( 'toto le hero' eq subject( 'Subject: toto le hero' ), 'subject: toto le hero') ;
+ ok( 'toto le hero' eq subject( 'Subject:toto le hero' ), 'subject: toto le hero blank') ;
+ ok( 'toto le hero' eq subject( "Subject:toto le hero\r\n" ), 'subject: toto le hero\r\n') ;
my $MESS ;
- $MESS = <<'EOF';
+ $MESS = <<'EOF';
From: lalala
Subject: toto le hero
Date: zzzzzz
Boogie boogie
EOF
- ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 2') ;
+ ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 2') ;
- $MESS = <<'EOF';
+ $MESS = <<'EOF';
Subject: toto le hero
From: lalala
Date: zzzzzz
Boogie boogie
EOF
- ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 3') ;
+ ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 3') ;
- $MESS = <<'EOF';
+ $MESS = <<'EOF';
From: lalala
Subject: cuicui
Date: zzzzzz
Subject: toto le hero
EOF
- ok( 'cuicui' eq subject( $MESS ), 'subject: cuicui') ;
+ ok( 'cuicui' eq subject( $MESS ), 'subject: cuicui') ;
- $MESS = <<'EOF';
+ $MESS = <<'EOF';
From: lalala
Date: zzzzzz
Subject: toto le hero
EOF
- ok( q{} eq subject( $MESS ), 'subject: null but body could') ;
+ ok( q{} eq subject( $MESS ), 'subject: null but body could') ;
- return ;
+ note( 'Leaving tests_subject()' ) ;
+ return ;
}
# GlobVar
-# $dry
+# $sync
# $max_msg_size_in_bytes
# $imap2
# $imap1
# $total_bytes_error
# $h1_nb_msg_processed
# $h2_uidguess
-# $total_bytes_transferred
-# $nb_msg_transferred
-# $begin_transfer_time
-# $time_spent
# ...
#
#
sub append_message_on_host2 {
- my( $string_ref, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) = @_ ;
- if ( $sync->{debugmemory} ) {
- myprintf("A1: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
+ my( $string_ref, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) = @_ ;
+ if ( $sync->{debugmemory} ) {
+ myprintf("A1: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
}
- my $new_id ;
- if ( ! $dry ) {
- $max_msg_size_in_bytes = max( $h1_size, $max_msg_size_in_bytes ) ;
- $new_id = $imap2->append_string( $h2_fold, ${ $string_ref }, $h1_flags, $h1_date ) ;
- if ( $sync->{debugmemory} ) {
- myprintf("A2: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
+ my $new_id ;
+ if ( ! $sync->{dry} ) {
+ $max_msg_size_in_bytes = max( $h1_size, $max_msg_size_in_bytes ) ;
+ $new_id = $imap2->append_string( $h2_fold, ${ $string_ref }, $h1_flags, $h1_date ) ;
+ if ( $sync->{debugmemory} ) {
+ myprintf("A2: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
}
- if ( ! $new_id){
- my $subject = subject( ${ $string_ref } ) ;
+ if ( ! $new_id){
+ my $subject = subject( ${ $string_ref } ) ;
my $error_imap = $imap2->LastError || q{} ;
- my $error = "- msg $h1_fold/$h1_msg {$string_len} couldn't append (Subject:[$subject]) to folder $h2_fold: $error_imap\n" ;
- errors_incr( $sync, $error ) ;
- $total_bytes_error += $h1_size;
+ my $error = "- msg $h1_fold/$h1_msg {$string_len} could not append ( Subject:[$subject], Date:[$h1_date], Size:[$h1_size] ) to folder $h2_fold: $error_imap\n" ;
+ errors_incr( $sync, $error ) ;
+ $total_bytes_error += $h1_size;
$h1_nb_msg_processed +=1 ;
- return ;
- }
- else{
- # good
- # $new_id is an id if the IMAP server has the
- # UIDPLUS capability else just a ref
- if ( $new_id !~ m{^\d+$}x ) {
- $new_id = lastuid( $imap2, $h2_fold, $h2_uidguess ) ;
- }
- $h2_uidguess += 1 ;
- $total_bytes_transferred += $h1_size ;
- $nb_msg_transferred += 1 ;
+ return ;
+ }
+ else{
+ # good
+ # $new_id is an id if the IMAP server has the
+ # UIDPLUS capability else just a ref
+ if ( $new_id !~ m{^\d+$}x ) {
+ $new_id = lastuid( $imap2, $h2_fold, $h2_uidguess ) ;
+ }
+ $h2_uidguess += 1 ;
+ $sync->{total_bytes_transferred} += $h1_size ;
+ $sync->{nb_msg_transferred} += 1 ;
$h1_nb_msg_processed +=1 ;
- my $time_spent = timesince( $begin_transfer_time ) ;
- my $rate = bytes_display_string( $total_bytes_transferred / $time_spent ) ;
+ my $time_spent = timesince( $sync->{begin_transfer_time} ) ;
+ my $rate = bytes_display_string( $sync->{total_bytes_transferred} / $time_spent ) ;
my $eta = eta( $time_spent,
- $h1_nb_msg_processed, $h1_nb_msg_start, $nb_msg_transferred ) ;
- my $amount_transferred = bytes_display_string( $total_bytes_transferred ) ;
- myprintf( "msg %s/%-19s copied to %s/%-10s %.2f msgs/s %s/s %s copied %s\n",
- $h1_fold, "$h1_msg {$string_len}", $h2_fold, $new_id, $nb_msg_transferred/$time_spent, $rate,
+ $h1_nb_msg_processed, $h1_nb_msg_start, $sync->{nb_msg_transferred} ) ;
+ my $amount_transferred = bytes_display_string( $sync->{total_bytes_transferred} ) ;
+ myprintf( "msg %s/%-19s copied to %s/%-10s %.2f msgs/s %s/s %s copied %s\n",
+ $h1_fold, "$h1_msg {$string_len}", $h2_fold, $new_id, $sync->{nb_msg_transferred}/$time_spent, $rate,
$amount_transferred,
$eta );
- sleep_if_needed( $time_spent, $total_bytes_transferred, $nb_msg_transferred ) ;
+ sleep_if_needed( $sync ) ;
if ( $usecache and $cacheaftercopy and $new_id =~ m{^\d+$}x ) {
- $debugcache and myprint( "touch $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" ) ;
+ $debugcache and myprint( "touch $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" ) ;
}
- if ( $delete ) {
- delete_message_on_host1( $h1_msg, $h1_fold ) ;
- }
- #myprint( "PRESS ENTER" ) and my $a = <> ;
+ if ( $delete1 ) {
+ delete_message_on_host1( $h1_msg, $h1_fold ) ;
+ }
+ #myprint( "PRESS ENTER" ) and my $a = <> ;
return( $new_id ) ;
- }
- }
- else{
- # NOOP to avoid timeout on large folders.
- $imap2->noop( ) ;
- $nb_msg_skipped_dry_mode += 1 ;
+ }
+ }
+ else{
+ $nb_msg_skipped_dry_mode += 1 ;
$h1_nb_msg_processed +=1 ;
- }
+ }
+
+ return ;
+}
+
+sub tests_sleep_if_needed {
+ note( 'Entering tests_sleep_if_needed()' ) ;
+ is( undef, sleep_if_needed( ), 'sleep_if_needed: no args => undef' ) ;
+ my $mysync ;
+ is( undef, sleep_if_needed( $mysync ), 'sleep_if_needed: arg undef => undef' ) ;
+
+ $mysync->{maxbytespersecond} = 1000 ;
+ is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: maxbytespersecond only => no sleep => 0' ) ;
+ $mysync->{begin_transfer_time} = time ; # now
+ is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: begin_transfer_time now => no sleep => 0' ) ;
+ $mysync->{begin_transfer_time} = time - 2 ; # 2 s before
+ is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 0 => no sleep => 0' ) ;
+
+ $mysync->{total_bytes_transferred} = 2200 ;
+ $mysync->{begin_transfer_time} = time - 2 ; # 2 s before
+ is( '0.20', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 2200 since 2s => sleep 0.2s' ) ;
+ is( '0', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 2200 since 2+2 == 4s => no sleep' ) ;
+
+ $mysync->{maxsleep} = 0.1 ;
+ $mysync->{begin_transfer_time} = time - 2 ; # 2 s before again
+ is( '0.10', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 4000 since 2s but maxsleep 0.1s => sleep 0.1s' ) ;
+
+ $mysync->{maxbytesafter} = 4000 ;
+ $mysync->{begin_transfer_time} = time - 2 ; # 2 s before again
+ is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: maxbytesafter == total_bytes_transferred => no sleep => 0' ) ;
+
+ note( 'Leaving tests_sleep_if_needed()' ) ;
return ;
}
+
sub sleep_if_needed {
- my( $time_spent, $total_bytes_transferred, $nb_msg_transferred ) = @_ ;
- my $sleep_max_messages = sleep_max_messages( $nb_msg_transferred, $time_spent, $maxmessagespersecond ) ;
- my $sleep_max_bytes = sleep_max_bytes( $total_bytes_transferred, $time_spent, $maxbytespersecond ) ;
- my $sleep_max = max( $sleep_max_messages, $sleep_max_bytes ) ;
+ my( $mysync ) = shift ;
+
+ if ( ! $mysync ) {
+ return ;
+ }
+ # No need to go further if there is no limit set
+ if ( not ( $mysync->{maxmessagespersecond}
+ or $mysync->{maxbytespersecond} )
+ ) {
+ return ;
+ }
+
+ $mysync->{maxsleep} = defined $mysync->{maxsleep} ? $mysync->{maxsleep} : $MAX_SLEEP ;
+
+ my $time_spent = timesince( $mysync->{begin_transfer_time} ) ;
+ my $sleep_max_messages = sleep_max_messages( $mysync->{nb_msg_transferred}, $time_spent, $mysync->{maxmessagespersecond} ) ;
+
+ my $maxbytesafter = $mysync->{maxbytesafter} || 0 ;
+ my $total_bytes_transferred = $mysync->{total_bytes_transferred} || 0 ;
+ my $total_bytes_to_consider = $total_bytes_transferred - $maxbytesafter ;
+
+ #myprint( "maxbytesafter:$maxbytesafter\n" ) ;
+ #myprint( "total_bytes_to_consider:$total_bytes_to_consider\n" ) ;
+
+ my $sleep_max_bytes = sleep_max_bytes( $total_bytes_to_consider, $time_spent, $mysync->{maxbytespersecond} ) ;
+ my $sleep_max = min( $mysync->{maxsleep}, max( $sleep_max_messages, $sleep_max_bytes ) ) ;
+ $sleep_max = mysprintf( "%.2f", $sleep_max ) ; # round with 2 decimals.
if ( $sleep_max > 0 ) {
- myprintf( "sleeping %.2f s\n", $sleep_max ) ;
+ myprint( "sleeping $sleep_max s\n" ) ;
sleep $sleep_max ;
+ # Slept
+ return $sleep_max ;
}
- return ;
+ # No sleep
+ return 0 ;
}
sub sleep_max_messages {
- # how long we have to sleep to go under max_messages_per_second
+ # how long we have to sleep to go under max_messages_per_second
my( $nb_msg_transferred, $time_spent, $maxmessagespersecond ) = @_ ;
if ( ( not defined $maxmessagespersecond ) or $maxmessagespersecond <= 0 ) { return( 0 ) } ;
my $sleep = ( $nb_msg_transferred / $maxmessagespersecond ) - $time_spent ;
@@ -5505,417 +6614,454 @@ sub sleep_max_messages {
sub tests_sleep_max_messages {
- ok( 0 == sleep_max_messages( 4, 2, undef ), 'sleep_max_messages: maxmessagespersecond = undef') ;
- ok( 0 == sleep_max_messages( 4, 2, 0 ), 'sleep_max_messages: maxmessagespersecond = 0') ;
- ok( 0 == sleep_max_messages( 4, 2, $MINUS_ONE ), 'sleep_max_messages: maxmessagespersecond = -1') ;
- ok( 0 == sleep_max_messages( 4, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max reached') ;
- ok( 2 == sleep_max_messages( 8, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max over') ;
- ok( 0 == sleep_max_messages( 2, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max not reached') ;
- return ;
+ note( 'Entering tests_sleep_max_messages()' ) ;
+
+ ok( 0 == sleep_max_messages( 4, 2, undef ), 'sleep_max_messages: maxmessagespersecond = undef') ;
+ ok( 0 == sleep_max_messages( 4, 2, 0 ), 'sleep_max_messages: maxmessagespersecond = 0') ;
+ ok( 0 == sleep_max_messages( 4, 2, $MINUS_ONE ), 'sleep_max_messages: maxmessagespersecond = -1') ;
+ ok( 0 == sleep_max_messages( 4, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max reached') ;
+ ok( 2 == sleep_max_messages( 8, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max over') ;
+ ok( 0 == sleep_max_messages( 2, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max not reached') ;
+
+ note( 'Leaving tests_sleep_max_messages()' ) ;
+ return ;
}
sub sleep_max_bytes {
- # how long we have to sleep to go under max_bytes_per_second
- my( $total_bytes_transferred, $time_spent, $maxbytespersecond ) = @_ ;
+ # how long we have to sleep to go under max_bytes_per_second
+ my( $total_bytes_to_consider, $time_spent, $maxbytespersecond ) = @_ ;
+ $total_bytes_to_consider ||= 0 ;
+ $time_spent ||= 0 ;
+
if ( ( not defined $maxbytespersecond ) or $maxbytespersecond <= 0 ) { return( 0 ) } ;
- my $sleep = ( $total_bytes_transferred / $maxbytespersecond ) - $time_spent ;
+ #myprint( "total_bytes_to_consider:$total_bytes_to_consider\n" ) ;
+ my $sleep = ( $total_bytes_to_consider / $maxbytespersecond ) - $time_spent ;
# the sleep must be positive
return( max( 0, $sleep ) ) ;
}
sub tests_sleep_max_bytes {
- ok( 0 == sleep_max_bytes( 4000, 2, undef ), 'sleep_max_bytes: maxbytespersecond = undef') ;
- ok( 0 == sleep_max_bytes( 4000, 2, 0 ), 'sleep_max_bytes: maxbytespersecond = 0') ;
- ok( 0 == sleep_max_bytes( 4000, 2, $MINUS_ONE ), 'sleep_max_bytes: maxbytespersecond = -1') ;
- ok( 0 == sleep_max_bytes( 4000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2 max reached') ;
- ok( 2 == sleep_max_bytes( 8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2 max over') ;
- ok( 0 == sleep_max_bytes( 2000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2 max not reached') ;
- return ;
+ note( 'Entering tests_sleep_max_bytes()' ) ;
+
+ ok( 0 == sleep_max_bytes( 4000, 2, undef ), 'sleep_max_bytes: maxbytespersecond == undef => sleep 0' ) ;
+ ok( 0 == sleep_max_bytes( 4000, 2, 0 ), 'sleep_max_bytes: maxbytespersecond = 0 => sleep 0') ;
+ ok( 0 == sleep_max_bytes( 4000, 2, $MINUS_ONE ), 'sleep_max_bytes: maxbytespersecond = -1 => sleep 0') ;
+ ok( 0 == sleep_max_bytes( 4000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max reached sharp => sleep 0') ;
+ ok( 2 == sleep_max_bytes( 8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max over => sleep a little') ;
+ ok( 0 == sleep_max_bytes( -8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max not reached => sleep 0') ;
+ ok( 0 == sleep_max_bytes( 2000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max not reached => sleep 0') ;
+ ok( 0 == sleep_max_bytes( -2000, 2, 1000 ), 'sleep_max_bytes: maxbytespersecond = 1k max not reached => sleep 0') ;
+
+ note( 'Leaving tests_sleep_max_bytes()' ) ;
+ return ;
}
-# 6 GlobVar: $dry_message $dry $imap1 $h1_nb_msg_deleted $expunge $expunge1
+# 6 GlobVar: $sync $imap1 $h1_nb_msg_deleted $expunge1
sub delete_message_on_host1 {
- my( $h1_msg, $h1_fold ) = @_ ;
- my $expunge_message = q{} ;
- $expunge_message = 'and expunged' if ( $expungeaftereach and ( $expunge or $expunge1 ) ) ;
- myprint( "Host1 msg $h1_fold/$h1_msg marked deleted $expunge_message $dry_message\n" ) ;
- if ( ! $dry ) {
- $imap1->delete_message( $h1_msg ) ;
- $h1_nb_msg_deleted += 1 ;
- $imap1->expunge( ) if ( $expungeaftereach and ( $expunge or $expunge1 ) ) ;
+ my( $h1_msg, $h1_fold ) = @_ ;
+ my $expunge_message = q{} ;
+ $expunge_message = 'and expunged' if ( $expungeaftereach and $expunge1 ) ;
+ myprint( "Host1 msg $h1_fold/$h1_msg marked deleted $expunge_message $sync->{dry_message}\n" ) ;
+ if ( ! $sync->{dry} ) {
+ $imap1->delete_message( $h1_msg ) ;
+ $h1_nb_msg_deleted += 1 ;
+ $imap1->expunge( ) if ( $expungeaftereach and $expunge1 ) ;
}
return ;
}
sub eta {
- my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @_ ;
- return( q{} ) if not $foldersizes ;
+ my( $my_time_spent, $h1_nb_processed, $my_h1_nb_msg_start, $nb_transferred ) = @_ ;
+ return( q{} ) if not $foldersizes ;
- my $time_remaining = time_remaining( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) ;
- my $nb_msg_remaining = $h1_nb_msg_start - $h1_nb_processed ;
+ my $time_remaining = time_remaining( $my_time_spent, $h1_nb_processed, $my_h1_nb_msg_start, $nb_transferred ) ;
+ my $nb_msg_remaining = $my_h1_nb_msg_start - $h1_nb_processed ;
my $eta_date = localtime( time + $time_remaining ) ;
- return( mysprintf( 'ETA: %s %1.0f s %s/%s msgs left', $eta_date, $time_remaining, $nb_msg_remaining, $h1_nb_msg_start ) ) ;
+ return( mysprintf( 'ETA: %s %1.0f s %s/%s msgs left', $eta_date, $time_remaining, $nb_msg_remaining, $my_h1_nb_msg_start ) ) ;
}
sub time_remaining {
- my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @_ ;
+ my( $my_time_spent, $h1_nb_processed, $my_h1_nb_msg_start, $nb_transferred ) = @_ ;
- my $time_remaining = ( $my_time_spent / $nb_transferred ) * ( $h1_nb_msg_start - $h1_nb_processed ) ;
- return( $time_remaining ) ;
+ my $time_remaining = ( $my_time_spent / $nb_transferred ) * ( $my_h1_nb_msg_start - $h1_nb_processed ) ;
+ return( $time_remaining ) ;
}
sub tests_time_remaining {
+ note( 'Entering tests_time_remaining()' ) ;
- ok( 1 == time_remaining( 1, 1, 2, 1 ), 'time_remaining: 1, 1, 2, 1 -> 1' ) ;
- ok( 1 == time_remaining( 9, 9, 10, 9 ), 'time_remaining: 9, 9, 10, 9 -> 1' ) ;
- ok( 9 == time_remaining( 1, 1, 10, 1 ), 'time_remaining: 1, 1, 10, 1 -> 1' ) ;
- return ;
+
+ ok( 1 == time_remaining( 1, 1, 2, 1 ), 'time_remaining: 1, 1, 2, 1 -> 1' ) ;
+ ok( 1 == time_remaining( 9, 9, 10, 9 ), 'time_remaining: 9, 9, 10, 9 -> 1' ) ;
+ ok( 9 == time_remaining( 1, 1, 10, 1 ), 'time_remaining: 1, 1, 10, 1 -> 1' ) ;
+
+ note( 'Leaving tests_time_remaining()' ) ;
+ return ;
}
sub cache_map {
- my ( $cache_files_ref, $h1_msgs_ref, $h2_msgs_ref ) = @_;
- my ( %map1_2, %map2_1, %done2 ) ;
-
- my $h1_msgs_hash_ref = { } ;
- my $h2_msgs_hash_ref = { } ;
-
- @{ $h1_msgs_hash_ref }{ @{ $h1_msgs_ref } } = ( ) ;
- @{ $h2_msgs_hash_ref }{ @{ $h2_msgs_ref } } = ( ) ;
-
- foreach my $file ( sort @{ $cache_files_ref } ) {
- $debugcache and myprint( "C12: $file\n" ) ;
- ( $uid1, $uid2 ) = match_a_cache_file( $file ) ;
-
- if ( exists( $h1_msgs_hash_ref->{ defined $uid1 ? $uid1 : q{} } )
- and exists( $h2_msgs_hash_ref->{ defined $uid2 ? $uid2 : q{} } ) ) {
- # keep only the greatest uid2
- # 130_2301 and
- # 130_231 => keep only 130 -> 2301
-
- # keep only the greatest uid1
- # 1601_260 and
- # 161_260 => keep only 1601 -> 260
- my $max_uid2 = max( $uid2, $map1_2{ $uid1 } || $MINUS_ONE ) ;
- if ( exists $done2{ $max_uid2 } ) {
- if ( $done2{ $max_uid2 } < $uid1 ) {
- $map1_2{ $uid1 } = $max_uid2 ;
- delete $map1_2{ $done2{ $max_uid2 } } ;
- $done2{ $max_uid2 } = $uid1 ;
- }
- }else{
- $map1_2{ $uid1 } = $max_uid2 ;
- $done2{ $max_uid2 } = $uid1 ;
- }
- };
+ my ( $cache_files_ref, $h1_msgs_ref, $h2_msgs_ref ) = @_;
+ my ( %map1_2, %map2_1, %done2 ) ;
+
+ my $h1_msgs_hash_ref = { } ;
+ my $h2_msgs_hash_ref = { } ;
+
+ @{ $h1_msgs_hash_ref }{ @{ $h1_msgs_ref } } = ( ) ;
+ @{ $h2_msgs_hash_ref }{ @{ $h2_msgs_ref } } = ( ) ;
+
+ foreach my $file ( sort @{ $cache_files_ref } ) {
+ $debugcache and myprint( "C12: $file\n" ) ;
+ ( $uid1, $uid2 ) = match_a_cache_file( $file ) ;
+
+ if ( exists( $h1_msgs_hash_ref->{ defined $uid1 ? $uid1 : q{} } )
+ and exists( $h2_msgs_hash_ref->{ defined $uid2 ? $uid2 : q{} } ) ) {
+ # keep only the greatest uid2
+ # 130_2301 and
+ # 130_231 => keep only 130 -> 2301
+
+ # keep only the greatest uid1
+ # 1601_260 and
+ # 161_260 => keep only 1601 -> 260
+ my $max_uid2 = max( $uid2, $map1_2{ $uid1 } || $MINUS_ONE ) ;
+ if ( exists $done2{ $max_uid2 } ) {
+ if ( $done2{ $max_uid2 } < $uid1 ) {
+ $map1_2{ $uid1 } = $max_uid2 ;
+ delete $map1_2{ $done2{ $max_uid2 } } ;
+ $done2{ $max_uid2 } = $uid1 ;
+ }
+ }else{
+ $map1_2{ $uid1 } = $max_uid2 ;
+ $done2{ $max_uid2 } = $uid1 ;
+ }
+ };
- }
- %map2_1 = reverse %map1_2 ;
- return( \%map1_2, \%map2_1) ;
+ }
+ %map2_1 = reverse %map1_2 ;
+ return( \%map1_2, \%map2_1) ;
}
sub tests_cache_map {
- #$debugcache = 1 ;
- my @cache_files = qw (
- 100_200
- 101_201
- 120_220
- 142_242
- 143_243
- 177_277
- 177_278
- 177_279
- 155_255
- 180_280
- 181_280
- 182_280
- 130_231
- 130_2301
- 161_260
- 1601_260
- ) ;
+ note( 'Entering tests_cache_map()' ) ;
+
+ #$debugcache = 1 ;
+ my @cache_files = qw (
+ 100_200
+ 101_201
+ 120_220
+ 142_242
+ 143_243
+ 177_277
+ 177_278
+ 177_279
+ 155_255
+ 180_280
+ 181_280
+ 182_280
+ 130_231
+ 130_2301
+ 161_260
+ 1601_260
+ ) ;
- my $msgs_1 = [120, 142, 143, 144, 161, 1601, 177, 182, 130 ];
- my $msgs_2 = [ 242, 243, 260, 299, 377, 279, 255, 280, 231, 2301 ];
-
- my( $c12, $c21 ) ;
- ok( ( $c12, $c21 ) = cache_map( \@cache_files, $msgs_1, $msgs_2 ), 'cache_map: 02' );
- my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ;
- my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ;
- ok( 0 == compare_lists( [ 130, 142, 143, 177, 182, 1601 ], $a1 ), 'cache_map: 03' );
- ok( 0 == compare_lists( [ 242, 243, 260, 279, 280, 2301 ], $a2 ), 'cache_map: 04' );
- ok( ! $c12->{161}, 'cache_map: ! 161 -> 260' );
- ok( 260 == $c12->{1601}, 'cache_map: 1601 -> 260' );
- ok( 2301 == $c12->{130}, 'cache_map: 130 -> 2301' );
- #myprint( $c12->{1601}, "\n" ) ;
- return ;
+ my $msgs_1 = [120, 142, 143, 144, 161, 1601, 177, 182, 130 ];
+ my $msgs_2 = [ 242, 243, 260, 299, 377, 279, 255, 280, 231, 2301 ];
+
+ my( $c12, $c21 ) ;
+ ok( ( $c12, $c21 ) = cache_map( \@cache_files, $msgs_1, $msgs_2 ), 'cache_map: 02' );
+ my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ;
+ my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ;
+ ok( 0 == compare_lists( [ 130, 142, 143, 177, 182, 1601 ], $a1 ), 'cache_map: 03' );
+ ok( 0 == compare_lists( [ 242, 243, 260, 279, 280, 2301 ], $a2 ), 'cache_map: 04' );
+ ok( ! $c12->{161}, 'cache_map: ! 161 -> 260' );
+ ok( 260 == $c12->{1601}, 'cache_map: 1601 -> 260' );
+ ok( 2301 == $c12->{130}, 'cache_map: 130 -> 2301' );
+ #myprint( $c12->{1601}, "\n" ) ;
+
+ note( 'Leaving tests_cache_map()' ) ;
+ return ;
}
sub cache_dir_fix {
- my $cache_dir = shift ;
+ my $cache_dir = shift ;
$cache_dir =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\])/\\$1/xg ;
#myprint( "cache_dir_fix: $cache_dir\n" ) ;
- return( $cache_dir ) ;
+ return( $cache_dir ) ;
}
sub tests_cache_dir_fix {
- ok( 'lalala' eq cache_dir_fix('lalala'), 'cache_dir_fix: lalala -> lalala' );
- ok( 'ii\\\\ii' eq cache_dir_fix('ii\ii'), 'cache_dir_fix: ii\ii -> ii\\\\ii' );
- ok( 'ii@ii' eq cache_dir_fix('ii@ii'), 'cache_dir_fix: ii@ii -> ii@ii' );
- ok( 'ii@ii\\:ii' eq cache_dir_fix('ii@ii:ii'), 'cache_dir_fix: ii@ii:ii -> ii@ii\\:ii' );
- ok( 'i\\\\i\\\\ii' eq cache_dir_fix('i\i\ii'), 'cache_dir_fix: i\i\ii -> i\\\\i\\\\ii' );
- ok( 'i\\\\ii' eq cache_dir_fix('i\\ii'), 'cache_dir_fix: i\\ii -> i\\\\\\\\ii' );
- ok( '\\\\ ' eq cache_dir_fix('\\ '), 'cache_dir_fix: \\ -> \\\\\ ' );
- ok( '\\\\ ' eq cache_dir_fix('\ '), 'cache_dir_fix: \ -> \\\\\ ' );
- ok( '\[bracket\]' eq cache_dir_fix('[bracket]'), 'cache_dir_fix: [bracket] -> \[bracket\]' );
- return ;
+ note( 'Entering tests_cache_dir_fix()' ) ;
+
+ ok( 'lalala' eq cache_dir_fix('lalala'), 'cache_dir_fix: lalala -> lalala' );
+ ok( 'ii\\\\ii' eq cache_dir_fix('ii\ii'), 'cache_dir_fix: ii\ii -> ii\\\\ii' );
+ ok( 'ii@ii' eq cache_dir_fix('ii@ii'), 'cache_dir_fix: ii@ii -> ii@ii' );
+ ok( 'ii@ii\\:ii' eq cache_dir_fix('ii@ii:ii'), 'cache_dir_fix: ii@ii:ii -> ii@ii\\:ii' );
+ ok( 'i\\\\i\\\\ii' eq cache_dir_fix('i\i\ii'), 'cache_dir_fix: i\i\ii -> i\\\\i\\\\ii' );
+ ok( 'i\\\\ii' eq cache_dir_fix('i\\ii'), 'cache_dir_fix: i\\ii -> i\\\\\\\\ii' );
+ ok( '\\\\ ' eq cache_dir_fix('\\ '), 'cache_dir_fix: \\ -> \\\\\ ' );
+ ok( '\\\\ ' eq cache_dir_fix('\ '), 'cache_dir_fix: \ -> \\\\\ ' );
+ ok( '\[bracket\]' eq cache_dir_fix('[bracket]'), 'cache_dir_fix: [bracket] -> \[bracket\]' );
+
+ note( 'Leaving tests_cache_dir_fix()' ) ;
+ return ;
}
sub cache_dir_fix_win {
- my $cache_dir = shift ;
+ my $cache_dir = shift ;
$cache_dir =~ s/(\[|\])/[$1]/xg ;
#myprint( "cache_dir_fix_win: $cache_dir\n" ) ;
- return( $cache_dir ) ;
+ return( $cache_dir ) ;
}
sub tests_cache_dir_fix_win {
- ok( 'lalala' eq cache_dir_fix_win('lalala'), 'cache_dir_fix_win: lalala -> lalala' );
- ok( '[[]bracket[]]' eq cache_dir_fix_win('[bracket]'), 'cache_dir_fix_win: [bracket] -> [[]bracket[]]' );
- return ;
+ note( 'Entering tests_cache_dir_fix_win()' ) ;
+
+ ok( 'lalala' eq cache_dir_fix_win('lalala'), 'cache_dir_fix_win: lalala -> lalala' );
+ ok( '[[]bracket[]]' eq cache_dir_fix_win('[bracket]'), 'cache_dir_fix_win: [bracket] -> [[]bracket[]]' );
+
+ note( 'Leaving tests_cache_dir_fix_win()' ) ;
+ return ;
}
sub get_cache {
- my ( $cache_dir, $h1_msgs_ref, $h2_msgs_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_;
+ my ( $cache_dir, $h1_msgs_ref, $h2_msgs_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_;
- $debugcache and myprint( "Entering get_cache\n" ) ;
+ $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" ) ;
+ -d $cache_dir or return( undef ); # exit if cache directory doesn't exist
+ $debugcache and myprint( "cache_dir : $cache_dir\n" ) ;
if ( 'MSWin32' ne $OSNAME ) {
- $cache_dir = cache_dir_fix( $cache_dir ) ;
+ $cache_dir = cache_dir_fix( $cache_dir ) ;
}else{
- $cache_dir = cache_dir_fix_win( $cache_dir ) ;
+ $cache_dir = cache_dir_fix_win( $cache_dir ) ;
}
- $debugcache and myprint( "cache_dir_fix: $cache_dir\n" ) ;
+ $debugcache and myprint( "cache_dir_fix: $cache_dir\n" ) ;
- my @cache_files = bsd_glob( "$cache_dir/*" ) ;
- #$debugcache and myprint( "cache_files: [@cache_files]\n" ) ;
+ my @cache_files = bsd_glob( "$cache_dir/*" ) ;
+ #$debugcache and myprint( "cache_files: [@cache_files]\n" ) ;
- $debugcache and myprint( 'cache_files: ', scalar @cache_files , " files found\n" ) ;
+ $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 ) ;
+ my( $cache_1_2_ref, $cache_2_1_ref )
+ = cache_map( \@cache_files, $h1_msgs_ref, $h2_msgs_ref ) ;
- clean_cache( \@cache_files, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ;
+ clean_cache( \@cache_files, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ;
- $debugcache and myprint( "Exiting get_cache\n" ) ;
- return( $cache_1_2_ref, $cache_2_1_ref ) ;
+ $debugcache and myprint( "Exiting get_cache\n" ) ;
+ return( $cache_1_2_ref, $cache_2_1_ref ) ;
}
sub 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 @test_files_cache = ( qw(
- W/tmp/cache/F1/F2/100_200
- W/tmp/cache/F1/F2/101_201
- W/tmp/cache/F1/F2/120_220
- W/tmp/cache/F1/F2/142_242
- W/tmp/cache/F1/F2/143_243
- W/tmp/cache/F1/F2/177_277
- W/tmp/cache/F1/F2/177_377
- 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/...' ) ;
-
-
- # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255
- # on live:
- my $msgs_1 = [120, 142, 143, 144, 177 ];
- my $msgs_2 = [ 242, 243, 299, 377, 777, 255 ];
+ 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 @test_files_cache = ( qw(
+ W/tmp/cache/F1/F2/100_200
+ W/tmp/cache/F1/F2/101_201
+ W/tmp/cache/F1/F2/120_220
+ W/tmp/cache/F1/F2/142_242
+ W/tmp/cache/F1/F2/143_243
+ W/tmp/cache/F1/F2/177_277
+ W/tmp/cache/F1/F2/177_377
+ 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/...' ) ;
+
+
+ # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255
+ # on live:
+ my $msgs_1 = [120, 142, 143, 144, 177 ];
+ my $msgs_2 = [ 242, 243, 299, 377, 777, 255 ];
my $msgs_all_1 = { 120 => 0, 142 => 0, 143 => 0, 144 => 0, 177 => 0 } ;
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' );
- 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');
-
- # 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');
-
-
- # 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' ) ;
-
- @test_files_cache = ( qw(
- W/tmp/cache/rr\uee/100_200
- W/tmp/cache/rr\uee/101_201
- W/tmp/cache/rr\uee/120_220
- W/tmp/cache/rr\uee/142_242
- W/tmp/cache/rr\uee/143_243
- W/tmp/cache/rr\uee/177_277
- W/tmp/cache/rr\uee/177_377
- 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/...' ) ;
-
- # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255
- # on live:
- $msgs_1 = [120, 142, 143, 144, 177 ] ;
- $msgs_2 = [ 242, 243, 299, 377, 777, 255 ] ;
+ 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' );
+ 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');
+
+ # 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');
+
+
+ # 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' ) ;
+
+ @test_files_cache = ( qw(
+ W/tmp/cache/rr\uee/100_200
+ W/tmp/cache/rr\uee/101_201
+ W/tmp/cache/rr\uee/120_220
+ W/tmp/cache/rr\uee/142_242
+ W/tmp/cache/rr\uee/143_243
+ W/tmp/cache/rr\uee/177_277
+ W/tmp/cache/rr\uee/177_377
+ 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/...' ) ;
+
+ # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255
+ # on live:
+ $msgs_1 = [120, 142, 143, 144, 177 ] ;
+ $msgs_2 = [ 242, 243, 299, 377, 777, 255 ] ;
$msgs_all_1 = { 120 => 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' );
- $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');
- return ;
+ 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' );
+ $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');
+
+ note( 'Leaving tests_get_cache()' ) ;
+ return ;
}
sub match_a_cache_file {
- my $file = shift ;
- my ( $cache_uid1, $cache_uid2 ) ;
+ my $file = shift ;
+ my ( $cache_uid1, $cache_uid2 ) ;
- return( ( undef, undef ) ) if ( ! $file ) ;
- if ( $file =~ m{(?:^|/)(\d+)_(\d+)$}x ) {
- $cache_uid1 = $1 ;
- $cache_uid2 = $2 ;
- }
- return( $cache_uid1, $cache_uid2 ) ;
+ return( ( undef, undef ) ) if ( ! $file ) ;
+ if ( $file =~ m{(?:^|/)(\d+)_(\d+)$}x ) {
+ $cache_uid1 = $1 ;
+ $cache_uid2 = $2 ;
+ }
+ return( $cache_uid1, $cache_uid2 ) ;
}
sub tests_match_a_cache_file {
- my ( $tuid1, $tuid2 ) ;
- ok( ( $tuid1, $tuid2 ) = match_a_cache_file( ), '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' ) ;
+ note( 'Entering tests_match_a_cache_file()' ) ;
- ok( ( $tuid1, $tuid2 ) = match_a_cache_file( q{} ), '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' ) ;
+ my ( $tuid1, $tuid2 ) ;
+ ok( ( $tuid1, $tuid2 ) = match_a_cache_file( ), '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( '000_000' ), '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( q{} ), '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( '123_456' ), '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( '000_000' ), '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( '/tmp/truc/123_456' ), '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( '123_456' ), '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( '/lala123_456' ), '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( '/tmp/truc/123_456' ), '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( 'la123_456' ), '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' ) ;
+ ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/lala123_456' ), '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' ) ;
- return ;
+ ok( ( $tuid1, $tuid2 ) = match_a_cache_file( 'la123_456' ), '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' ) ;
+
+ note( 'Leaving tests_match_a_cache_file()' ) ;
+ return ;
}
sub clean_cache {
- my ( $cache_files_ref, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_ ;
-
- $debugcache and myprint( "Entering clean_cache\n" ) ;
-
- $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" ) ;
- 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") ;
-# or ( ! exists( $cache_1_2_ref->{ $cache_uid1 } ) )
-# or ( ! ( $cache_uid2 == $cache_1_2_ref->{ $cache_uid1 } ) )
- if ( ( not defined $cache_uid1 )
- or ( not defined $cache_uid2 )
+ my ( $cache_files_ref, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_ ;
+
+ $debugcache and myprint( "Entering clean_cache\n" ) ;
+
+ $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" ) ;
+ 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") ;
+# or ( ! exists( $cache_1_2_ref->{ $cache_uid1 } ) )
+# or ( ! ( $cache_uid2 == $cache_1_2_ref->{ $cache_uid1 } ) )
+ if ( ( not defined $cache_uid1 )
+ or ( not defined $cache_uid2 )
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" ) ;
- unlink $file or myprint( "$!" ) ;
- }
- }
+ $debugcache and myprint( "remove $file\n" ) ;
+ unlink $file or myprint( "$OS_ERROR" ) ;
+ }
+ }
- $debugcache and myprint( "Exiting clean_cache\n" ) ;
- return( 1 ) ;
+ $debugcache and myprint( "Exiting clean_cache\n" ) ;
+ return( 1 ) ;
}
sub 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' ) ;
-
- my @test_files_cache = ( qw(
- W/tmp/cache/G1/G2/100_200
- W/tmp/cache/G1/G2/101_201
- W/tmp/cache/G1/G2/120_220
- W/tmp/cache/G1/G2/142_242
- W/tmp/cache/G1/G2/143_243
- W/tmp/cache/G1/G2/177_277
- W/tmp/cache/G1/G2/177_377
- 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( -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' );
-
- my $cache = {
- 142 => 242,
- 177 => 777,
- } ;
+ 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' ) ;
+
+ my @test_files_cache = ( qw(
+ W/tmp/cache/G1/G2/100_200
+ W/tmp/cache/G1/G2/101_201
+ W/tmp/cache/G1/G2/120_220
+ W/tmp/cache/G1/G2/142_242
+ W/tmp/cache/G1/G2/143_243
+ W/tmp/cache/G1/G2/177_277
+ W/tmp/cache/G1/G2/177_377
+ 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( -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' );
+
+ my $cache = {
+ 142 => 242,
+ 177 => 777,
+ } ;
my $all_1 = {
142 => q{},
@@ -5927,46 +7073,49 @@ sub tests_clean_cache {
242 => q{},
777 => q{},
} ;
- ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), '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' );
- return ;
+ ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), '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' );
+
+ note( 'Leaving tests_clean_cache()' ) ;
+ return ;
}
sub 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' ) ;
-
- my @test_files_cache = ( qw(
- W/tmp/cache/G1/G2/100_200
- W/tmp/cache/G1/G2/101_201
- W/tmp/cache/G1/G2/120_220
- W/tmp/cache/G1/G2/142_242
- W/tmp/cache/G1/G2/143_243
- W/tmp/cache/G1/G2/177_277
- W/tmp/cache/G1/G2/177_377
- 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( -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' );
-
- my $cache = {
- 142 => 242,
- 177 => 777,
- } ;
+ 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' ) ;
+
+ my @test_files_cache = ( qw(
+ W/tmp/cache/G1/G2/100_200
+ W/tmp/cache/G1/G2/101_201
+ W/tmp/cache/G1/G2/120_220
+ W/tmp/cache/G1/G2/142_242
+ W/tmp/cache/G1/G2/143_243
+ W/tmp/cache/G1/G2/177_277
+ W/tmp/cache/G1/G2/177_377
+ 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( -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' );
+
+ my $cache = {
+ 142 => 242,
+ 177 => 777,
+ } ;
my $all_1 = {
$NUMBER_100 => q{},
@@ -5982,105 +7131,131 @@ sub tests_clean_cache_2 {
- ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), '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' );
- return ;
+ 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' );
+
+ note( 'Leaving tests_clean_cache_2()' ) ;
+ return ;
}
sub tests_mkpath {
+ note( 'Entering tests_mkpath()' ) ;
- ok( 1 == 1, 'tests_mkpath: 1 == 1' ) ;
-
- SKIP: {
- skip( 'Tests only for Unix', 2 ) if ( 'MSWin32' eq $OSNAME ) ;
- my $long_path_unix = '123456789/' x 30 ;
- ok( (-d "W/tmp/tests/long/$long_path_unix" or mkpath( "W/tmp/tests/long/$long_path_unix" ) ), 'tests_mkpath: mkpath > 300 char' ) ;
- ok( (-d "W/tmp/tests/long/$long_path_unix" and rmtree( 'W/tmp/tests/long/' ) ), 'tests_mkpath: rmtree > 300 char' ) ;
+ ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'mkpath: mkpath W/tmp/tests/' ) ;
+
+ SKIP: {
+ skip( 'Tests only for Unix', 10 ) if ( 'MSWin32' eq $OSNAME ) ;
+ my $long_path_unix = '123456789/' x 30 ;
+ ok( ( -d "W/tmp/tests/long/$long_path_unix" or mkpath( "W/tmp/tests/long/$long_path_unix" ) ), 'mkpath: mkpath 300 char' ) ;
+ ok( -d "W/tmp/tests/long/$long_path_unix", 'mkpath: mkpath > 300 char verified' ) ;
+ ok( ( -d "W/tmp/tests/long/$long_path_unix" and rmtree( 'W/tmp/tests/long/' ) ), 'mkpath: rmtree 300 char' ) ;
+ ok( ! -d "W/tmp/tests/long/$long_path_unix", 'mkpath: rmtree 300 char verified' ) ;
+
+ ok( ( -d 'W/tmp/tests/trailing_dots...' or mkpath( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: mkpath trailing_dots...' ) ;
+ ok( -d 'W/tmp/tests/trailing_dots...', 'mkpath: mkpath trailing_dots... verified' ) ;
+ ok( ( -d 'W/tmp/tests/trailing_dots...' and rmtree( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: rmtree trailing_dots...' ) ;
+ ok( ! -d 'W/tmp/tests/trailing_dots...', 'mkpath: rmtree trailing_dots... verified' ) ;
+
+ eval { ok( 1 / 0, 'mkpath: divide by 0' ) ; } or ok( 1, 'mkpath: can not divide by 0' ) ;
+ ok( 1, 'mkpath: still alive' ) ;
} ;
- SKIP: {
- skip( 'Tests only for MSWin32', 6 ) if ( 'MSWin32' ne $OSNAME ) ;
- my $long_path_2_prefix = "$tmpdir\\imapsync_tests" || '\\\?\\E:\\TEMP\\imapsync_tests' ;
- myprint( "long_path_2_prefix: $long_path_2_prefix\n" ) ;
-
- my $long_path_2 = $long_path_2_prefix . '\\' . '123456789\\' x 10 . 'END' ;
- my $long_path_300 = $long_path_2_prefix . '\\' . '123456789\\' x 30 . 'END' ;
-
- myprint( "$long_path_2\n" ) ;
-
- #ok( ( -d $long_path_2_prefix and rmtree( $long_path_2_prefix ) ), 'tests_mkpath: rmtree > 200 char' ) ;
- #ok( ( -d $long_path_2_prefix or mkpath( "\\\\\?\\E:\\\\TEMP\\imapsync_tests" ) ), 'tests_mkpath: -d small path 1' ) ;
-
- ok( ( -d $long_path_2_prefix or mkpath( $long_path_2_prefix ) ), 'tests_mkpath: -d mkpath small path' ) ;
- ok( ( -d $long_path_2_prefix ), 'tests_mkpath: -d mkpath small path done' ) ;
- ok( ( -d $long_path_2 or mkpath( $long_path_2 ) ), 'tests_mkpath: mkpath > 200 char' ) ;
- ok( ( -d $long_path_2 ), 'tests_mkpath: -d mkpath > 200 char done' ) ;
- ok( ( -d $long_path_2_prefix and rmtree( $long_path_2_prefix ) ), 'tests_mkpath: rmtree > 200 char' ) ;
- ok( (! -d $long_path_2_prefix ), 'tests_mkpath: ! -d rmtree done' ) ;
-
- myprint( "$long_path_300\n" ) ;
- # This one just kill the whole process without a whisper:
- #ok( ( -d $long_path_300 or mkpath( $long_path_300 ) ), 'tests_mkpath: mkpath fails > 300 char' ) ;
- #ok( ( -d $long_path_300 and rmtree( $long_path_300 ) ), 'tests_mkpath: rmtree \ > 300 char' ) ;
- } ;
+ SKIP: {
+ skip( 'Tests only for MSWin32', 13 ) if ( 'MSWin32' ne $OSNAME ) ;
+ my $long_path_2_prefix = "$tmpdir\\imapsync_tests" || '\\\?\\E:\\TEMP\\imapsync_tests' ;
+ myprint( "long_path_2_prefix: $long_path_2_prefix\n" ) ;
+
+ my $long_path_100 = $long_path_2_prefix . '\\' . '123456789\\' x 10 . 'END' ;
+ my $long_path_300 = $long_path_2_prefix . '\\' . '123456789\\' x 30 . 'END' ;
+
+ #myprint( "$long_path_100\n" ) ;
+
+ ok( ( -d $long_path_2_prefix or mkpath( $long_path_2_prefix ) ), 'mkpath: -d mkpath small path' ) ;
+ ok( ( -d $long_path_2_prefix ), 'mkpath: -d mkpath small path done' ) ;
+ ok( ( -d $long_path_100 or mkpath( $long_path_100 ) ), 'mkpath: mkpath > 100 char' ) ;
+ ok( ( -d $long_path_100 ), 'mkpath: -d mkpath > 200 char done' ) ;
+ ok( ( -d $long_path_2_prefix and rmtree( $long_path_2_prefix ) ), 'mkpath: rmtree > 100 char' ) ;
+ ok( (! -d $long_path_2_prefix ), 'mkpath: ! -d rmtree done' ) ;
+
+ # Without the eval the following mkpath 300 just kill the whole process without a whisper
+ #myprint( "$long_path_300\n" ) ;
+ eval { ok( ( -d $long_path_300 or mkpath( $long_path_300 ) ), 'mkpath: create a path with 300 characters' ) ; }
+ or ok( 1, 'mkpath: can not create a path with 300 characters' ) ;
+ ok( ( ( ! -d $long_path_300 ) or -d $long_path_300 and rmtree( $long_path_300 ) ), 'mkpath: rmtree the 300 character path' ) ;
+ ok( 1, 'mkpath: still alive' ) ;
+
+ ok( ( -d 'W/tmp/tests/trailing_dots...' or mkpath( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: mkpath trailing_dots...' ) ;
+ ok( -d 'W/tmp/tests/trailing_dots...', 'mkpath: mkpath trailing_dots... verified' ) ;
+ ok( ( -d 'W/tmp/tests/trailing_dots...' and rmtree( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: rmtree trailing_dots...' ) ;
+ ok( ! -d 'W/tmp/tests/trailing_dots...', 'mkpath: rmtree trailing_dots... verified' ) ;
+
+
+ } ;
- return 1 ;
+ note( 'Leaving tests_mkpath()' ) ;
+ # Keep this because of the eval used by the caller (failed badly?)
+ return 1 ;
}
sub tests_touch {
+ note( 'Entering tests_touch()' ) ;
- ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'tests_touch: mkpath W/tmp/tests/' ) ;
- ok( 1 == touch( 'W/tmp/tests/lala'), 'tests_touch: W/tmp/tests/lala') ;
- ok( 1 == touch( 'W/tmp/tests/\y'), 'tests_touch: W/tmp/tests/\y') ;
- ok( 0 == touch( '/no/no/no/aaa'), 'tests_touch: not /aaa') ;
- ok( 1 == touch( 'W/tmp/tests/lili', 'W/tmp/tests/lolo'), 'tests_touch: 2 files') ;
- ok( 0 == touch( 'W/tmp/tests/\y', '/no/no/aaa'), 'tests_touch: 2 files, 1 fails' ) ;
- return ;
+ ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'touch: mkpath W/tmp/tests/' ) ;
+ ok( 1 == touch( 'W/tmp/tests/lala'), 'touch: W/tmp/tests/lala') ;
+ ok( 1 == touch( 'W/tmp/tests/\y'), 'touch: W/tmp/tests/\y') ;
+ ok( 0 == touch( '/no/no/no/aaa'), 'touch: not /aaa') ;
+ ok( 1 == touch( 'W/tmp/tests/lili', 'W/tmp/tests/lolo'), 'touch: 2 files') ;
+ ok( 0 == touch( 'W/tmp/tests/\y', '/no/no/aaa'), 'touch: 2 files, 1 fails' ) ;
+
+ note( 'Leaving tests_touch()' ) ;
+ return ;
}
sub touch {
- my @files = @_ ;
- my $failures = 0 ;
-
- foreach my $file ( @files ) {
- my $fh = IO::File->new ;
- if ( $fh->open(">> $file" ) ) {
- $fh->close ;
- }else{
- myprint( "Could not open file $file in write/append mode\n" ) ;
- $failures++ ;
+ my @files = @_ ;
+ my $failures = 0 ;
+
+ foreach my $file ( @files ) {
+ my $fh = IO::File->new ;
+ if ( $fh->open(">> $file" ) ) {
+ $fh->close ;
+ }else{
+ myprint( "Could not open file $file in write/append mode\n" ) ;
+ $failures++ ;
}
- }
- return( ! $failures );
+ }
+ return( ! $failures );
}
sub tests_tmpdir_has_colon_bug {
+ note( 'Entering tests_tmpdir_has_colon_bug()' ) ;
- ok( 0 == tmpdir_has_colon_bug( q{} ), 'tmpdir_has_colon_bug: ' ) ;
- ok( 0 == tmpdir_has_colon_bug( '/tmp' ), 'tmpdir_has_colon_bug: /tmp' ) ;
- ok( 1 == tmpdir_has_colon_bug( 'C:' ), 'tmpdir_has_colon_bug: C:' ) ;
- ok( 1 == tmpdir_has_colon_bug( 'C:\temp' ), 'tmpdir_has_colon_bug: C:\temp' ) ;
+ ok( 0 == tmpdir_has_colon_bug( q{} ), 'tmpdir_has_colon_bug: ' ) ;
+ ok( 0 == tmpdir_has_colon_bug( '/tmp' ), 'tmpdir_has_colon_bug: /tmp' ) ;
+ ok( 1 == tmpdir_has_colon_bug( 'C:' ), 'tmpdir_has_colon_bug: C:' ) ;
+ ok( 1 == tmpdir_has_colon_bug( 'C:\temp' ), 'tmpdir_has_colon_bug: C:\temp' ) ;
- return( 0 ) ;
+ note( 'Leaving tests_tmpdir_has_colon_bug()' ) ;
+ return ;
}
sub tmpdir_has_colon_bug {
- my $path = shift ;
+ my $path = shift ;
- my $path_filtered = filter_forbidden_characters( $path ) ;
- if ( $path_filtered ne $path ) {
- ( -d $path_filtered ) and myprint( "Path $path was previously mistakely changed to $path_filtered\n" ) ;
- return( 1 ) ;
+ my $path_filtered = filter_forbidden_characters( $path ) ;
+ if ( $path_filtered ne $path ) {
+ ( -d $path_filtered ) and myprint( "Path $path was previously mistakely changed to $path_filtered\n" ) ;
+ return( 1 ) ;
}
return( 0 ) ;
}
@@ -6133,140 +7308,154 @@ sub tmpdir_fix_colon_bug {
sub tests_cache_folder {
+ note( 'Entering tests_cache_folder()' ) ;
- ok( '/path/fold1/fold2' eq cache_folder( q{}, '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ;
- ok( '/pa_th/fold1/fold2' eq cache_folder( q{}, '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ;
- ok( '/_p_a__th/fol_d1/fold2' eq cache_folder( q{}, '/>p<a|*th', 'fol*d1', 'fold2'), 'cache_folder: />p<a|*th, fol*d1, fold2 -> /path/fol_d1/fold2' ) ;
- ok( 'D:/path/fold1/fold2' eq cache_folder( 'D:', '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ;
- ok( 'D:/pa_th/fold1/fold2' eq cache_folder( 'D:', '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ;
- ok( 'D:/_p_a__th/fol_d1/fold2' eq cache_folder( 'D:', '/>p<a|*th', 'fol*d1', 'fold2'), 'cache_folder: />p<a|*th, fol*d1, fold2 -> /path/fol_d1/fold2' ) ;
- ok( '//' eq cache_folder( q{}, q{}, q{}, q{}), 'cache_folder: -> //' ) ;
- ok( '//_______' eq cache_folder( q{}, q{}, q{}, '*|?:"<>'), 'cache_folder: *|?:"<> -> //_______' ) ;
- return ;
+ ok( '/path/fold1/fold2' eq cache_folder( q{}, '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ;
+ ok( '/pa_th/fold1/fold2' eq cache_folder( q{}, '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ;
+ ok( '/_p_a__th/fol_d1/fold2' eq cache_folder( q{}, '/>p<a|*th', 'fol*d1', 'fold2'), 'cache_folder: />p<a|*th, fol*d1, fold2 -> /path/fol_d1/fold2' ) ;
+
+ ok( 'D:/path/fold1/fold2' eq cache_folder( 'D:', '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ;
+ ok( 'D:/pa_th/fold1/fold2' eq cache_folder( 'D:', '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ;
+ ok( 'D:/_p_a__th/fol_d1/fold2' eq cache_folder( 'D:', '/>p<a|*th', 'fol*d1', 'fold2'), 'cache_folder: />p<a|*th, fol*d1, fold2 -> /path/fol_d1/fold2' ) ;
+ ok( '//' eq cache_folder( q{}, q{}, q{}, q{}), 'cache_folder: -> //' ) ;
+ ok( '//_______' eq cache_folder( q{}, q{}, q{}, '*|?:"<>'), 'cache_folder: *|?:"<> -> //_______' ) ;
+
+ note( 'Leaving tests_cache_folder()' ) ;
+ return ;
}
sub cache_folder {
- my( $cache_base, $cache_dir, $h1_fold, $h2_fold ) = @_ ;
+ my( $cache_base, $cache_dir, $h1_fold, $h2_fold ) = @_ ;
- my $sep_1 = $h1_sep || '/';
- my $sep_2 = $h2_sep || '/';
+ my $sep_1 = $h1_sep || '/';
+ my $sep_2 = $h2_sep || '/';
- #myprint( "$cache_dir h1_fold $h1_fold sep1 $sep_1 h2_fold $h2_fold sep2 $sep_2\n" ) ;
- $h1_fold = convert_sep_to_slash( $h1_fold, $sep_1 ) ;
- $h2_fold = convert_sep_to_slash( $h2_fold, $sep_2 ) ;
+ #myprint( "$cache_dir h1_fold $h1_fold sep1 $sep_1 h2_fold $h2_fold sep2 $sep_2\n" ) ;
+ $h1_fold = convert_sep_to_slash( $h1_fold, $sep_1 ) ;
+ $h2_fold = convert_sep_to_slash( $h2_fold, $sep_2 ) ;
my $cache_folder = "$cache_base" . filter_forbidden_characters( "$cache_dir/$h1_fold/$h2_fold" ) ;
- #myprint( "cache_folder [$cache_folder]\n" ) ;
+ #myprint( "cache_folder [$cache_folder]\n" ) ;
return( $cache_folder ) ;
}
sub filter_forbidden_characters {
- my $string = shift ;
+ my $string = shift ;
+
+ if ( ! defined $string ) { return ; }
if ( 'MSWin32' eq $OSNAME ) {
- # Move trailing whitespace to _ " a b /c d " -> " a b_/c d_"
- $string =~ s{\ (/|$)}{_$1}xg ;
+ # Move trailing whitespace to _ " a b /c d " -> " a b_/c d_"
+ $string =~ s{\ (/|$)}{_$1}xg ;
}
$string =~ s{[\Q*|?:"<>\E]}{_}xg ;
#myprint( "[$string]\n" ) ;
- return( $string ) ;
+ return( $string ) ;
}
sub tests_filter_forbidden_characters {
+ note( 'Entering tests_filter_forbidden_characters()' ) ;
- ok( 'a_b' eq filter_forbidden_characters( 'a_b' ), 'filter_forbidden_characters: a_b -> a_b' ) ;
- ok( 'a_b' eq filter_forbidden_characters( 'a*b' ), 'filter_forbidden_characters: a*b -> a_b' ) ;
- ok( 'a_b' eq filter_forbidden_characters( 'a|b' ), 'filter_forbidden_characters: a|b -> a_b' ) ;
- ok( 'a_b' eq filter_forbidden_characters( 'a?b' ), 'filter_forbidden_characters: a?b -> a_b' ) ;
- ok( 'a_______b' eq filter_forbidden_characters( 'a*|?:"<>b' ), 'filter_forbidden_characters: a*|?:"<>b -> a_______b' ) ;
- SKIP: {
- skip( 'Not on MSWin32', 1 ) if ( 'MSWin32' eq $OSNAME ) ;
- ok( ( 'a b ' eq filter_forbidden_characters( 'a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b "' ) ;
- } ;
+ ok( 'a_b' eq filter_forbidden_characters( 'a_b' ), 'filter_forbidden_characters: a_b -> a_b' ) ;
+ ok( 'a_b' eq filter_forbidden_characters( 'a*b' ), 'filter_forbidden_characters: a*b -> a_b' ) ;
+ ok( 'a_b' eq filter_forbidden_characters( 'a|b' ), 'filter_forbidden_characters: a|b -> a_b' ) ;
+ ok( 'a_b' eq filter_forbidden_characters( 'a?b' ), 'filter_forbidden_characters: a?b -> a_b' ) ;
+ ok( 'a_______b' eq filter_forbidden_characters( 'a*|?:"<>b' ), 'filter_forbidden_characters: a*|?:"<>b -> a_______b' ) ;
- SKIP: {
- skip( 'Only on MSWin32', 2 ) if ( 'MSWin32' ne $OSNAME ) ;
- ok( ( ' a b_' eq filter_forbidden_characters( ' a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b_"' ) ;
- ok( ( ' a b_/ c d_' eq filter_forbidden_characters( ' a b / c d ' ) ), 'filter_forbidden_characters: " a b / c d " -> "a b_/ c d_"' ) ;
+ SKIP: {
+ skip( 'Not on MSWin32', 1 ) if ( 'MSWin32' eq $OSNAME ) ;
+ ok( ( 'a b ' eq filter_forbidden_characters( 'a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b "' ) ;
} ;
- return ;
+ SKIP: {
+ skip( 'Only on MSWin32', 2 ) if ( 'MSWin32' ne $OSNAME ) ;
+ ok( ( ' a b_' eq filter_forbidden_characters( ' a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b_"' ) ;
+ ok( ( ' a b_/ c d_' eq filter_forbidden_characters( ' a b / c d ' ) ), 'filter_forbidden_characters: " a b / c d " -> "a b_/ c d_"' ) ;
+ } ;
+
+ note( 'Leaving tests_filter_forbidden_characters()' ) ;
+ return ;
}
sub convert_sep_to_slash {
- my ( $folder, $sep ) = @_ ;
+ my ( $folder, $sep ) = @_ ;
- $folder =~ s{\Q$sep\E}{/}xg ;
- return( $folder ) ;
+ $folder =~ s{\Q$sep\E}{/}xg ;
+ return( $folder ) ;
}
sub tests_convert_sep_to_slash {
+ note( 'Entering tests_convert_sep_to_slash()' ) ;
- ok(q{} eq convert_sep_to_slash(q{}, '/'), 'convert_sep_to_slash: no folder');
- ok('INBOX' eq convert_sep_to_slash('INBOX', '/'), 'convert_sep_to_slash: INBOX');
- ok('INBOX/foo' eq convert_sep_to_slash('INBOX/foo', '/'), 'convert_sep_to_slash: INBOX/foo');
- ok('INBOX/foo' eq convert_sep_to_slash('INBOX_foo', '_'), 'convert_sep_to_slash: INBOX_foo');
- ok('INBOX/foo/zob' eq convert_sep_to_slash('INBOX_foo_zob', '_'), 'convert_sep_to_slash: INBOX_foo_zob');
- ok('INBOX/foo' eq convert_sep_to_slash('INBOX.foo', '.'), 'convert_sep_to_slash: INBOX.foo');
- ok('INBOX/foo/hi' eq convert_sep_to_slash('INBOX.foo.hi', '.'), 'convert_sep_to_slash: INBOX.foo.hi');
- return ;
+
+ ok(q{} eq convert_sep_to_slash(q{}, '/'), 'convert_sep_to_slash: no folder');
+ ok('INBOX' eq convert_sep_to_slash('INBOX', '/'), 'convert_sep_to_slash: INBOX');
+ ok('INBOX/foo' eq convert_sep_to_slash('INBOX/foo', '/'), 'convert_sep_to_slash: INBOX/foo');
+ ok('INBOX/foo' eq convert_sep_to_slash('INBOX_foo', '_'), 'convert_sep_to_slash: INBOX_foo');
+ ok('INBOX/foo/zob' eq convert_sep_to_slash('INBOX_foo_zob', '_'), 'convert_sep_to_slash: INBOX_foo_zob');
+ ok('INBOX/foo' eq convert_sep_to_slash('INBOX.foo', '.'), 'convert_sep_to_slash: INBOX.foo');
+ ok('INBOX/foo/hi' eq convert_sep_to_slash('INBOX.foo.hi', '.'), 'convert_sep_to_slash: INBOX.foo.hi');
+
+ note( 'Leaving tests_convert_sep_to_slash()' ) ;
+ return ;
}
sub tests_regexmess {
+ note( 'Entering tests_regexmess()' ) ;
- ok( 'blabla' eq regexmess( 'blabla' ), 'regexmess, no regexmess, nothing to do' ) ;
+ ok( 'blabla' eq regexmess( 'blabla' ), 'regexmess, no regexmess, nothing to do' ) ;
- @regexmess = ( 'lalala' ) ;
- ok( not( defined regexmess( 'popopo' ) ), 'regexmess, bad regex lalala' ) ;
+ @regexmess = ( 'lalala' ) ;
+ ok( not( defined regexmess( 'popopo' ) ), 'regexmess, bad regex lalala' ) ;
- @regexmess = ( 's/p/Z/g' ) ;
- ok( 'ZoZoZo' eq regexmess( 'popopo' ), 'regexmess, s/p/Z/g' ) ;
+ @regexmess = ( 's/p/Z/g' ) ;
+ ok( 'ZoZoZo' eq regexmess( 'popopo' ), 'regexmess, s/p/Z/g' ) ;
- @regexmess = ( 's{c}{C}gxms' ) ;
- ok("H1: abC\nH2: Cde\n\nBody abC"
- eq regexmess( "H1: abc\nH2: cde\n\nBody abc"),
- 'regexmess, c->C');
+ @regexmess = ( 's{c}{C}gxms' ) ;
+ ok("H1: abC\nH2: Cde\n\nBody abC"
+ eq regexmess( "H1: abc\nH2: cde\n\nBody abc"),
+ 'regexmess, c->C');
- @regexmess = ( 's{\AFrom\ }{From:}gxms' ) ;
- ok( q{}
- eq regexmess(q{}),
- 'From mbox 1 add colon blank');
+ @regexmess = ( 's{\AFrom\ }{From:}gxms' ) ;
+ ok( q{}
+ eq regexmess(q{}),
+ 'From mbox 1 add colon blank');
- ok( 'From:<[email protected]>'
- eq regexmess('From <[email protected]>'),
- 'From mbox 2 add colo');
+ ok( 'From:<[email protected]>'
+ eq regexmess('From <[email protected]>'),
+ 'From mbox 2 add colo');
- ok( "\n" . 'From <[email protected]>'
- eq regexmess("\n" . 'From <[email protected]>'),
- 'From mbox 3 add colo') ;
+ ok( "\n" . 'From <[email protected]>'
+ eq regexmess("\n" . 'From <[email protected]>'),
+ 'From mbox 3 add colo') ;
- ok( "From: zzz\n" . 'From <[email protected]>'
- eq regexmess("From zzz\n" . 'From <[email protected]>'),
- 'From mbox 4 add colo') ;
+ ok( "From: zzz\n" . 'From <[email protected]>'
+ eq regexmess("From zzz\n" . 'From <[email protected]>'),
+ 'From mbox 4 add colo') ;
- @regexmess = ( 's{\AFrom\ [^\n]*(\n)?}{}gxms' ) ;
- ok( q{}
- eq regexmess(q{}),
- 'From mbox 1 remove, blank');
+ @regexmess = ( 's{\AFrom\ [^\n]*(\n)?}{}gxms' ) ;
+ ok( q{}
+ eq regexmess(q{}),
+ 'From mbox 1 remove, blank');
- ok( q{}
- eq regexmess('From <[email protected]>'),
- 'From mbox 2 remove');
+ ok( q{}
+ eq regexmess('From <[email protected]>'),
+ 'From mbox 2 remove');
- ok( "\n" . 'From <[email protected]>'
- eq regexmess("\n" . 'From <[email protected]>'),
- 'From mbox 3 remove');
+ ok( "\n" . 'From <[email protected]>'
+ eq regexmess("\n" . 'From <[email protected]>'),
+ 'From mbox 3 remove');
- #myprint( "[", regexmess("From zzz\n" . 'From <[email protected]>'), "]" ) ;
- ok( q{} . 'From <[email protected]>'
- eq regexmess("From zzz\n" . 'From <[email protected]>'),
- 'From mbox 4 remove');
+ #myprint( "[", regexmess("From zzz\n" . 'From <[email protected]>'), "]" ) ;
+ ok( q{} . 'From <[email protected]>'
+ eq regexmess("From zzz\n" . 'From <[email protected]>'),
+ 'From mbox 4 remove');
- ok(
+ ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6274,7 +7463,7 @@ From:<[email protected]>
Hello,
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
From zzz
Date: Sat, 10 Jul 2010 05:34:45 -0700
@@ -6287,7 +7476,7 @@ EOM
@regexmess = ( 's{\A((?:[^\n]+\n)+|)^Disposition-Notification-To:[^\n]*\n(\r?\n|.*\n\r?\n)}{$1$2}xms' ) ; # SUPER SUPER BEST!
- ok(
+ ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6295,7 +7484,7 @@ From:<[email protected]>
Hello,
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
@@ -6304,10 +7493,10 @@ From:<[email protected]>
Hello,
Bye.
EOM
- ),
- 'regexmess: 1 Delete header Disposition-Notification-To:');
+ ),
+ 'regexmess: 1 Delete header Disposition-Notification-To:');
- ok(
+ ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6315,7 +7504,7 @@ From:<[email protected]>
Hello,
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6325,9 +7514,9 @@ Hello,
Bye.
EOM
),
- 'regexmess: 2 Delete header Disposition-Notification-To:');
+ 'regexmess: 2 Delete header Disposition-Notification-To:');
- ok(
+ ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6335,7 +7524,7 @@ From:<[email protected]>
Hello,
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Date: Sat, 10 Jul 2010 05:34:45 -0700
@@ -6345,9 +7534,9 @@ Hello,
Bye.
EOM
),
- 'regexmess: 3 Delete header Disposition-Notification-To:');
+ 'regexmess: 3 Delete header Disposition-Notification-To:');
- ok(
+ ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6355,7 +7544,7 @@ From:<[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Date: Sat, 10 Jul 2010 05:34:45 -0700
@@ -6365,10 +7554,10 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
- 'regexmess: 4 Delete header Disposition-Notification-To:');
+ 'regexmess: 4 Delete header Disposition-Notification-To:');
- ok(
+ ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6376,7 +7565,7 @@ From:<[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6385,7 +7574,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
- 'regexmess: 5 Delete header Disposition-Notification-To:');
+ 'regexmess: 5 Delete header Disposition-Notification-To:');
ok(
@@ -6397,7 +7586,7 @@ Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6407,7 +7596,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
- 'regexmess: 6 Delete header Disposition-Notification-To:');
+ 'regexmess: 6 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
@@ -6419,7 +7608,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6430,7 +7619,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
- 'regexmess: 7 Delete header Disposition-Notification-To:');
+ 'regexmess: 7 Delete header Disposition-Notification-To:');
ok(
@@ -6441,7 +7630,7 @@ From:<[email protected]>
Hello,
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6450,7 +7639,7 @@ Hello,
Bye.
EOM
),
- 'regexmess: 8 Delete header Disposition-Notification-To:');
+ 'regexmess: 8 Delete header Disposition-Notification-To:');
ok(
@@ -6462,7 +7651,7 @@ Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6472,7 +7661,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
- 'regexmess: 9 Delete header Disposition-Notification-To:');
+ 'regexmess: 9 Delete header Disposition-Notification-To:');
@@ -6487,7 +7676,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6499,7 +7688,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
- 'regexmess: 10 Delete header Disposition-Notification-To:');
+ 'regexmess: 10 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
@@ -6512,7 +7701,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6524,7 +7713,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
- 'regexmess: 11 Delete header Disposition-Notification-To:');
+ 'regexmess: 11 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
@@ -6539,7 +7728,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6553,7 +7742,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
- 'regexmess: 12 Delete header Disposition-Notification-To:');
+ 'regexmess: 12 Delete header Disposition-Notification-To:');
@regexmess = ( 's{\A(.*?(?! ^$))^Disposition-Notification-To:(.*?)$}{$1X-Disposition-Notification-To:$2}igxms' ) ; # BAD!
@@ -6573,7 +7762,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6587,7 +7776,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
- 'regexmess: 13 Delete header Disposition-Notification-To:');
+ 'regexmess: 13 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
@@ -6603,7 +7792,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
@@ -6618,7 +7807,7 @@ Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
- 'regexmess: 14 Delete header Disposition-Notification-To:');
+ 'regexmess: 14 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
@@ -6630,7 +7819,7 @@ Hello,
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
@@ -6641,7 +7830,7 @@ Hello,
Bye.
EOM
),
- 'regexmess: 15 Delete header Disposition-Notification-To:');
+ 'regexmess: 15 Delete header Disposition-Notification-To:');
ok(
@@ -6654,7 +7843,7 @@ Hello,
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6665,7 +7854,7 @@ Hello,
Bye.
EOM
),
- 'regexmess: 16 Delete header Disposition-Notification-To:');
+ 'regexmess: 16 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
@@ -6677,7 +7866,7 @@ Hello,
Bye.
EOM
- eq regexmess(
+ eq regexmess(
<<'EOM'
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Date: Sat, 10 Jul 2010 05:34:45 -0700
@@ -6688,76 +7877,78 @@ Hello,
Bye.
EOM
),
- 'regexmess: 17 Delete header Disposition-Notification-To:');
+ 'regexmess: 17 Delete header Disposition-Notification-To:');
# regex to play with Date: from the FAQ
#@regexmess = 's{\A(.*?(?! ^$))^Date:(.*?)$}{$1Date:$2\nX-Date:$2}gxms'
-return ;
+ note( 'Leaving tests_regexmess()' ) ;
+ return ;
}
sub regexmess {
- my ( $string ) = @_ ;
- foreach my $regexmess ( @regexmess ) {
- $debug and myprint( "eval \$string =~ $regexmess\n" ) ;
- my $ret = eval "\$string =~ $regexmess ; 1" ;
+ my ( $string ) = @_ ;
+ foreach my $regexmess ( @regexmess ) {
+ $debug and myprint( "eval \$string =~ $regexmess\n" ) ;
+ my $ret = eval "\$string =~ $regexmess ; 1" ;
#myprint( "eval [$ret]\n" ) ;
- if ( ( not $ret ) or $@ ) {
- myprint( "Error: eval regexmess '$regexmess': $@" ) ;
+ if ( ( not $ret ) or $EVAL_ERROR ) {
+ myprint( "Error: eval regexmess '$regexmess': $EVAL_ERROR" ) ;
return( undef ) ;
}
- }
+ }
$debug and myprint( "$string\n" ) ;
- return( $string ) ;
+ return( $string ) ;
}
sub tests_skipmess {
+ note( 'Entering tests_skipmess()' ) ;
- ok( not( defined skipmess( 'blabla' ) ), 'skipmess, no skipmess, no skip' ) ;
+ ok( not( defined skipmess( 'blabla' ) ), 'skipmess, no skipmess, no skip' ) ;
- @skipmess = ('[') ;
- ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex [' ) ;
+ @skipmess = ('[') ;
+ ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex [' ) ;
- @skipmess = ('lalala') ;
- ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex lalala' ) ;
+ @skipmess = ('lalala') ;
+ ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex lalala' ) ;
- @skipmess = ('/popopo/') ;
- ok( 1 == skipmess( 'popopo' ), 'skipmess, popopo match regex /popopo/' ) ;
+ @skipmess = ('/popopo/') ;
+ ok( 1 == skipmess( 'popopo' ), 'skipmess, popopo match regex /popopo/' ) ;
- @skipmess = ('/popopo/') ;
- ok( 0 == skipmess( 'rrrrrr' ), 'skipmess, rrrrrr does not match regex /popopo/' ) ;
+ @skipmess = ('/popopo/') ;
+ ok( 0 == skipmess( 'rrrrrr' ), 'skipmess, rrrrrr does not match regex /popopo/' ) ;
- @skipmess = ('m{^$}') ;
- ok( 1 == skipmess( q{} ), 'skipmess: empty string yes' ) ;
- ok( 0 == skipmess( 'Hi!' ), 'skipmess: empty string no' ) ;
+ @skipmess = ('m{^$}') ;
+ ok( 1 == skipmess( q{} ), 'skipmess: empty string yes' ) ;
+ ok( 0 == skipmess( 'Hi!' ), 'skipmess: empty string no' ) ;
- @skipmess = ('m{i}') ;
- ok( 1 == skipmess( 'Hi!' ), 'skipmess: i string yes' ) ;
- ok( 0 == skipmess( 'Bye!' ), 'skipmess: i string no' ) ;
+ @skipmess = ('m{i}') ;
+ ok( 1 == skipmess( 'Hi!' ), 'skipmess: i string yes' ) ;
+ ok( 0 == skipmess( 'Bye!' ), 'skipmess: i string no' ) ;
- @skipmess = ('m{[\x80-\xff]}') ;
- ok( 0 == skipmess( 'Hi!' ), 'skipmess: i 8bit no' ) ;
- ok( 1 == skipmess( "\xff" ), 'skipmess: \xff 8bit yes' ) ;
+ @skipmess = ('m{[\x80-\xff]}') ;
+ ok( 0 == skipmess( 'Hi!' ), 'skipmess: i 8bit no' ) ;
+ ok( 1 == skipmess( "\xff" ), 'skipmess: \xff 8bit yes' ) ;
- @skipmess = ('m{A}', 'm{B}') ;
- ok( 0 == skipmess( 'Hi!' ), 'skipmess: A or B no' ) ;
- ok( 0 == skipmess( 'lala' ), 'skipmess: A or B no' ) ;
- ok( 0 == skipmess( "\xff" ), 'skipmess: A or B no' ) ;
- ok( 1 == skipmess( 'AB' ), 'skipmess: A or B yes' ) ;
- ok( 1 == skipmess( 'BA' ), 'skipmess: A or B yes' ) ;
- ok( 1 == skipmess( 'AA' ), 'skipmess: A or B yes' ) ;
- ok( 1 == skipmess( 'Ok Bye' ), 'skipmess: A or B yes' ) ;
+ @skipmess = ('m{A}', 'm{B}') ;
+ ok( 0 == skipmess( 'Hi!' ), 'skipmess: A or B no' ) ;
+ ok( 0 == skipmess( 'lala' ), 'skipmess: A or B no' ) ;
+ ok( 0 == skipmess( "\xff" ), 'skipmess: A or B no' ) ;
+ ok( 1 == skipmess( 'AB' ), 'skipmess: A or B yes' ) ;
+ ok( 1 == skipmess( 'BA' ), 'skipmess: A or B yes' ) ;
+ ok( 1 == skipmess( 'AA' ), 'skipmess: A or B yes' ) ;
+ ok( 1 == skipmess( 'Ok Bye' ), 'skipmess: A or B yes' ) ;
- @skipmess = ( 'm#\A((?:[^\n]+\n)+|)^Content-Type: Message/Partial;[^\n]*\n(?:\n|.*\n\n)#ism' ) ; # SUPER BEST!
+ @skipmess = ( 'm#\A((?:[^\n]+\n)+|)^Content-Type: Message/Partial;[^\n]*\n(?:\n|.*\n\n)#ism' ) ; # SUPER BEST!
- ok( 1 == skipmess(
+ ok( 1 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Content-Type: Message/Partial; blabla
@@ -6769,7 +7960,7 @@ EOM
),
'skipmess: 1 match Content-Type: Message/Partial' ) ;
- ok( 0 == skipmess(
+ ok( 0 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6781,7 +7972,7 @@ EOM
'skipmess: 2 not match Content-Type: Message/Partial' ) ;
- ok( 1 == skipmess(
+ ok( 1 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6793,7 +7984,7 @@ EOM
),
'skipmess: 3 match Content-Type: Message/Partial' ) ;
- ok( 0 == skipmess(
+ ok( 0 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6806,7 +7997,7 @@ EOM
'skipmess: 4 not match Content-Type: Message/Partial' ) ;
- ok( 0 == skipmess(
+ ok( 0 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
@@ -6820,7 +8011,7 @@ EOM
'skipmess: 5 not match Content-Type: Message/Partial' ) ;
- ok( 1 == skipmess(
+ ok( 1 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Content-Type: Message/Partial; blabla
@@ -6835,7 +8026,7 @@ EOM
),
'skipmess: 6 match Content-Type: Message/Partial' ) ;
- ok( 1 == skipmess(
+ ok( 1 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Content-Type: Message/Partial;
@@ -6847,14 +8038,14 @@ EOM
),
'skipmess: 7 match Content-Type: Message/Partial' ) ;
- ok( 1 == skipmess(
+ ok( 1 == skipmess(
<<'EOM'
Date: Wed, 2 Jul 2014 02:26:40 +0000
MIME-Version: 1.0
Content-Type: message/partial;
- id="TAN_U_P<1404267997.00007489ed17>";
- number=3;
- total=3
+ id="TAN_U_P<1404267997.00007489ed17>";
+ number=3;
+ total=3
6HQ6Hh3CdXj77qEGixerQ6zHx0OnQ/Cf5On4W0Y6vtU2crABZQtD46Hx1EOh8dDz4+OnTr1G
@@ -6898,7 +8089,7 @@ Content-Type: message/partial;
test: aethaecohngiexao
EOM
-. "lalala\n" x 3000000
+. "lalala\n" x 3_000_000
),
'skipmess: 10 match Content-Type: Message/Partial' ) ;
@@ -6909,7 +8100,7 @@ From: [email protected] (Gilles LAMIRAL)
test: aethaecohngiexao
EOM
-. "lalala\n" x 3000000
+. "lalala\n" x 3_000_000
),
'skipmess: 11 match Content-Type: Message/Partial' ) ;
@@ -6925,69 +8116,75 @@ Content-Type: text/plain; charset=iso-8859-1\r
Content-Transfer-Encoding: 7bit\r
\r
EOM
-. qq{!#"$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefg\r\n } x 32730
+. qq{!#"d%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefg\r\n } x 32_730
),
'skipmess: 12 not match Content-Type: Message/Partial' ) ;
# Complex regular subexpression recursion limit (32766) exceeded with more lines
# exit;
- return ;
+
+ note( 'Leaving tests_skipmess()' ) ;
+ return ;
}
sub skipmess {
- my ( $string ) = @_ ;
- my $match ;
- #myprint( "$string\n" ) ;
- foreach my $skipmess ( @skipmess ) {
- $debug and myprint( "eval \$match = \$string =~ $skipmess\n" ) ;
- my $ret = eval "\$match = \$string =~ $skipmess ; 1" ;
- #myprint( "eval [$ret]\n" ) ;
- $debug and myprint( "match [$match]\n" ) ;
- if ( ( not $ret ) or $@ ) {
- myprint( "Error: eval skipmess '$skipmess': $@" ) ;
- return( undef ) ;
- }
- return( $match ) if ( $match ) ;
- }
- return( $match ) ;
+ my ( $string ) = @_ ;
+ my $match ;
+ #myprint( "$string\n" ) ;
+ foreach my $skipmess ( @skipmess ) {
+ $debug and myprint( "eval \$match = \$string =~ $skipmess\n" ) ;
+ my $ret = eval "\$match = \$string =~ $skipmess ; 1" ;
+ #myprint( "eval [$ret]\n" ) ;
+ $debug and myprint( "match [$match]\n" ) ;
+ if ( ( not $ret ) or $EVAL_ERROR ) {
+ myprint( "Error: eval skipmess '$skipmess': $EVAL_ERROR" ) ;
+ return( undef ) ;
+ }
+ return( $match ) if ( $match ) ;
+ }
+ return( $match ) ;
}
sub tests_bytes_display_string {
+ note( 'Entering tests_bytes_display_string()' ) ;
+
is( 'NA', bytes_display_string( ), 'bytes_display_string: no args => NA' ) ;
is( 'NA', bytes_display_string( undef ), 'bytes_display_string: undef => NA' ) ;
is( 'NA', bytes_display_string( 'blabla' ), 'bytes_display_string: blabla => NA' ) ;
-
- ok( '0.000 KiB' eq bytes_display_string( 0 ), 'bytes_display_string: 0' ) ;
- ok( '0.001 KiB' eq bytes_display_string( 1 ), 'bytes_display_string: 1' ) ;
- ok( '0.010 KiB' eq bytes_display_string( 10 ), 'bytes_display_string: 10' ) ;
- ok( '1.000 MiB' eq bytes_display_string( 1048575 ), 'bytes_display_string: 1048575' ) ;
- ok( '1.000 MiB' eq bytes_display_string( 1048576 ), 'bytes_display_string: 1048576' ) ;
- ok( '1.000 GiB' eq bytes_display_string( 1073741823 ), 'bytes_display_string: 1073741823 ' ) ;
- ok( '1.000 GiB' eq bytes_display_string( 1073741824 ), 'bytes_display_string: 1073741824 ' ) ;
+ ok( '0.000 KiB' eq bytes_display_string( 0 ), 'bytes_display_string: 0' ) ;
+ ok( '0.001 KiB' eq bytes_display_string( 1 ), 'bytes_display_string: 1' ) ;
+ ok( '0.010 KiB' eq bytes_display_string( 10 ), 'bytes_display_string: 10' ) ;
+ ok( '1.000 MiB' eq bytes_display_string( 1_048_575 ), 'bytes_display_string: 1_048_575' ) ;
+ ok( '1.000 MiB' eq bytes_display_string( 1_048_576 ), 'bytes_display_string: 1_048_576' ) ;
- ok( '1.000 TiB' eq bytes_display_string( 1099511627775 ), 'bytes_display_string: 1099511627775' ) ;
- ok( '1.000 TiB' eq bytes_display_string( 1099511627776 ), 'bytes_display_string: 1099511627776' ) ;
+ ok( '1.000 GiB' eq bytes_display_string( 1_073_741_823 ), 'bytes_display_string: 1_073_741_823 ' ) ;
+ ok( '1.000 GiB' eq bytes_display_string( 1_073_741_824 ), 'bytes_display_string: 1_073_741_824 ' ) ;
- ok( '1.000 PiB' eq bytes_display_string( 1125899906842623 ), 'bytes_display_string: 1125899906842623' ) ;
- ok( '1.000 PiB' eq bytes_display_string( 1125899906842624 ), 'bytes_display_string: 1125899906842624' ) ;
+ ok( '1.000 TiB' eq bytes_display_string( 1_099_511_627_775 ), 'bytes_display_string: 1_099_511_627_775' ) ;
+ ok( '1.000 TiB' eq bytes_display_string( 1_099_511_627_776 ), 'bytes_display_string: 1_099_511_627_776' ) ;
- ok( '1024.000 PiB' eq bytes_display_string( 1152921504606846975 ), 'bytes_display_string: 1152921504606846975' ) ;
- ok( '1024.000 PiB' eq bytes_display_string( 1152921504606846976 ), 'bytes_display_string: 1152921504606846976' ) ;
+ ok( '1.000 PiB' eq bytes_display_string( 1_125_899_906_842_623 ), 'bytes_display_string: 1_125_899_906_842_623' ) ;
+ ok( '1.000 PiB' eq bytes_display_string( 1_125_899_906_842_624 ), 'bytes_display_string: 1_125_899_906_842_624' ) ;
- ok( '1048576.000 PiB' eq bytes_display_string( 1180591620717411303424 ), 'bytes_display_string: 1180591620717411303424' ) ;
+ ok( '1024.000 PiB' eq bytes_display_string( 1_152_921_504_606_846_975 ), 'bytes_display_string: 1_152_921_504_606_846_975' ) ;
+ ok( '1024.000 PiB' eq bytes_display_string( 1_152_921_504_606_846_976 ), 'bytes_display_string: 1_152_921_504_606_846_976' ) ;
- #myprint( bytes_display_string( 1180591620717411303424 ), "\n" ) ;
- return ;
+ ok( '1048576.000 PiB' eq bytes_display_string( 1_180_591_620_717_411_303_424 ), 'bytes_display_string: 1_180_591_620_717_411_303_424' ) ;
+
+ #myprint( bytes_display_string( 1_180_591_620_717_411_303_424 ), "\n" ) ;
+ note( 'Leaving tests_bytes_display_string()' ) ;
+
+ return ;
}
sub bytes_display_string {
- my ( $bytes ) = @_ ;
+ my ( $bytes ) = @_ ;
- my $readable_value = q{} ;
+ my $readable_value = q{} ;
if ( ! defined( $bytes ) ) {
return( 'NA' ) ;
@@ -6997,71 +8194,69 @@ sub bytes_display_string {
return( 'NA' ) ;
}
-
- SWITCH: {
- if ( abs( $bytes ) < ( 1000 * $KIBI ) ) {
- $readable_value = mysprintf( '%.3f KiB', $bytes / $KIBI) ;
- last SWITCH ;
- }
- if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI ) ) {
- $readable_value = mysprintf( '%.3f MiB', $bytes / ($KIBI * $KIBI) ) ;
- last SWITCH ;
- }
- if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI) ) {
- $readable_value = mysprintf( '%.3f GiB', $bytes / ($KIBI * $KIBI * $KIBI) ) ;
- last SWITCH ;
- }
- if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI * $KIBI) ) {
- $readable_value = mysprintf( '%.3f TiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI) ) ;
- last SWITCH ;
- } else {
- $readable_value = mysprintf( '%.3f PiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI * $KIBI) ) ;
- }
- # if you have exabytes (EiB) of email to transfer, you have too much email!
- }
+
+ SWITCH: {
+ if ( abs( $bytes ) < ( 1000 * $KIBI ) ) {
+ $readable_value = mysprintf( '%.3f KiB', $bytes / $KIBI) ;
+ last SWITCH ;
+ }
+ if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI ) ) {
+ $readable_value = mysprintf( '%.3f MiB', $bytes / ($KIBI * $KIBI) ) ;
+ last SWITCH ;
+ }
+ if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI) ) {
+ $readable_value = mysprintf( '%.3f GiB', $bytes / ($KIBI * $KIBI * $KIBI) ) ;
+ last SWITCH ;
+ }
+ if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI * $KIBI) ) {
+ $readable_value = mysprintf( '%.3f TiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI) ) ;
+ last SWITCH ;
+ } else {
+ $readable_value = mysprintf( '%.3f PiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI * $KIBI) ) ;
+ }
+ # if you have exabytes (EiB) of email to transfer, you have too much email!
+ }
#myprint( "$bytes = $readable_value\n" ) ;
return( $readable_value ) ;
}
sub stats {
- my $sync_loc = shift ;
+ my $mysync = shift ;
- if ( ! $sync_loc->{stats} ) {
+ if ( ! $mysync->{stats} ) {
return ;
}
-
- $timeend = time ;
- my $timediff = $timeend - $sync_loc->{timestart} ;
- my $timeend_str = localtime $timeend ;
+ my $timeend = time ;
+ my $timediff = $timeend - $mysync->{timestart} ;
+
+ my $timeend_str = localtime $timeend ;
- my $memory_consumption = 0 ;
+ my $memory_consumption = 0 ;
$memory_consumption = memory_consumption( ) || 0 ;
- my $memory_ratio = ($max_msg_size_in_bytes) ?
- mysprintf('%.1f', $memory_consumption / $max_msg_size_in_bytes) : 'NA' ;
-
- my $host1_reconnect_count = $imap1->Reconnect_counter() || 0 ;
- my $host2_reconnect_count = $imap2->Reconnect_counter() || 0 ;
-
- myprint( "++++ Statistics\n" ) ;
- myprint( "Transfer started on : $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( "Messages transferred : $nb_msg_transferred " ) ;
- myprint( "(could be $nb_msg_skipped_dry_mode without dry mode)" ) if ( $dry ) ;
- myprint( "\n" ) ;
- myprint( "Messages skipped : $nb_msg_skipped\n" ) ;
- myprint( "Messages found duplicate on host1 : $h1_nb_msg_duplicate\n" ) ;
- myprint( "Messages found duplicate on host2 : $h2_nb_msg_duplicate\n" ) ;
- myprint( "Messages void (noheader) on host1 : $h1_nb_msg_noheader\n" ) ;
- myprint( "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n" ) ;
- myprint( "Messages deleted on host1 : $h1_nb_msg_deleted\n" ) ;
- myprint( "Messages deleted on host2 : $h2_nb_msg_deleted\n" ) ;
+ my $memory_ratio = ($max_msg_size_in_bytes) ?
+ mysprintf('%.1f', $memory_consumption / $max_msg_size_in_bytes) : 'NA' ;
+
+
+ myprint( "++++ Statistics\n" ) ;
+ myprint( "Transfer started on : $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( "Messages transferred : $mysync->{nb_msg_transferred} " ) ;
+ myprint( "(could be $nb_msg_skipped_dry_mode without dry mode)" ) if ( $mysync->{dry} ) ;
+ myprint( "\n" ) ;
+ myprint( "Messages skipped : $nb_msg_skipped\n" ) ;
+ myprint( "Messages found duplicate on host1 : $h1_nb_msg_duplicate\n" ) ;
+ myprint( "Messages found duplicate on host2 : $h2_nb_msg_duplicate\n" ) ;
+ myprint( "Messages void (noheader) on host1 : $h1_nb_msg_noheader\n" ) ;
+ myprint( "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n" ) ;
+ myprint( "Messages deleted on host1 : $h1_nb_msg_deleted\n" ) ;
+ myprint( "Messages deleted on host2 : $h2_nb_msg_deleted\n" ) ;
myprintf( "Total bytes transferred : %s (%s)\n",
- $total_bytes_transferred,
- bytes_display_string( $total_bytes_transferred ) ) ;
+ $mysync->{total_bytes_transferred},
+ bytes_display_string( $mysync->{total_bytes_transferred} ) ) ;
myprintf( "Total bytes duplicate host1 : %s (%s)\n",
$h1_total_bytes_duplicate,
bytes_display_string( $h1_total_bytes_duplicate) ) ;
@@ -7074,62 +8269,62 @@ sub stats {
myprintf( "Total bytes error : %s (%s)\n",
$total_bytes_error,
bytes_display_string( $total_bytes_error ) ) ;
- $timediff ||= 1 ; # No division per 0
- myprintf("Message rate : %.1f messages/s\n", $nb_msg_transferred / $timediff ) ;
- myprintf("Average bandwidth rate : %.1f KiB/s\n", $total_bytes_transferred / $KIBI / $timediff ) ;
- #myprint( "Reconnections to host1 : $host1_reconnect_count\n" ) ;
- #myprint( "Reconnections to host2 : $host2_reconnect_count\n" ) ;
- myprintf("Memory consumption : %.1f MiB\n", $memory_consumption / $KIBI / $KIBI ) ;
+ $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 : %.1f MiB\n", $memory_consumption / $KIBI / $KIBI ) ;
myprintf("Biggest message : %s bytes (%s)\n",
$max_msg_size_in_bytes,
bytes_display_string( $max_msg_size_in_bytes) ) ;
- myprint( "Memory/biggest message ratio : $memory_ratio\n" ) ;
+ myprint( "Memory/biggest message ratio : $memory_ratio\n" ) ;
if ( $foldersizesatend and $foldersizes ) {
-
+
my $nb_msg_start_diff = diff_or_NA( $h2_nb_msg_start, $h1_nb_msg_start ) ;
my $bytes_start_diff = diff_or_NA( $h2_bytes_start, $h1_bytes_start ) ;
-
- myprintf("Start difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_start_diff,
+
+ myprintf("Start difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_start_diff,
$bytes_start_diff,
bytes_display_string( $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 ) ;
-
- myprintf("Final difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_end_diff,
+
+ myprintf("Final difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_end_diff,
$bytes_end_diff,
bytes_display_string( $bytes_end_diff ) ) ;
}
- myprint( "Detected $sync->{nb_errors} errors\n\n" ) ;
+ myprint( "Detected $mysync->{nb_errors} errors\n\n" ) ;
- myprint( $warn_release, "\n" ) ;
- myprint( thank_author( ) ) ;
- return ;
+ myprint( $warn_release, "\n" ) ;
+ myprint( homepage( ), "\n" ) ;
+ return ;
}
sub diff_or_NA {
my( $n1, $n2 ) = @ARG ;
-
+
if ( not defined $n1 or not defined $n2 ) {
return 'NA' ;
}
-
- if ( not match_number( $n1 )
+
+ if ( not match_number( $n1 )
or not match_number( $n2 ) ) {
return 'NA' ;
}
-
+
return( $n1 - $n2 ) ;
}
sub match_number {
my $n = shift @ARG ;
-
+
if ( not defined $n ) {
return 0 ;
}
- if ( $n =~ /[0-9]+\.?[0-9]?/ ) {
+ if ( $n =~ /[0-9]+\.?[0-9]?/x ) {
return 1 ;
}
else {
@@ -7139,6 +8334,8 @@ sub match_number {
sub tests_match_number {
+ note( 'Entering tests_match_number()' ) ;
+
is( 0, match_number( ), 'match_number: no parameters => 0' ) ;
is( 0, match_number( undef ), 'match_number: undef => 0' ) ;
@@ -7147,12 +8344,16 @@ sub tests_match_number {
is( 1, match_number( 1 ), 'match_number: 1 => 1' ) ;
is( 1, match_number( 1.0 ), 'match_number: 1.0 => 1' ) ;
is( 1, match_number( 0.0 ), 'match_number: 0.0 => 1' ) ;
+
+ note( 'Leaving tests_match_number()' ) ;
return ;
}
sub tests_diff_or_NA {
+ note( 'Entering tests_diff_or_NA()' ) ;
+
is( 'NA', diff_or_NA( ), 'diff_or_NA: no parameters => NA' ) ;
is( 'NA', diff_or_NA( undef ), 'diff_or_NA: undef => NA' ) ;
@@ -7167,127 +8368,120 @@ sub tests_diff_or_NA {
is( 0, diff_or_NA( 1.0, 1 ), 'diff_or_NA: 1.0 1 => 0' ) ;
is( 1, diff_or_NA( 1.0, 0 ), 'diff_or_NA: 1.0 0 => 1' ) ;
is( -1, diff_or_NA( 0, 1.0 ), 'diff_or_NA: 0 1.0 => -1' ) ;
+
+ note( 'Leaving tests_diff_or_NA()' ) ;
return ;
}
-sub thank_author {
- return( "Homepage: http://imapsync.lamiral.info/\n" ) ;
+sub homepage {
+ return( 'Homepage: http://imapsync.lamiral.info/' ) ;
}
sub load_modules {
-
- if ( $ssl1 or $ssl2 or $tls1 or $tls2) {
- # not yet a "use" statement
- require IO::Socket::SSL ;
- if ( $sync->{inet4} ) {
- IO::Socket::SSL->import( 'inet4' ) ;
- }
- if ( $sync->{inet6} ) {
- IO::Socket::SSL->import( 'inet6' ) ;
- }
- }
-
- if ( ( ( not( $password1 or $passfile1 ) )
- or (not ( $password2 or $passfile2 ) )
- )
- and ( not $help ) ) {
- # now a "use" statement
- #require Term::ReadKey ;
+ if ( $sync->{ssl1}
+ or $sync->{ssl2}
+ or $sync->{tls1}
+ or $sync->{tls2}) {
+ if ( $sync->{inet4} ) {
+ IO::Socket::SSL->import( 'inet4' ) ;
+ }
+ if ( $sync->{inet6} ) {
+ IO::Socket::SSL->import( 'inet6' ) ;
+ }
}
-
- return ;
+ return ;
}
sub parse_header_msg {
- my ( $imap, $m_uid, $s_heads, $s_fir, $side, $s_hash ) = @_ ;
+ my ( $imap, $m_uid, $s_heads, $s_fir, $side, $s_hash ) = @_ ;
- my $head = $s_heads->{$m_uid} ;
- my $headnum = scalar keys %{ $head } ;
- $debug and myprint( "$side uid $m_uid head nb pass one: ", $headnum, "\n" ) ;
+ my $head = $s_heads->{$m_uid} ;
+ my $headnum = scalar keys %{ $head } ;
+ $debug and myprint( "$side uid $m_uid head nb pass one: ", $headnum, "\n" ) ;
- if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){
- myprint( "$side uid $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 ;
+ if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){
+ myprint( "$side uid $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 ;
#myprint( $whole_header ) ;
$head = decompose_header( $whole_header ) ;
$headnum = scalar keys %{ $head } ;
- $debug and myprint( "$side uid $m_uid head nb pass two: ", $headnum, "\n" ) ;
- }
+ $debug and myprint( "$side uid $m_uid head nb pass two: ", $headnum, "\n" ) ;
+ }
#myprint( Data::Dumper->Dump( [ $head, \%useheader ] ) ) ;
- my $headstr ;
+ my $headstr ;
$headstr = header_construct( $head, $side, $m_uid ) ;
- if ( ( ! $headstr) and ( $addheader ) and ( $side eq 'Host1' ) ) {
- my $header = add_header( $m_uid ) ;
- myprint( "Host1 uid $m_uid no header found so adding our own [$header]\n" ) ;
- $headstr .= uc $header ;
- $s_fir->{$m_uid}->{NO_HEADER} = 1;
- }
+ if ( ( ! $headstr) and ( $addheader ) and ( $side eq 'Host1' ) ) {
+ my $header = add_header( $m_uid ) ;
+ myprint( "Host1 uid $m_uid no header found so adding our own [$header]\n" ) ;
+ $headstr .= uc $header ;
+ $s_fir->{$m_uid}->{NO_HEADER} = 1;
+ }
- return if ( ! $headstr ) ;
+ return if ( ! $headstr ) ;
- my $size = $s_fir->{$m_uid}->{'RFC822.SIZE'} ;
- my $flags = $s_fir->{$m_uid}->{'FLAGS'} ;
- my $idate = $s_fir->{$m_uid}->{'INTERNALDATE'} ;
- $size = length $headstr unless ( $size ) ;
- my $m_md5 = md5_base64( $headstr ) ;
- $debug and myprint( "$side uid $m_uid sig $m_md5 size $size idate $idate\n" ) ;
- my $key ;
+ my $size = $s_fir->{$m_uid}->{'RFC822.SIZE'} ;
+ my $flags = $s_fir->{$m_uid}->{'FLAGS'} ;
+ my $idate = $s_fir->{$m_uid}->{'INTERNALDATE'} ;
+ $size = length $headstr unless ( $size ) ;
+ my $m_md5 = md5_base64( $headstr ) ;
+ $debug and myprint( "$side uid $m_uid sig $m_md5 size $size idate $idate\n" ) ;
+ my $key ;
if ($skipsize) {
$key = "$m_md5";
}
- else {
+ else {
$key = "$m_md5:$size";
}
- # 0 return code is used to identify duplicate message hash
- return 0 if exists $s_hash->{"$key"};
- $s_hash->{"$key"}{'5'} = $m_md5;
- $s_hash->{"$key"}{'s'} = $size;
- $s_hash->{"$key"}{'D'} = $idate;
- $s_hash->{"$key"}{'F'} = $flags;
- $s_hash->{"$key"}{'m'} = $m_uid;
+ # 0 return code is used to identify duplicate message hash
+ return 0 if exists $s_hash->{"$key"};
+ $s_hash->{"$key"}{'5'} = $m_md5;
+ $s_hash->{"$key"}{'s'} = $size;
+ $s_hash->{"$key"}{'D'} = $idate;
+ $s_hash->{"$key"}{'F'} = $flags;
+ $s_hash->{"$key"}{'m'} = $m_uid;
- return( 1 ) ;
+ return( 1 ) ;
}
sub header_construct {
- my( $head, $side, $m_uid ) = @_ ;
+ my( $head, $side, $m_uid ) = @_ ;
my $headstr ;
- foreach my $h ( sort keys %{ $head } ) {
+ foreach my $h ( sort keys %{ $head } ) {
next if ( not ( exists $useheader{ uc $h } )
and ( not exists $useheader{ 'ALL' } )
) ;
- foreach my $val ( sort @{$head->{$h}} ) {
+ foreach my $val ( sort @{$head->{$h}} ) {
my $H = header_line_normalize( $h, $val ) ;
- # show stuff in debug mode
- $debug and myprint( "$side uid $m_uid header [$H]", "\n" ) ;
+ # show stuff in debug mode
+ $debug and myprint( "$side uid $m_uid header [$H]", "\n" ) ;
- if ($skipheader and $H =~ m/$skipheader/xi) {
- $debug and myprint( "$side uid $m_uid skipping header [$H]\n" ) ;
- next ;
- }
- $headstr .= "$H" ;
- }
- }
- return( $headstr ) ;
+ if ($skipheader and $H =~ m/$skipheader/xi) {
+ $debug and myprint( "$side uid $m_uid skipping header [$H]\n" ) ;
+ next ;
+ }
+ $headstr .= "$H" ;
+ }
+ }
+ return( $headstr ) ;
}
sub header_line_normalize {
- my( $header_key, $header_val ) = @_ ;
+ my( $header_key, $header_val ) = @_ ;
# no 8-bit data in headers !
$header_val =~ s/[\x80-\xff]/X/xog;
@@ -7312,20 +8506,23 @@ sub header_line_normalize {
my $header_line = uc "$header_key: $header_val" ;
- return( $header_line ) ;
+ return( $header_line ) ;
}
sub tests_header_line_normalize {
+ note( 'Entering tests_header_line_normalize()' ) ;
- ok( ': ' eq header_line_normalize( q{}, q{} ), 'header_line_normalize: empty args' ) ;
- ok( 'HHH: VVV' eq header_line_normalize( 'hhh', 'vvv' ), 'header_line_normalize: hhh vvv ' ) ;
- ok( 'HHH: VVV' eq header_line_normalize( 'hhh', ' vvv' ), 'header_line_normalize: remove first blancs' ) ;
- ok( 'HHH: AA BB CCC D' eq header_line_normalize( 'hhh', 'aa bb ccc d' ), 'header_line_normalize: remove succesive blanks' ) ;
- ok( 'HHH: AA BB CCC' eq header_line_normalize( 'hhh', 'aa bb ccc ' ), 'header_line_normalize: remove last blanks' ) ;
- ok( 'HHH: VVV XX YY' eq header_line_normalize( 'hhh', "vvv\t\txx\tyy" ), 'header_line_normalize: tabs' ) ;
- ok( 'HHH: XABX' eq header_line_normalize( 'hhh', "\x80AB\xff" ), 'header_line_normalize: 8bit' ) ;
- return ;
+ ok( ': ' eq header_line_normalize( q{}, q{} ), 'header_line_normalize: empty args' ) ;
+ ok( 'HHH: VVV' eq header_line_normalize( 'hhh', 'vvv' ), 'header_line_normalize: hhh vvv ' ) ;
+ ok( 'HHH: VVV' eq header_line_normalize( 'hhh', ' vvv' ), 'header_line_normalize: remove first blancs' ) ;
+ ok( 'HHH: AA BB CCC D' eq header_line_normalize( 'hhh', 'aa bb ccc d' ), 'header_line_normalize: remove succesive blanks' ) ;
+ ok( 'HHH: AA BB CCC' eq header_line_normalize( 'hhh', 'aa bb ccc ' ), 'header_line_normalize: remove last blanks' ) ;
+ ok( 'HHH: VVV XX YY' eq header_line_normalize( 'hhh', "vvv\t\txx\tyy" ), 'header_line_normalize: tabs' ) ;
+ ok( 'HHH: XABX' eq header_line_normalize( 'hhh', "\x80AB\xff" ), 'header_line_normalize: 8bit' ) ;
+
+ note( 'Leaving tests_header_line_normalize()' ) ;
+ return ;
}
@@ -7334,9 +8531,14 @@ sub firstline {
my( $file ) = @_ ;
my $line = q{} ;
- my $FILE ;
- open $FILE, '<', $file or do {
- myprint( "Error opening file $file : $!\n" ) ;
+
+ if ( ! -e $file ) {
+ myprint( "Cannot open file $file since it does not exist\n" ) ;
+ return ;
+ }
+
+ open my $FILE, '<', $file or do {
+ myprint( "Error opening file $file : $OS_ERROR\n" ) ;
return ;
} ;
$line = <$FILE> || q{} ;
@@ -7346,34 +8548,113 @@ sub firstline {
}
sub tests_firstline {
- is( 1 , string_to_file( "blabla\n", 'tmp/firstline.txt' ), 'tests_firstline: put blabla in tmp/firstline.txt' ) ;
- is( 'blabla' , firstline( 'tmp/firstline.txt' ), 'tests_firstline: get blabla from tmp/firstline.txt' ) ;
- is( undef , firstline( 'tmp/noexist.txt' ), 'tests_firstline: get blabla from tmp/noexist.txt' ) ;
- is( 1 , string_to_file( q{}, 'tmp/firstline2.txt' ), 'tests_firstline: put empty string in tmp/firstline2.txt' ) ;
- is( q{} , firstline( 'tmp/firstline2.txt' ), 'tests_firstline: get empty string from tmp/firstline2.txt' ) ;
- is( 1 , string_to_file( "\n", 'tmp/firstline3.txt' ), 'tests_firstline: put CR in tmp/firstline3.txt' ) ;
- is( q{} , firstline( 'tmp/firstline3.txt' ), 'tests_firstline: get empty string from tmp/firstline3.txt' ) ;
+ note( 'Entering tests_firstline()' ) ;
+ is( undef , firstline( 'W/tmp/tests/noexist.txt' ), 'tests_firstline: not getting blabla from W/tmp/tests/noexist.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' ), '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' ), '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' ) ;
+
+ note( 'Leaving tests_firstline()' ) ;
return ;
}
+
+# Should be unit tested and then be used by file_to_string, refactoring file_to_string
+sub file_to_array {
+
+ my( $file ) = shift ;
+ my @string ;
+
+ open my $FILE, '<', $file or do {
+ myprint( "Error reading file $file : $OS_ERROR" ) ;
+ return ;
+ } ;
+ @string = <$FILE> ;
+ close $FILE ;
+ return( @string ) ;
+}
+
+
+sub tests_file_to_string {
+ note( 'Entering tests_file_to_string()' ) ;
+
+ is( undef, file_to_string( ), 'file_to_string: no args => undef' ) ;
+ is( undef, file_to_string( '/noexist' ), 'file_to_string: /noexist => undef' ) ;
+ is( undef, file_to_string( '/' ), 'file_to_string: reading a directory => undef' ) ;
+ ok( file_to_string( $PROGRAM_NAME ), 'file_to_string: reading myself' ) ;
+
+ ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'file_to_string: mkpath W/tmp/tests/' ) ;
+
+ is( 'lilili', string_to_file( 'lilili', 'W/tmp/tests/canbewritten' ), 'file_to_string: string_to_file filling W/tmp/tests/canbewritten with lilili' ) ;
+ is( 'lilili', file_to_string( 'W/tmp/tests/canbewritten' ), 'file_to_string: reading W/tmp/tests/canbewritten is lilili' ) ;
+
+ is( q{}, string_to_file( q{}, 'W/tmp/tests/empty' ), 'file_to_string: string_to_file filling W/tmp/tests/empty with empty string' ) ;
+ is( q{}, file_to_string( 'W/tmp/tests/empty' ), 'file_to_string: reading W/tmp/tests/empty is empty' ) ;
+
+ note( 'Leaving tests_file_to_string()' ) ;
+ return ;
+}
+
sub file_to_string {
- my( $file ) = @_ ;
- my @string ;
- open my $FILE, '<', $file or die_clean( "Error with file $file : $! " ) ;
- @string = <$FILE> ;
- close $FILE ;
- return( join q{}, @string ) ;
+ my $file = shift ;
+ if ( ! $file ) { return ; }
+ if ( ! -e $file ) { return ; }
+ if ( ! -f $file ) { return ; }
+ if ( ! -r $file ) { return ; }
+ my @string ;
+ if ( open my $FILE, '<', $file ) {
+ @string = <$FILE> ;
+ close $FILE ;
+ return( join q{}, @string ) ;
+ }else{
+ myprint( "Error reading file $file : $OS_ERROR\n" ) ;
+ return ;
+ }
}
+sub tests_string_to_file {
+ note( 'Entering tests_string_to_file()' ) ;
+
+ is( undef, string_to_file( ), 'string_to_file: no args => undef' ) ;
+ 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/' ) ;
+ 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' ) ;
+
+ SKIP: {
+ Readonly my $NB_UNX_tests_string_to_file => 1 ;
+ skip( 'Not on Unix', $NB_UNX_tests_string_to_file ) if ('MSWin32' eq $OSNAME) ;
+ is( undef, string_to_file( 'lalala', '/cantouch' ), 'string_to_file: /cantouch denied => undef' ) ;
+ }
+
+ note( 'Leaving tests_string_to_file()' ) ;
+ return ;
+}
+
sub string_to_file {
- my( $string, $file ) = @_ ;
- sysopen( FILE, $file, O_WRONLY|O_TRUNC|O_CREAT, 0600) or die_clean( "$! $file" ) ;
- print FILE $string ;
- close FILE ;
- return 1 ;
+ my( $string, $file ) = @_ ;
+ if( ! defined $string ) { return ; }
+ if( ! defined $file ) { return ; }
+
+ if ( ! -e $file && ! -w dirname( $file ) ) {
+ myprint( "string_to_file: directory of $file is not writable\n" ) ;
+ return ;
+ }
+
+ if ( ! sysopen( FILE, $file, O_WRONLY|O_TRUNC|O_CREAT, 0600) ) {
+ myprint( "string_to_file: failure writing to $file with error: $OS_ERROR\n" ) ;
+ return ;
+ }
+ print FILE $string ;
+ close FILE ;
+ return $string ;
}
q^
@@ -7383,18 +8664,18 @@ Based on David Carter discussion, to do:
* 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 )
+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.
+ on console and at the end with the final error listing. Count this as a sync error.
^ if 0 ; # End of multiline comment.
sub pipemess {
- my ( $string, @commands ) = @_ ;
- my $error = q{} ;
+ my ( $string, @commands ) = @_ ;
+ my $error = q{} ;
foreach my $command ( @commands ) {
my $input_tmpfile = "$tmpdir/imapsync_tmp_file.$PROCESS_ID.inp.txt" ;
my $output_tmpfile = "$tmpdir/imapsync_tmp_file.$PROCESS_ID.out.txt" ;
@@ -7404,22 +8685,22 @@ sub pipemess {
my $is_command_ko = $CHILD_ERROR ;
my $error_cmd = file_to_string( $error_tmpfile ) ;
chomp( $error_cmd ) ;
- $string = file_to_string( $output_tmpfile ) ;
+ $string = file_to_string( $output_tmpfile ) ;
my $string_len = length( $string ) ;
unlink $input_tmpfile, $output_tmpfile, $error_tmpfile ;
- if ( $is_command_ko or ( ! $string_len ) ) {
- my $cmd_exit_value = $CHILD_ERROR >> 8 ;
- my $cmd_end_signal = $CHILD_ERROR & 127 ;
+ if ( $is_command_ko or ( ! $string_len ) ) {
+ my $cmd_exit_value = $CHILD_ERROR >> 8 ;
+ my $cmd_end_signal = $CHILD_ERROR & 127 ;
my $signal_log = ( $cmd_end_signal ) ? " signal $cmd_end_signal and" : q{} ;
my $error_log = qq{Failure: --pipemess command "$command" ended with$signal_log "$string_len" characters exit value "$cmd_exit_value" and STDERR "$error_cmd"\n} ;
- myprint( $error_log ) ;
- if ( wantarray ) {
+ myprint( $error_log ) ;
+ if ( wantarray ) {
return @{ [ undef, $error_log ] }
}else{
return ;
}
- }
+ }
if ( $error_cmd ) {
$error .= qq{STDERR of --pipemess "$command": $error_cmd\n} ;
myprint( qq{STDERR of --pipemess "$command": $error_cmd\n} ) ;
@@ -7436,39 +8717,41 @@ sub pipemess {
sub tests_pipemess {
+ note( 'Entering tests_pipemess()' ) ;
- SKIP: {
+
+ SKIP: {
Readonly my $NB_WIN_tests_pipemess => 3 ;
- skip( 'Not on MSWin32', $NB_WIN_tests_pipemess ) if ('MSWin32' ne $OSNAME) ;
- # 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' ) ;
- # command not found
- #diag( 'Warning and failure about cacaprout are on purpose' ) ;
- ok( ! defined( pipemess( q{}, 'cacaprout' ) ), 'pipemess: command not found' ) ;
+ skip( 'Not on MSWin32', $NB_WIN_tests_pipemess ) if ('MSWin32' ne $OSNAME) ;
+ # 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' ) ;
+ # command not found
+ #diag( 'Warning and failure about cacaprout are on purpose' ) ;
+ ok( ! defined( pipemess( q{}, 'cacaprout' ) ), 'pipemess: command not found' ) ;
- } ;
+ } ;
my ( $stringT, $errorT ) ;
- SKIP: {
+ SKIP: {
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' ) ;
+ 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( 'nochange2' eq pipemess( 'nochange2', 'cat', 'cat' ), 'pipemess: no change by cat,cat' ) ;
+ ok( 'nochange2' eq pipemess( 'nochange2', 'cat', 'cat' ), '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' ), '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( "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' ), 'pipemess: sort' ) ;
- # command not found
- #diag( 'Warning and failure about cacaprout are on purpose' ) ;
- is( undef, pipemess( q{}, 'cacaprout' ), 'pipemess: command not found' ) ;
+ # command not found
+ #diag( 'Warning and failure about cacaprout are on purpose' ) ;
+ is( undef, pipemess( q{}, 'cacaprout' ), 'pipemess: command not found' ) ;
# success with true but no output at all
is( undef, pipemess( q{blabla}, 'true' ), 'pipemess: true but no output' ) ;
@@ -7476,376 +8759,714 @@ sub tests_pipemess {
# failure with false and no output at all
is( undef, pipemess( q{blabla}, 'false' ), '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 )' ) ;
+ # 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 )' ) ;
( $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' ) ;
-
+
( $stringT, $errorT ) = pipemess( 'dontcare', 'true' ) ;
is( $stringT, undef, 'pipemess: list context, true but no output, string' ) ;
- like( $errorT, qr{Failure: --pipemess command "true" ended with "0" characters exit value "0" and STDERR ""}, 'pipemess: list context, true but no output, error' ) ;
+ 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' ) ;
( $stringT, $errorT ) = pipemess( 'dontcare', 'false' ) ;
is( $stringT, undef, 'pipemess: list context, false and no output, string' ) ;
- like( $errorT, qr{Failure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""}, 'pipemess: list context, false and no output, error' ) ;
+ 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' ) ;
- ( $stringT, $errorT ) = pipemess( 'dontcare', 'echo -n blablabla' ) ;
+ ( $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' ) ;
-
+
( $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"$}, 'pipemess: list context, "no output STDERR blablabla", error' ) ;
+ like( $errorT, qr{blablabla"}xm, '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"$}, 'pipemess: list context, "no output STDERR blablabla then false", error' ) ;
+ like( $errorT, qr{blablabla"}xm, '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' ) ;
- like( $errorT, qr{Failure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""}, 'pipemess: list context, "false then STDERR blablabla", error' ) ;
+ 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' ) ;
( $stringT, $errorT ) = pipemess( 'dontcare', '( echo rrrrr ; echo -n error_blablabla 3>&1 1>&2 2>&3 )' ) ;
- like( $stringT, qr{rrrrr}, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", string' ) ;
- like( $errorT, qr{STDERR.*error_blablabla}, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", error' ) ;
+ 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' ) ;
- }
+ }
( $stringT, $errorT ) = pipemess( 'dontcare', 'cacaprout' ) ;
is( $stringT, undef, 'pipemess: list context, cacaprout not found, string' ) ;
- like( $errorT, qr{Failure: --pipemess command "cacaprout" ended with "0" characters exit value.*}, 'pipemess: list context, cacaprout not found, error' ) ;
+ like( $errorT, qr{\QFailure: --pipemess command "cacaprout" ended with "0" characters exit value\E}xm,
+ 'pipemess: list context, cacaprout not found, error' ) ;
- return ;
+ note( 'Leaving tests_pipemess()' ) ;
+ return ;
}
+
+
sub tests_is_a_release_number {
- ok(is_a_release_number($RELEASE_NUMBER_EXAMPLE_1), 'is_a_release_number 1.351') ;
- ok(is_a_release_number($RELEASE_NUMBER_EXAMPLE_2), 'is_a_release_number 42.4242') ;
- ok(is_a_release_number(imapsync_version()), 'is_a_release_number imapsync_version()') ;
- ok(! is_a_release_number('blabla' ), '! is_a_release_number blabla') ;
- return ;
+ note( 'Entering tests_is_a_release_number()' ) ;
+
+ ok(is_a_release_number($RELEASE_NUMBER_EXAMPLE_1), 'is_a_release_number 1.351') ;
+ ok(is_a_release_number($RELEASE_NUMBER_EXAMPLE_2), 'is_a_release_number 42.4242') ;
+ ok(is_a_release_number( imapsync_version( $sync ) ), 'is_a_release_number imapsync_version( )') ;
+ ok(! is_a_release_number('blabla' ), '! is_a_release_number blabla') ;
+
+ note( 'Leaving tests_is_a_release_number()' ) ;
+ return ;
}
sub is_a_release_number {
- my $number = shift;
+ my $number = shift;
+
+ return( $number =~ m{^\d+\.\d+$}xo ) ;
+}
+
+sub imapsync_version_public {
+
+ my $local_version = imapsync_version( $sync ) ;
+ my $imapsync_basename = imapsync_basename( ) ;
+ my $agent_info = "$OSNAME system, perl "
+ . mysprintf( '%vd', $PERL_VERSION)
+ . ", Mail::IMAPClient $Mail::IMAPClient::VERSION"
+ . " $imapsync_basename" ;
+ my $sock = IO::Socket::INET->new(
+ PeerAddr => 'imapsync.lamiral.info',
+ PeerPort => 80,
+ Proto => 'tcp',
+ ) ;
+ return( 'unknown' ) if not $sock ;
+ print $sock
+ "GET /prj/imapsync/VERSION HTTP/1.0\r\n",
+ "User-Agent: imapsync/$local_version ($agent_info)\r\n",
+ "Host: ks.lamiral.info\r\n\r\n" ;
+ my @line = <$sock> ;
+ close $sock ;
+ my $last_release = $line[$LAST] ;
+ chomp $last_release ;
+ return( $last_release ) ;
+}
+
+sub not_long_imapsync_version_public {
+ #myprint( "Entering not_long_imapsync_version_public\n" ) ;
+
+ my $fake = shift ;
+ if ( $fake ) { return $fake }
+
+ my $val ;
+
+ # Doesn't work with gethostbyname (see perlipc)
+ #local $SIG{ALRM} = sub { die "alarm\n" } ;
- return( $number =~ m{^\d+\.\d+$}xo ) ;
+ if ('MSWin32' eq $OSNAME) {
+ local $SIG{ALRM} = sub { die "alarm\n" } ;
+ }else{
+
+ POSIX::sigaction(SIGALRM,
+ POSIX::SigAction->new(sub { croak 'alarm' } ) )
+ or myprint( "Error setting SIGALRM handler: $OS_ERROR\n" ) ;
+ }
+
+ my $ret = eval {
+ alarm 3 ;
+ {
+ $val = imapsync_version_public( ) ;
+ #sleep 4 ;
+ #myprint( "End of imapsync_version_public\n" ) ;
+ }
+ alarm 0 ;
+ 1 ;
+ } ;
+ #myprint( "eval [$ret]\n" ) ;
+ if ( ( not $ret ) or $EVAL_ERROR ) {
+ #myprint( "$EVAL_ERROR" ) ;
+ if ($EVAL_ERROR =~ /alarm/) {
+ # timed out
+ return('timeout') ;
+ }else{
+ alarm 0 ;
+ return( 'unknown' ) ; # propagate unexpected errors
+ }
+ }else {
+ # Good!
+ return( $val ) ;
+ }
+}
+
+sub tests_not_long_imapsync_version_public {
+ note( 'Entering tests_not_long_imapsync_version_public()' ) ;
+
+
+ is( 1, is_a_release_number( not_long_imapsync_version_public( ) ),
+ 'not_long_imapsync_version_public: public release is a number' ) ;
+
+ note( 'Leaving tests_not_long_imapsync_version_public()' ) ;
+ return ;
}
sub check_last_release {
+ my $fake = shift ;
+ my $public_release = not_long_imapsync_version_public( $fake ) ;
+ $debug and myprint( "check_last_release: [$public_release]\n" ) ;
+ return( 'Imapsync public release is unknown' ) if ( $public_release eq 'unknown' ) ;
+ return( 'Imapsync public release is unknown (timeout)' ) if ( $public_release eq 'timeout' ) ;
+ return( "Imapsync public release is unknown ($public_release)" ) if ( ! is_a_release_number( $public_release ) ) ;
+
+ my $imapsync_here = imapsync_version( $sync ) ;
+
+ if ( $public_release > $imapsync_here ) {
+ return(
+ "New imapsync release $public_release available to replace this $imapsync_here\n"
+ . "Get it at https://imapsync.lamiral.info/dist/") ;
+ }else{
+ return( 'This imapsync is up to date. ' . "( local $imapsync_here >= official $public_release )") ;
+ }
- my $public_release = not_long_imapsync_version_public( ) ;
- $debug and myprint( "check_last_release: [$public_release]\n" ) ;
- return('unknown') if ($public_release eq 'unknown') ;
- return('timeout') if ($public_release eq 'timeout') ;
- return('unknown') if (! is_a_release_number( $public_release ) ) ;
+ return('really unknown') ; # Should never arrive here
+}
- my $imapsync_here = imapsync_version();
+sub tests_check_last_release {
+ note( 'Entering tests_check_last_release()' ) ;
- if ($public_release > $imapsync_here) {
- return("New imapsync release $public_release available");
- }else{
- return( 'This imapsync is up to date') ;
- }
+ diag( check_last_release( 1.1 ) ) ;
+ like( check_last_release( 1.1 ), qr/\Qup to date\E/mxs, 'check_last_release: up to date' ) ;
+ like( check_last_release( 1.1 ), qr/1\.1/mxs, 'check_last_release: up to date, include number' ) ;
+ diag( check_last_release( 999.999 ) ) ;
+ like( check_last_release( 999.999 ), qr/available/mxs, 'check_last_release: update available' ) ;
+ like( check_last_release( 999.999 ), qr/999\.999/mxs, 'check_last_release: update available, include number' ) ;
+ diag( check_last_release( ) ) ;
+ is( 'Imapsync public release is unknown', check_last_release( 'unknown' ), 'check_last_release: unknown' ) ;
+ is( 'Imapsync public release is unknown (timeout)', check_last_release( 'timeout' ), 'check_last_release: timeout' ) ;
+ is( 'Imapsync public release is unknown (lalala)', check_last_release( 'lalala' ), 'check_last_release: lalala' ) ;
+
+ note( 'Leaving tests_check_last_release()' ) ;
+ return ;
}
sub imapsync_version {
- my $rcs_imapsync = '$Id: imapsync,v 1.727 2016/08/19 10:30:36 gilles Exp gilles $ ' ;
+ my $mysync = shift ;
+ my $rcs = $mysync->{rcs} ;
my $imapsync_version ;
- if ( $rcs_imapsync =~ m{,v\s+(\d+\.\d+)}xo ) {
- $imapsync_version = $1
- } else {
- $imapsync_version = 'UNKNOWN' ;
+ $imapsync_version = version_from_rcs( $rcs ) ;
+
+ return( $imapsync_version ) ;
+}
+
+
+sub tests_version_from_rcs {
+ note( 'Entering tests_version_from_rcs()' ) ;
+
+ is( undef, version_from_rcs( ), 'version_from_rcs: no args => UNKNOWN' ) ;
+ is( 1.831, version_from_rcs( q{imapsync,v 1.831 2017/08/27} ), 'version_from_rcs: imapsync,v 1.831 2017/08/27 => 1.831' ) ;
+ is( 'UNKNOWN', version_from_rcs( 1.831 ), 'version_from_rcs: 1.831 => UNKNOWN' ) ;
+
+ note( 'Leaving tests_version_from_rcs()' ) ;
+ return ;
+}
+
+
+sub version_from_rcs {
+
+ my $rcs = shift ;
+ if ( ! $rcs ) { return ; }
+
+ my $version = 'UNKNOWN' ;
+
+ if ( $rcs =~ m{,v\s+(\d+\.\d+)}mxso ) {
+ $version = $1
}
- return( $imapsync_version ) ;
+
+ return( $version ) ;
}
+
sub tests_imapsync_basename {
- ok( imapsync_basename() =~ m/imapsync/, 'imapsync_basename: match imapsync');
- ok( 'blabla' ne imapsync_basename(), 'imapsync_basename: do not equal blabla');
- return ;
+ note( 'Entering tests_imapsync_basename()' ) ;
+
+ ok( imapsync_basename() =~ m/imapsync/, 'imapsync_basename: match imapsync');
+ ok( 'blabla' ne imapsync_basename(), 'imapsync_basename: do not equal blabla');
+
+ note( 'Leaving tests_imapsync_basename()' ) ;
+ return ;
}
-sub imapsync_basename {
+sub imapsync_basename {
- return basename($0);
+ return basename( $PROGRAM_NAME ) ;
}
-sub imapsync_version_public {
- my $local_version = imapsync_version();
- my $imapsync_basename = imapsync_basename();
- my $agent_info = "$OSNAME system, perl "
- . mysprintf( '%vd', $PERL_VERSION)
- . ", Mail::IMAPClient $Mail::IMAPClient::VERSION"
- . " $imapsync_basename";
- my $sock = IO::Socket::INET->new(
- PeerAddr => 'imapsync.lamiral.info',
- PeerPort => 80,
- Proto => 'tcp',
- ) ;
- return( 'unknown' ) if not $sock ;
- print $sock
- "GET /prj/imapsync/VERSION HTTP/1.0\n",
- "User-Agent: imapsync/$local_version ($agent_info)\n",
- "Host: ks.lamiral.info\n\n";
- my @line = <$sock>;
- close $sock ;
- my $last_release = $line[$LAST];
- chomp $last_release ;
- return($last_release) ;
+sub localhost_info {
+
+ my( $infos ) = join q{},
+ "Here is " . hostname() . ", a " . memory_available( ) . " [$OSNAME] system (",
+ join(q{ },
+ uname(),
+ ),
+ ")\n",
+ 'with Perl ',
+ mysprintf( '%vd ', $PERL_VERSION),
+ "and Mail::IMAPClient $Mail::IMAPClient::VERSION",
+ ;
+ return( $infos ) ;
}
-sub not_long_imapsync_version_public {
- #myprint( "Entering not_long_imapsync_version_public\n" ) ;
+sub tests_cpu_number {
+ note( 'Entering tests_cpu_number()' ) ;
- my $val;
+ ok( 1 <= cpu_number( ), "cpu_number: 1 or more" ) ;
- # Doesn't work with gethostbyname (see perlipc)
- #local $SIG{ALRM} = sub { die "alarm\n" };
+ note( 'Leaving tests_cpu_number()' ) ;
+ return ;
+}
- if ('MSWin32' eq $OSNAME) {
- local $SIG{ALRM} = sub { die "alarm\n" };
- }else{
+sub cpu_number {
+ my @cpuinfo ;
- POSIX::sigaction(SIGALRM,
- POSIX::SigAction->new(sub { croak 'alarm' } ) )
- or myprint( "Error setting SIGALRM handler: $!\n" ) ;
+ # Well, here 1 is better than 0 or undef
+ my $cpu_number = 1 ; # Default value, erased if better found
+
+ if ( $ENV{"NUMBER_OF_PROCESSORS"} ) {
+ # might be under a Windows system
+ $cpu_number = $ENV{"NUMBER_OF_PROCESSORS"} ;
+ $debug and myprint( "Number of processors found by envvar NUMBER_OF_PROCESSORS: $cpu_number\n" ) ;
+ return $cpu_number ;
}
- my $ret = eval {
- alarm 3 ;
- {
- $val = imapsync_version_public( ) ;
- #sleep 4 ;
- #myprint( "End of imapsync_version_public\n" ) ;
- }
- alarm 0 ;
- 1 ;
+ if ( 'darwin' eq $OSNAME ) {
+ $cpu_number = `sysctl -n hw.ncpu` ;
+ chomp( $cpu_number ) ;
+ return $cpu_number ;
+ }
+
+ if ( ! -e '/proc/cpuinfo' ) {
+ $debug and myprint( "Number of processors not found so use: $cpu_number\n" ) ;
+ return $cpu_number ;
+ }
+
+ @cpuinfo = file_to_array( '/proc/cpuinfo' ) ;
+ if ( @cpuinfo ) {
+ $cpu_number = grep { /^processor/mxs } @cpuinfo ;
+ }
+ $debug and myprint( "Number of processors found via /proc/cpuinfo: $cpu_number\n" ) ;
+ return $cpu_number ;
+}
+
+
+
+sub tests_loadavg {
+ note( 'Entering tests_loadavg()' ) ;
+
+
+ SKIP: {
+ skip( 'Tests for darwin', 2 ) if ('darwin' ne $OSNAME) ;
+ is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ;
+ is_deeply( [ '0.11', '0.22', '0.33' ],
+ [ loadavg( 'W/t/loadavg.out' ) ],
+ 'loadavg W/t/loadavg.out => 0.11 0.22 0.33' ) ;
} ;
- #myprint( "eval [$ret]\n" ) ;
- if ( ( not $ret ) or $@ ) {
- #myprint( "$@" ) ;
- if ($@ =~ /alarm/) {
- # timed out
- return('timeout');
- }else{
- alarm 0 ;
- return('unknown'); # propagate unexpected errors
- }
- }else {
- # Good!
- return($val);
+
+ SKIP: {
+ skip( 'Tests for linux', 3 ) if ('linux' ne $OSNAME) ;
+ is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ;
+ ok( loadavg( ), 'loadavg: no args' ) ;
+
+ is_deeply( [ '0.39', '0.30', '0.37', '1/602' ],
+ [ loadavg( '0.39 0.30 0.37 1/602 6073' ) ],
+ 'loadavg 0.39 0.30 0.37 1/602 6073 => [0.39, 0.30, 0.37, 1/602]' ) ;
+ } ;
+
+ SKIP: {
+ skip( 'Tests for Windows', 1 ) if ('MSWin32' ne $OSNAME) ;
+ is_deeply( [ 0 ],
+ [ loadavg( ) ],
+ 'loadavg on MSWin32 => 0' ) ;
+
+ } ;
+
+ note( 'Leaving tests_loadavg()' ) ;
+ return ;
+}
+
+
+sub loadavg {
+ if ( 'linux' eq $OSNAME ) {
+ return ( loadavg_linux( @ARG ) ) ;
}
+ if ( 'darwin' eq $OSNAME ) {
+ return ( loadavg_darwin( @ARG ) ) ;
+ }
+ if ( 'MSWin32' eq $OSNAME ) {
+ return ( loadavg_windows( @ARG ) ) ;
+ }
+ return( 'unknown' ) ;
+
}
-sub localhost_info {
+sub loadavg_linux {
+ my $line = shift ;
- my($infos) = join q{},
- "Here is a [$OSNAME] system (",
- join(q{ },
- uname(),
- ),
- ")\n",
- 'with Perl ',
- mysprintf( '%vd', $PERL_VERSION),
- " Mail::IMAPClient $Mail::IMAPClient::VERSION",
- ;
- return($infos) ;
+ 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 ) ) {
+ $debug and print "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 ) ;
+ }
+ return ;
+}
+
+
+sub loadavg_darwin {
+ my $file = shift ;
+ # Example of output of command "sysctl vm.loadavg":
+ # vm.loadavg: { 0.15 0.08 0.08 }
+ my $loadavg ;
+
+ if ( ! defined $file ) {
+ eval {
+ $loadavg = `/usr/sbin/sysctl vm.loadavg` ;
+ #myprint( "LOADAVG DARWIN: $loadavg\n" ) ;
+ } ;
+ if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; }
+ }else{
+ $loadavg = firstline( $file ) or return ;
+ }
+
+ my ( $avg_1_min, $avg_5_min, $avg_15_min )
+ = $loadavg =~ /vm\.loadavg\s*[:=]\s*\{?\s*(\d+\.?\d*)\s+(\d+\.?\d*)\s+(\d+\.?\d*)/mxs ;
+ $debug and print "System load: $avg_1_min $avg_5_min $avg_15_min\n" ;
+ return ( $avg_1_min, $avg_5_min, $avg_15_min ) ;
+}
+
+sub loadavg_windows {
+ my $file = shift ;
+ # Example of output of command "wmic cpu get loadpercentage":
+ # LoadPercentage
+ # 12
+ my $loadavg ;
+
+ if ( ! defined $file ) {
+ eval {
+ #$loadavg = `CMD wmic cpu get loadpercentage` ;
+ $loadavg = "LoadPercentage\n0\n" ;
+ #myprint( "LOADAVG WIN: $loadavg\n" ) ;
+ } ;
+ if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; }
+ }else{
+ $loadavg = file_to_string( $file ) or return ;
+ #myprint( "$loadavg" ) ;
+ }
+ $loadavg =~ /LoadPercentage\n(\d+)/xms ;
+ my $num = $1 ;
+ $num /= 100 ;
+
+ $debug and myprint( "System load: $num\n" ) ;
+ return ( $num ) ;
+}
+
+
+
+
+
+
+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( 0, load_and_delay( 1, 1, 1, 1 ), 'load_and_delay: one core, loads are all 1 => 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 ' ) ;
+
+ is( 0, load_and_delay( 1, 0, 0, 0 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ;
+ is( 0, load_and_delay( 1, 0, 0, 2 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ;
+ is( 0, load_and_delay( 1, 0, 2, 0 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ;
+ is( 0, load_and_delay( 1, 0, 2, 2 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ;
+ is( 1, load_and_delay( 1, 2, 0, 0 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=0 => 1 ' ) ;
+ is( 1, load_and_delay( 1, 2, 0, 2 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=2 => 1 ' ) ;
+ is( 5, load_and_delay( 1, 2, 2, 0 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=0 => 5 ' ) ;
+ is( 15, load_and_delay( 1, 2, 2, 2 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=2 => 15 ' ) ;
+
+ is( 0, load_and_delay( 4, 0, 2, 2 ), 'load_and_delay: four core, load1m=0 load5m=2 load15m=2 => 0 ' ) ;
+ is( 1, load_and_delay( 4, 8, 0, 0 ), 'load_and_delay: four core, load1m=2 load5m=0 load15m=0 => 1 ' ) ;
+ is( 1, load_and_delay( 4, 8, 0, 2 ), 'load_and_delay: four core, load1m=2 load5m=0 load15m=2 => 1 ' ) ;
+ is( 5, load_and_delay( 4, 8, 8, 0 ), 'load_and_delay: four core, load1m=2 load5m=2 load15m=0 => 5 ' ) ;
+ is( 15, load_and_delay( 4, 8, 8, 8 ), 'load_and_delay: four core, load1m=2 load5m=2 load15m=2 => 15 ' ) ;
+ is( 15, load_and_delay( 4, 8, 8, 8, 'lalala' ), 'load_and_delay: five arguments is ok' ) ;
+
+ note( 'Leaving tests_load_and_delay()' ) ;
+ return ;
+}
+
+sub load_and_delay {
+ # Basically return 0 if load is not heavy, ie <= 1 per processor
+
+ if ( 4 > scalar @ARG ) { return ; }
+
+ my ( $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) = @ARG ;
+
+ if ( 0 == $cpu_num ) { return ; }
+
+ # 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 <= 1 ) { return 0 ; }
+ if ( $avg_5_min <= 1 ) { return 1 ; } # Retry in 1 minute
+ if ( $avg_15_min <= 1 ) { return 5 ; } # Retry in 5 minutes
+ return 15 ; # Retry in 15 minutes
}
+sub memory_available {
+ # / ( 1000 ** 3 )
+ return(
+ sprintf( "%.1f GiB", Sys::MemInfo::get("totalmem") / ( 1024 ** 3 ) )
+ ) ;
+}
sub memory_consumption {
- # memory consumed by imapsync until now in bytes
- return( ( memory_consumption_of_pids( ) )[0] );
+ # memory consumed by imapsync until now in bytes
+ return( ( memory_consumption_of_pids( ) )[0] );
}
sub tests_memory_consumption {
+ note( 'Entering tests_memory_consumption()' ) ;
- like( memory_consumption( ), qr{\d+},'memory_consumption no args') ;
- like( memory_consumption( 1 ), qr{\d+},'memory_consumption 1') ;
- like( memory_consumption( $PROCESS_ID ), qr{\d+},"memory_consumption_of_pids $PROCESS_ID") ;
+ 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+}, 'memory_consumption_ratio' ) ;
- like( memory_consumption_ratio(1), qr{\d+}, 'memory_consumption_ratio 1' ) ;
- like( memory_consumption_ratio(10), qr{\d+}, 'memory_consumption_ratio 10' ) ;
+ 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' ) ;
- like( memory_consumption(), qr{\d+}, "memory_consumption\n" ) ;
- return ;
+ like( memory_consumption(), qr{\d+}xms, "memory_consumption\n" ) ;
+
+ note( 'Leaving tests_memory_consumption()' ) ;
+ return ;
}
sub memory_consumption_of_pids {
- my @pid = @_;
- @pid = (@pid) ? @pid : ($PROCESS_ID) ;
+ my @pid = @_;
+ @pid = (@pid) ? @pid : ($PROCESS_ID) ;
- #myprint( "PIDs: @pid\n" ) ;
- my @val;
- if ('MSWin32' eq $OSNAME) {
- @val = memory_consumption_of_pids_win32(@pid);
- }else{
- # Unix
- my @ps = qx{ ps -o vsz -p @pid } ;
+ #myprint( "PIDs: @pid\n" ) ;
+ my @val;
+ if ('MSWin32' eq $OSNAME) {
+ @val = memory_consumption_of_pids_win32(@pid);
+ }else{
+ # Unix
+ my @ps = qx{ ps -o vsz -p @pid } ;
#myprint( @ps ) ;
#my @ps = backtick( "ps -o vsz -p @pid" ) ;
- shift @ps; # First line is column name "VSZ"
- chomp @ps;
- # convert to octets
-
- @val = map { $_ * $KIBI } @ps;
- }
- return( @val ) ;
+ shift @ps; # First line is column name "VSZ"
+ chomp @ps;
+ # convert to octets
+
+ @val = map { $_ * $KIBI } @ps;
+ }
+ return( @val ) ;
}
sub memory_consumption_of_pids_win32 {
- # Windows
- my @PID = @_;
- my %PID;
- # hash of pids as key values
- map { $PID{$_}++ } @PID;
+ # Windows
+ my @PID = @_;
+ my %PID;
+ # hash of pids as key values
+ map { $PID{$_}++ } @PID;
- # Does not work but should reading the tasklist documentation
- #@ps = qx{ tasklist /FI "PID eq @PID" };
+ # Does not work but should reading the tasklist documentation
+ #@ps = qx{ tasklist /FI "PID eq @PID" };
- my @ps = qx{ tasklist /NH /FO CSV } ;
+ my @ps = qx{ tasklist /NH /FO CSV } ;
#my @ps = backtick( 'tasklist /NH /FO CSV' ) ;
- #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];
- next if (! $pid);
- #myprint( "[$name][$pid][$mem]" ) ;
- if ($PID{remove_qq($pid)}) {
- #myprint( "MATCH !\n" ) ;
- chomp $mem ;
- $mem = remove_qq($mem);
- $mem = remove_Ko($mem);
- $mem = remove_not_num($mem);
- #myprint( "[$mem]\n" ) ;
- push @val, $mem * $KIBI;
- }
- }
- return(@val);
+ #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];
+ next if (! $pid);
+ #myprint( "[$name][$pid][$mem]" ) ;
+ if ($PID{remove_qq($pid)}) {
+ #myprint( "MATCH !\n" ) ;
+ chomp $mem ;
+ $mem = remove_qq($mem);
+ $mem = remove_Ko($mem);
+ $mem = remove_not_num($mem);
+ #myprint( "[$mem]\n" ) ;
+ push @val, $mem * $KIBI;
+ }
+ }
+ return(@val);
}
sub backtick {
- my $command = shift ;
- my ( $writer, $reader, $err ) ;
+ my $command = shift ;
+
+ if ( ! $command ) { return ; }
+
+ my ( $writer, $reader, $err ) ;
my @output ;
- open3( $writer, $reader, $err, $command ) ;
- @output = <$reader>; #Output here
+ my $pid ;
+ eval {
+ $pid = open3( $writer, $reader, $err, $command ) ;
+ } ;
+
+ if ( ! $pid ) { return ; }
+ waitpid( $pid, 0 ) ;
+ @output = <$reader>; # Output here
+ #
#my @errors = <$err>; #Errors here, instead of the console
+ if ( not @output ) { return ; }
$debugdev and myprint( @output ) ;
- return( @output ) ;
+ if ( $output[0] =~ /\Qopen3: exec of $command failed\E/mxs ) { return ; }
+ if ( wantarray ) {
+ return( @output ) ;
+ } else {
+ return( join( q{}, @output) ) ;
+ }
}
sub tests_backtick {
+ note( 'Entering tests_backtick()' ) ;
+
+ is( undef, backtick( ), 'backtick: no args' ) ;
+ is( undef, backtick( q{} ), 'backtick: empty command' ) ;
SKIP: {
- skip( 'Tests for MSWin32', 3 ) if ('MSWin32' ne $OSNAME) ;
- my @output ;
- @output = backtick( 'echo Hello World!' ) ;
- # Add \r on Windows.
- ok( "Hello World!\r\n" eq $output[0], 'backtick: echo Hello World!' ) ;
- $debug and myprint( "[@output]" ) ;
- @output = backtick( 'echo Hello & echo World!' ) ;
- ok( "Hello \r\n" eq $output[0], 'backtick: echo Hello & echo World!' ) ;
- ok( "World!\r\n" eq $output[1], 'backtick: echo Hello & echo World!' ) ;
- $debug and myprint( "[@output][$output[0]][$output[1]]" ) ;
+ skip( 'test for MSWin32', 5 ) if ('MSWin32' ne $OSNAME) ;
+ my @output ;
+ @output = backtick( 'echo Hello World!' ) ;
+ # Add \r on Windows.
+ ok( "Hello World!\r\n" eq $output[0], 'backtick: echo Hello World!' ) ;
+ $debug and myprint( "[@output]" ) ;
+ @output = backtick( 'echo Hello & echo World!' ) ;
+ ok( "Hello \r\n" eq $output[0], 'backtick: echo Hello & echo World! line 1' ) ;
+ ok( "World!\r\n" eq $output[1], 'backtick: echo Hello & echo World! line 2' ) ;
+ $debug and myprint( "[@output][$output[0]][$output[1]]" ) ;
+ # Scalar context
+ ok( "Hello World!\r\n" eq backtick( 'echo Hello World!' ),
+ 'backtick: echo Hello World! scalar' ) ;
+ ok( "Hello \r\nWorld!\r\n" eq backtick( 'echo Hello & echo World!' ),
+ 'backtick: echo Hello & echo World! scalar 2 lines' ) ;
} ;
- SKIP: {
- skip( 'Tests for Unix', 3 ) if ('MSWin32' eq $OSNAME) ;
- my @output ;
- @output = backtick( 'echo Hello World!' ) ;
- ok( "Hello World!\n" eq $output[0], 'backtick: echo Hello World!' ) ;
- $debug and myprint( "[@output]" ) ;
- @output = backtick( "echo Hello\necho World!" ) ;
- ok( "Hello\n" eq $output[0], 'backtick: echo Hello; echo World!' ) ;
- ok( "World!\n" eq $output[1], 'backtick: echo Hello; echo World!' ) ;
- $debug and myprint( "[@output]" ) ;
- }
+ SKIP: {
+ skip( 'test for Unix', 7 ) if ('MSWin32' eq $OSNAME) ;
+ is( undef, backtick( 'aaaarrrg' ), 'backtick: aaaarrrg command not found' ) ;
+ # Array context
+ my @output ;
+ @output = backtick( 'echo Hello World!' ) ;
+ ok( "Hello World!\n" eq $output[0], 'backtick: echo Hello World!' ) ;
+ $debug and myprint( "[@output]" ) ;
+ @output = backtick( "echo Hello\necho World!" ) ;
+ ok( "Hello\n" eq $output[0], 'backtick: echo Hello; echo World! line 1' ) ;
+ ok( "World!\n" eq $output[1], 'backtick: echo Hello; echo World! line 2' ) ;
+ $debug and myprint( "[@output]" ) ;
+ # Scalar context
+ ok( "Hello World!\n" eq backtick( 'echo Hello World!' ),
+ 'backtick: echo Hello World! scalar' ) ;
+ ok( "Hello\nWorld!\n" eq backtick( "echo Hello\necho World!" ),
+ 'backtick: echo Hello; echo World! scalar 2 lines' ) ;
+ # Return error positive value, that's ok
+ is( undef, backtick( 'false' ), 'backtick: false returns no output' ) ;
+ }
+
+ note( 'Leaving tests_backtick()' ) ;
return ;
}
sub remove_not_num {
- my $string = shift;
- $string =~ tr/0-9//cd;
- #myprint( "tr [$string]\n" ) ;
- return($string);
+ my $string = shift ;
+ $string =~ tr/0-9//cd ;
+ #myprint( "tr [$string]\n" ) ;
+ return( $string ) ;
}
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' )} ) ;
- return ;
+ 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' )} ) ;
+
+ note( 'Leaving tests_remove_not_num()' ) ;
+ return ;
}
sub remove_Ko {
- my $string = shift;
- if ($string =~ /^(.*)\sKo$/xo) {
- return($1);
- }else{
- return($string);
- }
+ my $string = shift;
+ if ($string =~ /^(.*)\sKo$/xo) {
+ return($1);
+ }else{
+ return($string);
+ }
}
sub remove_qq {
- my $string = shift;
- if ($string =~ /^"(.*)"$/xo) {
- return($1);
- }else{
- return($string);
- }
+ 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);
+ my ($base) = @_;
+ $base ||= 1;
+ my $consu = memory_consumption();
+ return($consu / $base);
}
sub date_from_rcs {
- my $d = shift ;
+ my $d = shift ;
- 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 ) ;
+ 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 ) {
# Handles the following format
# 2015/07/10 11:05:59 -- Generated by RCS Date tag.
- #myprint( "$d\n" ) ;
+ #myprint( "$d\n" ) ;
#myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ;
my ($year, $month, $day, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6) ;
$month = $num2mon{$month} ;
$d = "$day-$month-$year $hour:$min:$sec +0000" ;
- #myprint( "$d\n" ) ;
- }
- return( $d ) ;
+ #myprint( "$d\n" ) ;
+ }
+ return( $d ) ;
}
sub tests_date_from_rcs {
- ok('19-Sep-2015 16:11:07 +0000'
- eq date_from_rcs('Date: 2015/09/19 16:11:07 '), 'date_from_rcs from RCS date' ) ;
- return ;
+ note( 'Entering tests_date_from_rcs()' ) ;
+
+ ok('19-Sep-2015 16:11:07 +0000'
+ eq date_from_rcs('Date: 2015/09/19 16:11:07 '), 'date_from_rcs from RCS date' ) ;
+
+ note( 'Leaving tests_date_from_rcs()' ) ;
+ return ;
}
sub good_date {
# two incoming formats:
# header Tue, 24 Aug 2010 16:00:00 +0200
- # internal 24-Aug-2010 16:00:00 +0200
+ # internal 24-Aug-2010 16:00:00 +0200
# outgoing format: internal date format
# 24-Aug-2010 16:00:00 +0200
@@ -7853,18 +9474,18 @@ sub good_date {
my $d = shift ;
return(q{}) if not defined $d;
- SWITCH: {
- if ( $d =~ m{(\d?)(\d-...-\d{4})(\s\d{2}:\d{2}:\d{2})(\s(?:\+|-)\d{4})?}xo ) {
- #myprint( "internal: [$1][$2][$3][$4]\n" ) ;
- my ($day_1, $date_rest, $hour, $zone) = ($1,$2,$3,$4) ;
- $day_1 = '0' if ($day_1 eq q{}) ;
- $zone = ' +0000' if not defined $zone ;
- $d = $day_1 . $date_rest . $hour . $zone ;
+ SWITCH: {
+ if ( $d =~ m{(\d?)(\d-...-\d{4})(\s\d{2}:\d{2}:\d{2})(\s(?:\+|-)\d{4})?}xo ) {
+ #myprint( "internal: [$1][$2][$3][$4]\n" ) ;
+ my ($day_1, $date_rest, $hour, $zone) = ($1,$2,$3,$4) ;
+ $day_1 = '0' if ($day_1 eq q{}) ;
+ $zone = ' +0000' if not defined $zone ;
+ $d = $day_1 . $date_rest . $hour . $zone ;
last SWITCH ;
}
- if ($d =~ m{(?:\w{3,},\s)?(\d{1,2}),?\s+(\w{3,})\s+(\d{2,4})\s+(\d{1,2})(?::|\.)(\d{1,2})(?:(?::|\.)(\d{1,2}))?\s*((?:\+|-)\d{4})?}xo ) {
- # Handles any combination of following formats
+ if ($d =~ m{(?:\w{3,},\s)?(\d{1,2}),?\s+(\w{3,})\s+(\d{2,4})\s+(\d{1,2})(?::|\.)(\d{1,2})(?:(?::|\.)(\d{1,2}))?\s*((?:\+|-)\d{4})?}xo ) {
+ # Handles any combination of following formats
# Tue, 24 Aug 2010 16:00:00 +0200 -- Standard
# 24 Aug 2010 16:00:00 +0200 -- Missing Day of Week
# Tue, 24 Aug 97 16:00:00 +0200 -- Two digit year
@@ -7886,11 +9507,11 @@ sub good_date {
$sec = mysprintf( '%02d', $sec ) ;
$zone = '+0000' if not defined $zone ;
$d = "$day-$month-$year $hour:$min:$sec $zone" ;
- last SWITCH ;
- }
+ last SWITCH ;
+ }
- if ($d =~ m{(?:.{3})\s(...)\s+(\d{1,2})\s(\d{1,2}):(\d{1,2}):(\d{1,2})\s(?:\w{3})?\s?(\d{4})}xo ) {
- # Handles any combination of following formats
+ if ($d =~ m{(?:.{3})\s(...)\s+(\d{1,2})\s(\d{1,2}):(\d{1,2}):(\d{1,2})\s(?:\w{3})?\s?(\d{4})}xo ) {
+ # Handles any combination of following formats
# Sun Aug 20 11:55:09 2006
# Wed Jan 24 11:58:38 MST 2007
# Wed Jan 2 08:40:57 2008
@@ -7902,21 +9523,21 @@ sub good_date {
$min = mysprintf( '%02d', $min ) ;
$sec = mysprintf( '%02d', $sec ) ;
$d = "$day-$month-$year $hour:$min:$sec +0000" ;
- last SWITCH ;
- }
+ last SWITCH ;
+ }
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 ) {
# Handles the following format
# 2015/07/10 11:05:59 -- Generated by RCS Date tag.
- #myprint( "$d\n" ) ;
+ #myprint( "$d\n" ) ;
#myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ;
my ($year, $month, $day, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6) ;
$month = $num2mon{$month} ;
$d = "$day-$month-$year $hour:$min:$sec +0000" ;
- #myprint( "$d\n" ) ;
- last SWITCH ;
- }
+ #myprint( "$d\n" ) ;
+ last SWITCH ;
+ }
if ($d =~ m{(\d{2})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) {
# Handles the following format
@@ -7927,11 +9548,11 @@ sub good_date {
$year = '20' . $year;
$month = $num2mon{$month};
$d = "$day-$month-$year $hour:$min:$sec +0000";
- last SWITCH ;
- }
+ last SWITCH ;
+ }
- if ($d =~ m{\w{6,},\s(\w{3})\w+\s+(\d{1,2}),\s(\d{4})\s(\d{2}):(\d{2})\s(AM|PM)}xo ) {
- # Handles the following format
+ if ($d =~ m{\w{6,},\s(\w{3})\w+\s+(\d{1,2}),\s(\d{4})\s(\d{2}):(\d{2})\s(AM|PM)}xo ) {
+ # Handles the following format
# Saturday, December 14, 2002 05:00 PM - KBtoys.com order confirmations
my ($month, $day, $year, $hour, $min, $apm) = ($1,$2,$3,$4,$5,$6);
@@ -7940,10 +9561,10 @@ sub good_date {
$day = mysprintf( '%02d', $day ) ;
$d = "$day-$month-$year $hour:$min:00 +0000" ;
last SWITCH ;
- }
+ }
- if ($d =~ m{(\w{3})\s(\d{1,2})\s(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-)\d{4})}xo ) {
- # Handles the following format
+ if ($d =~ m{(\w{3})\s(\d{1,2})\s(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-)\d{4})}xo ) {
+ # Handles the following format
# Saturday, December 14, 2002 05:00 PM - jr.com order confirmations
my ($month, $day, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7);
@@ -7951,20 +9572,20 @@ sub good_date {
$day = mysprintf( '%02d', $day ) ;
$d = "$day-$month-$year $hour:$min:$sec $zone";
last SWITCH ;
- }
+ }
- if ($d =~ m{(\d{1,2})-(\w{3})-(\d{4})}xo ) {
- # Handles the following format
+ if ($d =~ m{(\d{1,2})-(\w{3})-(\d{4})}xo ) {
+ # Handles the following format
# 21-Jun-2001 - register.com domain transfer email circa 2001
my ($day, $month, $year) = ($1,$2,$3);
$day = mysprintf( '%02d', $day);
$d = "$day-$month-$year 11:11:11 +0000";
- last SWITCH ;
- }
+ last SWITCH ;
+ }
- # unknown or unmatch => return same string
- return($d);
+ # unknown or unmatch => return same string
+ return($d);
}
$d = qq("$d") ;
@@ -7973,15 +9594,16 @@ sub good_date {
sub tests_good_date {
-
- ok(q{} eq good_date(), 'good_date no arg');
- ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24-Aug-2010 16:00:00 +0200'), 'good_date internal 2digit zone');
- ok('"24-Aug-2010 16:00:00 +0000"' eq good_date('24-Aug-2010 16:00:00'), 'good_date internal 2digit no zone');
- ok('"01-Sep-2010 16:00:00 +0200"' eq good_date( '1-Sep-2010 16:00:00 +0200'), 'good_date internal SP 1digit');
- ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('Tue, 24 Aug 2010 16:00:00 +0200'), 'good_date header 2digit zone');
- ok('"01-Sep-2010 16:00:00 +0000"' eq good_date('Wed, 1 Sep 2010 16:00:00'), 'good_date header SP 1digit zone');
- ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200'), 'good_date header SP 1digit zone');
- ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200 (CEST)'), 'good_date header SP 1digit zone');
+ note( 'Entering tests_good_date()' ) ;
+
+ ok(q{} eq good_date(), 'good_date no arg');
+ ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24-Aug-2010 16:00:00 +0200'), 'good_date internal 2digit zone');
+ ok('"24-Aug-2010 16:00:00 +0000"' eq good_date('24-Aug-2010 16:00:00'), 'good_date internal 2digit no zone');
+ ok('"01-Sep-2010 16:00:00 +0200"' eq good_date( '1-Sep-2010 16:00:00 +0200'), 'good_date internal SP 1digit');
+ ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('Tue, 24 Aug 2010 16:00:00 +0200'), 'good_date header 2digit zone');
+ ok('"01-Sep-2010 16:00:00 +0000"' eq good_date('Wed, 1 Sep 2010 16:00:00'), 'good_date header SP 1digit zone');
+ ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200'), 'good_date header SP 1digit zone');
+ ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200 (CEST)'), 'good_date header SP 1digit zone');
ok('"06-Feb-2009 22:18:08 +0000"' eq good_date('02/06/09 22:18:08'), 'good_date header TemPageR');
ok('"02-Jan-2008 08:40:57 +0000"' eq good_date('Wed Jan 2 08:40:57 2008'), 'good_date header dice.com support 1digit day');
ok('"20-Aug-2006 11:55:09 +0000"' eq good_date('Sun Aug 20 11:55:09 2006'), 'good_date header dice.com support 2digit day');
@@ -8002,104 +9624,220 @@ sub tests_good_date {
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('"19-Sep-2015 16:11:07 +0000"' eq good_date('Date: 2015/09/19 16:11:07 '), 'good_date from RCS date' ) ;
- return ;
+ 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()' ) ;
+ return ;
+}
+
+
+sub tests_list_keys_in_2_not_in_1 {
+ note( 'Entering tests_list_keys_in_2_not_in_1()' ) ;
+
+
+ my @list;
+ ok( ! list_keys_in_2_not_in_1( {}, {}), 'list_keys_in_2_not_in_1: {} {}');
+ ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {}, {} ) ] ), 'list_keys_in_2_not_in_1: {} {}');
+ ok( 0 == compare_lists( ['a','b'], [ list_keys_in_2_not_in_1( {}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {} {a, b}');
+ ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a} {a, b}');
+ ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b} {a, b}');
+ ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}');
+ ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}');
+
+ note( 'Leaving tests_list_keys_in_2_not_in_1()' ) ;
+ return ;
+}
+
+sub list_keys_in_2_not_in_1 {
+
+ my $folders1_ref = shift;
+ my $folders2_ref = shift;
+ my @list;
+
+ foreach my $folder ( sort keys %{ $folders2_ref } ) {
+ next if exists $folders1_ref->{$folder};
+ push @list, $folder;
+ }
+ return(@list);
+}
+
+
+sub list_folders_in_2_not_in_1 {
+
+ my (@h2_folders_not_in_h1, %h2_folders_not_in_h1) ;
+ @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h1_folders_all, \%h2_folders_all) ;
+ map { $h2_folders_not_in_h1{$_} = 1} @h2_folders_not_in_h1 ;
+ @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h2_folders_from_1_all, \%h2_folders_not_in_h1) ;
+
+ return( reverse @h2_folders_not_in_h1 );
}
-sub tests_list_keys_in_2_not_in_1 {
+sub tests_match {
+ note( 'Entering tests_match()' ) ;
+
+ # undef serie
+ is( undef, match( ), 'match: no args => undef' ) ;
+ is( undef, match( 'lalala' ), 'match: one args => undef' ) ;
+
+ # This one gives 0 under a binary made by pp
+ # but 1 under "normal" Perl interpreter. So a PAR bug?
+ #is( 1, match( q{}, q{} ), 'match: q{} =~ q{} => 1' ) ;
+
+ is( 1, match( 'lalala', 'lalala' ), 'match: lalala =~ lalala => 1' ) ;
+ is( 1, match( 'lalala', '^lalala' ), 'match: lalala =~ ^lalala => 1' ) ;
+ is( 1, match( 'lalala', 'lalala$' ), 'match: lalala =~ lalala$ => 1' ) ;
+ is( 1, match( 'lalala', '^lalala$' ), 'match: lalala =~ ^lalala$ => 1' ) ;
+ is( 1, match( '_lalala_', 'lalala' ), 'match: _lalala_ =~ lalala => 1' ) ;
+ is( 1, match( 'lalala', '.*' ), 'match: lalala =~ .* => 1' ) ;
+ is( 1, match( 'lalala', '.' ), 'match: lalala =~ . => 1' ) ;
+ is( 1, match( '/lalala/', '/lalala/' ), 'match: /lalala/ =~ /lalala/ => 1' ) ;
+
+
+ is( 0, match( 'lalala', 'ooo' ), 'match: lalala =~ ooo => 0' ) ;
+ is( 0, match( 'lalala', 'lal_ala' ), 'match: lalala =~ lal_ala => 0' ) ;
+ is( 0, match( 'lalala', '\.' ), 'match: lalala =~ \. => 0' ) ;
+ is( 0, match( 'lalalaX', '^lalala$' ), 'match: lalalaX =~ ^lalala$ => 0' ) ;
+ is( 0, match( 'lalala', '/lalala/' ), 'match: lalala =~ /lalala/ => 1' ) ;
+
+ is( 1, match( 'LALALA', '(?i:lalala)' ), 'match: LALALA =~ (?i:lalala) => 1' ) ;
+
+ is( undef, match( 'LALALA', '(?{`ls /`})' ), 'match: LALALA =~ (?{`ls /`}) => undef' ) ;
+ is( undef, match( 'LALALA', '(?{print "CACA"})' ), 'match: LALALA =~ (?{print "CACA"}) => undef' ) ;
+ is( undef, match( 'CACA', '(??{print "CACA"})' ), 'match: CACA =~ (??{print "CACA"}) => undef' ) ;
- my @list;
- ok( ! list_keys_in_2_not_in_1( {}, {}), 'list_keys_in_2_not_in_1: {} {}');
- ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {}, {} ) ] ), 'list_keys_in_2_not_in_1: {} {}');
- ok( 0 == compare_lists( ['a','b'], [ list_keys_in_2_not_in_1( {}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {} {a, b}');
- ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a} {a, b}');
- ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b} {a, b}');
- ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}');
- ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}');
+ note( 'Leaving tests_match()' ) ;
return ;
}
-sub list_keys_in_2_not_in_1 {
+sub match {
+ my( $var, $regex ) = @ARG ;
- my $folders1_ref = shift;
- my $folders2_ref = shift;
- my @list;
+ # undef cases
+ if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; }
- foreach my $folder ( sort keys %{ $folders2_ref } ) {
- next if exists $folders1_ref->{$folder};
- push @list, $folder;
+ # normal cases
+ if ( eval { $var =~ $regex } ) {
+ return 1 ;
+ }elsif ( $EVAL_ERROR ) {
+ print "Fatal regex $regex\n" ;
+ return ;
+ } else {
+ return 0 ;
}
- return(@list);
+ return ;
}
-sub list_folders_in_2_not_in_1 {
+sub tests_notmatch {
+ note( 'Entering tests_notmatch()' ) ;
+
+ # undef serie
+ is( undef, notmatch( ), 'notmatch: no args => undef' ) ;
+ is( undef, notmatch( 'lalala' ), 'notmatch: one args => undef' ) ;
- my (@h2_folders_not_in_h1, %h2_folders_not_in_h1) ;
- @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h1_folders_all, \%h2_folders_all) ;
- map { $h2_folders_not_in_h1{$_} = 1} @h2_folders_not_in_h1 ;
- @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h2_folders_from_1_all, \%h2_folders_not_in_h1) ;
+ is( 1, notmatch( 'lalala', '/lalala/' ), 'notmatch: lalala !~ /lalala/ => 1' ) ;
+ is( 0, notmatch( '/lalala/', '/lalala/' ), 'notmatch: /lalala/ !~ /lalala/ => 0' ) ;
+ is( 1, notmatch( 'lalala', '/ooo/' ), 'notmatch: lalala !~ /ooo/ => 1' ) ;
- return( reverse @h2_folders_not_in_h1 );
+ # This one gives 1 under a binary made by pp
+ # but 0 under "normal" Perl interpreter. So a PAR bug, same in tests_match .
+ #is( 0, notmatch( q{}, q{} ), 'notmatch: q{} !~ q{} => 0' ) ;
+
+ is( 0, notmatch( 'lalala', 'lalala' ), 'notmatch: lalala !~ lalala => 0' ) ;
+ is( 0, notmatch( 'lalala', '^lalala' ), 'notmatch: lalala !~ ^lalala => 0' ) ;
+ is( 0, notmatch( 'lalala', 'lalala$' ), 'notmatch: lalala !~ lalala$ => 0' ) ;
+ is( 0, notmatch( 'lalala', '^lalala$' ), 'notmatch: lalala !~ ^lalala$ => 0' ) ;
+ is( 0, notmatch( '_lalala_', 'lalala' ), 'notmatch: _lalala_ !~ lalala => 0' ) ;
+ is( 0, notmatch( 'lalala', '.*' ), 'notmatch: lalala !~ .* => 0' ) ;
+ is( 0, notmatch( 'lalala', '.' ), 'notmatch: lalala !~ . => 0' ) ;
+
+
+ is( 1, notmatch( 'lalala', 'ooo' ), 'notmatch: does not match regex => 1' ) ;
+ is( 1, notmatch( 'lalala', 'lal_ala' ), 'notmatch: does not match regex => 1' ) ;
+ is( 1, notmatch( 'lalala', '\.' ), 'notmatch: matches regex => 0' ) ;
+ is( 1, notmatch( 'lalalaX', '^lalala$' ), 'notmatch: does not match regex => 1' ) ;
+
+ note( 'Leaving tests_notmatch()' ) ;
+
+ return ;
}
-sub delete_folders_in_2_not_in_1 {
+sub notmatch {
+ my( $var, $regex ) = @ARG ;
- 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 ;
- }
- if ( defined $delete2foldersbutnot and eval "\$folder =~ $delete2foldersbutnot" ) {
- myprint( "Not deleting $folder because of --delete2foldersbutnot $delete2foldersbutnot\n" ) ;
- next ;
- }
- my $res = $dry ; # always success in dry mode!
- $imap2->unsubscribe( $folder ) if ( ! $dry ) ;
- $res = $imap2->delete( $folder ) if ( ! $dry ) ;
- if ( $res ) {
- myprint( "Deleted $folder", "$dry_message", "\n" ) ;
- }else{
- myprint( "Deleting $folder failed", "\n" ) ;
- }
+ # undef cases
+ if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; }
+
+ # normal cases
+ if ( eval { $var !~ $regex } ) {
+ return 1 ;
+ }elsif ( $EVAL_ERROR ) {
+ print "Fatal regex $regex\n" ;
+ return ;
+ }else{
+ return 0 ;
}
return ;
}
+
+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 ;
+ }
+ 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!
+ $imap2->unsubscribe( $folder ) if ( ! $sync->{dry} ) ;
+ $res = $imap2->delete( $folder ) if ( ! $sync->{dry} ) ;
+ if ( $res ) {
+ myprint( "Deleted $folder", "$sync->{dry_message}", "\n" ) ;
+ }else{
+ myprint( "Deleting $folder failed", "\n" ) ;
+ }
+ }
+ return ;
+}
+
sub delete_folder {
- my ( $sync, $imap, $folder, $Side ) = @_ ;
- if ( ! $sync ) { return ; }
+ my ( $mysync, $imap, $folder, $Side ) = @_ ;
+ if ( ! $mysync ) { return ; }
if ( ! $imap ) { return ; }
if ( ! $folder ) { return ; }
$Side ||= 'HostX' ;
-
- my $res = $sync->{dry} ; # always success in dry mode!
- if ( ! $sync->{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", $sync->{dry_message}, "\n" ) ;
+ myprint( "$Side deleted $folder", $mysync->{dry_message}, "\n" ) ;
return 1 ;
}else{
- myprint( "$Side deleting $folder failed", "\n" ) ;
+ myprint( "$Side deleting $folder failed", "\n" ) ;
return ;
}
}
sub delete1emptyfolders {
- my $sync = shift ;
- if ( ! $sync ) { return ; } # abort if no parameter
- if ( ! $sync->{delete1emptyfolders} ) { return ; } # abort if --delete1emptyfolders off
- my $imap = $sync->{imap1} ;
+ my $mysync = shift ;
+ if ( ! $mysync ) { return ; } # abort if no parameter
+ 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 diesconnected
-
+
my %folders_kept ;
myprint( qq{Host1 deleting empty folders\n} ) ;
- foreach my $folder ( reverse sort @{ $sync->{h1_folders_wanted} } ) {
+ foreach my $folder ( reverse sort @{ $mysync->{h1_folders_wanted} } ) {
my $parenthood = $imap->is_parent( $folder ) ;
if ( defined $parenthood and $parenthood ) {
myprint( "Host1 folder $folder has subfolders\n" ) ;
@@ -8123,42 +9861,42 @@ sub delete1emptyfolders {
if ( uc $folder eq 'INBOX' ) {
myprint( "Host1 Not deleting $folder\n" ) ;
$folders_kept{ $folder }++ ;
- next ;
+ next ;
}
myprint( "Host1 deleting empty folder $folder\n" ) ;
# 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( $sync, $imap, $folder, 'Host1' ) ) {
+ $imap->close( ) ; # close after examine does not expunge; anyway expunging an empty folder...
+ if ( delete_folder( $mysync, $imap, $folder, 'Host1' ) ) {
next ; # Deleted, good!
}else{
$folders_kept{ $folder }++ ;
next ; # Not deleted, bad!
}
}
- remove_deleted_folders_from_wanted_list( $sync, %folders_kept ) ;
+ 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 {
- my ( $sync, %folders_kept ) = @ARG ;
-
- my @h1_folders_wanted_init = @{ $sync->{h1_folders_wanted} } ;
+ my ( $mysync, %folders_kept ) = @ARG ;
+
+ my @h1_folders_wanted_init = @{ $mysync->{h1_folders_wanted} } ;
my @h1_folders_wanted_last ;
foreach my $folder ( @h1_folders_wanted_init ) {
if ( $folders_kept{ $folder } ) {
push @h1_folders_wanted_last, $folder ;
}
}
- @{ $sync->{h1_folders_wanted} } = @h1_folders_wanted_last ;
+ @{ $mysync->{h1_folders_wanted} } = @h1_folders_wanted_last ;
return ;
}
sub examine_folder_and_count {
my ( $imap, $folder, $Side ) = @_ ;
$Side ||= 'HostX' ;
-
+
if ( ! examine_folder( $imap, $folder, $Side ) ) {
return ;
}
@@ -8168,6 +9906,8 @@ sub examine_folder_and_count {
sub tests_delete1emptyfolders {
+ note( 'Entering tests_delete1emptyfolders()' ) ;
+
is( undef, delete1emptyfolders( ), q{delete1emptyfolders: undef} ) ;
my $syncT ;
@@ -8175,7 +9915,7 @@ sub tests_delete1emptyfolders {
my $imapT ;
$syncT->{imap1} = $imapT ;
is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef imap} ) ;
-
+
require Test::MockObject ;
$imapT = Test::MockObject->new( ) ;
$syncT->{imap1} = $imapT ;
@@ -8186,7 +9926,7 @@ sub tests_delete1emptyfolders {
# Now connected tests
$imapT->set_false( 'IsUnconnected' ) ;
$imapT->mock( 'LastError', sub { q{LastError mocked} } ) ;
-
+
$syncT->{delete1emptyfolders} = 0 ;
tests_delete1emptyfolders_unit(
$syncT,
@@ -8207,7 +9947,7 @@ sub tests_delete1emptyfolders {
# No parents but examine false for all => skip all
$imapT->set_false( 'is_parent', 'examine' ) ;
-
+
tests_delete1emptyfolders_unit(
$syncT,
[ qw{ INBOX DELME1 DELME2 } ],
@@ -8267,26 +10007,28 @@ sub tests_delete1emptyfolders {
q{tests_delete1emptyfolders: 0 EXISTS 0 by messages() delete folders, keep INBOX}
) ;
-
-
-
+ note( 'Leaving tests_delete1emptyfolders()' ) ;
return ;
}
sub tests_delete1emptyfolders_unit {
+ note( 'Entering tests_delete1emptyfolders_unit()' ) ;
+
my $syncT = shift ;
my $folders1wanted_init_ref = shift ;
my $folders1wanted_after_ref = shift ;
my $comment = shift || q{delete1emptyfolders:} ;
-
+
my @folders1wanted_init = @{ $folders1wanted_init_ref } ;
my @folders1wanted_after = @{ $folders1wanted_after_ref } ;
@{ $syncT->{h1_folders_wanted} } = @folders1wanted_init ;
-
+
is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_init, qq{$comment, init check} ) ;
delete1emptyfolders( $syncT ) ;
is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_after, qq{$comment, after check} ) ;
+
+ note( 'Leaving tests_delete1emptyfolders_unit()' ) ;
return ;
}
@@ -8300,6 +10042,8 @@ sub extract_header {
}
sub tests_extract_header {
+ note( 'Entering tests_extract_header()' ) ;
+
my $h = <<'EOM';
@@ -8321,7 +10065,8 @@ EOM
- return ;
+ note( 'Leaving tests_extract_header()' ) ;
+ return ;
}
sub decompose_header{
@@ -8361,6 +10106,8 @@ sub decompose_header{
sub tests_decompose_header{
+ note( 'Entering tests_decompose_header()' ) ;
+
my $header_dec ;
@@ -8373,7 +10120,7 @@ KEY_2: VAL_2
KEY_3: VAL_3
KEY_1: VAL_1_other
KEY_4: VAL_4
- VAL_4_+
+ VAL_4_+
KEY_5 BLANC: VAL_5
KEY_6_BAD_BODY: VAL_6
@@ -8462,12 +10209,32 @@ EOH
ok( 'VAL_2 VAL_2_+ VAL_2_++'
eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: Bad header VAL_2 VAL_2_+ VAL_2_++' ) ;
- return ;
+ note( 'Leaving tests_decompose_header()' ) ;
+ return ;
+}
+
+sub tests_epoch {
+ note( 'Entering tests_epoch()' ) ;
+
+ ok( '1282658400' eq epoch( '24-Aug-2010 16:00:00 +0200' ), 'epoch 24-Aug-2010 16:00:00 +0200 -> 1282658400' ) ;
+ ok( '1282658400' eq epoch( '24-Aug-2010 14:00:00 +0000' ), 'epoch 24-Aug-2010 14:00:00 +0000 -> 1282658400' ) ;
+ ok( '1282658400' eq epoch( '24-Aug-2010 12:00:00 -0200' ), 'epoch 24-Aug-2010 12:00:00 -0200 -> 1282658400' ) ;
+ ok( '1282658400' eq epoch( '24-Aug-2010 16:01:00 +0201' ), 'epoch 24-Aug-2010 16:01:00 +0201 -> 1282658400' ) ;
+ ok( '1282658400' eq epoch( '24-Aug-2010 14:01:00 +0001' ), 'epoch 24-Aug-2010 14:01:00 +0001 -> 1282658400' ) ;
+
+ ok( '1280671200' eq epoch( '1-Aug-2010 16:00:00 +0200' ), 'epoch 1-Aug-2010 16:00:00 +0200 -> 1280671200' ) ;
+ ok( '1280671200' eq epoch( '1-Aug-2010 14:00:00 +0000' ), 'epoch 1-Aug-2010 14:00:00 +0000 -> 1280671200' ) ;
+ ok( '1280671200' eq epoch( '1-Aug-2010 12:00:00 -0200' ), 'epoch 1-Aug-2010 12:00:00 -0200 -> 1280671200' ) ;
+ ok( '1280671200' eq epoch( '1-Aug-2010 16:01:00 +0201' ), 'epoch 1-Aug-2010 16:01:00 +0201 -> 1280671200' ) ;
+ ok( '1280671200' eq epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ;
+
+ note( 'Leaving tests_epoch()' ) ;
+ return ;
}
sub epoch {
# incoming format:
- # internal date 24-Aug-2010 16:00:00 +0200
+ # internal date 24-Aug-2010 16:00:00 +0200
# outgoing format: epoch
@@ -8495,522 +10262,898 @@ sub epoch {
return( $time ) ;
}
-sub tests_epoch {
- ok( '1282658400' eq epoch( '24-Aug-2010 16:00:00 +0200' ), 'epoch 24-Aug-2010 16:00:00 +0200 -> 1282658400' ) ;
- ok( '1282658400' eq epoch( '24-Aug-2010 14:00:00 +0000' ), 'epoch 24-Aug-2010 14:00:00 +0000 -> 1282658400' ) ;
- ok( '1282658400' eq epoch( '24-Aug-2010 12:00:00 -0200' ), 'epoch 24-Aug-2010 12:00:00 -0200 -> 1282658400' ) ;
- ok( '1282658400' eq epoch( '24-Aug-2010 16:01:00 +0201' ), 'epoch 24-Aug-2010 16:01:00 +0201 -> 1282658400' ) ;
- ok( '1282658400' eq epoch( '24-Aug-2010 14:01:00 +0001' ), 'epoch 24-Aug-2010 14:01:00 +0001 -> 1282658400' ) ;
+sub tests_add_header {
+ note( 'Entering tests_add_header()' ) ;
- ok( '1280671200' eq epoch( '1-Aug-2010 16:00:00 +0200' ), 'epoch 1-Aug-2010 16:00:00 +0200 -> 1280671200' ) ;
- ok( '1280671200' eq epoch( '1-Aug-2010 14:00:00 +0000' ), 'epoch 1-Aug-2010 14:00:00 +0000 -> 1280671200' ) ;
- ok( '1280671200' eq epoch( '1-Aug-2010 12:00:00 -0200' ), 'epoch 1-Aug-2010 12:00:00 -0200 -> 1280671200' ) ;
- ok( '1280671200' eq epoch( '1-Aug-2010 16:01:00 +0201' ), 'epoch 1-Aug-2010 16:01:00 +0201 -> 1280671200' ) ;
- ok( '1280671200' eq epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ;
- return ;
+ ok( 'Message-Id: <mistake@imapsync>' eq add_header(), 'add_header no arg' ) ;
+ ok( 'Message-Id: <123456789@imapsync>' eq add_header( '123456789' ), 'add_header 123456789' ) ;
+
+ note( 'Leaving tests_add_header()' ) ;
+ return ;
}
sub add_header {
- my $header_uid = shift || 'mistake' ;
- my $header_Message_Id = 'Message-Id: <' . $header_uid . '@imapsync>' ;
+ my $header_uid = shift || 'mistake' ;
+ my $header_Message_Id = 'Message-Id: <' . $header_uid . '@imapsync>' ;
return( $header_Message_Id ) ;
}
-sub tests_add_header {
- ok( 'Message-Id: <mistake@imapsync>' eq add_header(), 'add_header no arg' ) ;
- ok( 'Message-Id: <123456789@imapsync>' eq add_header(123456789), 'add_header 123456789' ) ;
- return ;
-}
-sub tests_Banner{
- my $imap = Mail::IMAPClient->new( ) ;
- ok( 'lalala' eq $imap->Banner('lalala'), 'Banner set lalala' ) ;
- ok( 'lalala' eq $imap->Banner(), 'Banner returns lalala' ) ;
- return ;
+sub tests_max_line_length {
+ note( 'Entering tests_max_line_length()' ) ;
+
+ ok( 0 == max_line_length( q{} ), 'max_line_length: 0 == null string' ) ;
+ ok( 1 == max_line_length( "\n" ), 'max_line_length: 1 == \n' ) ;
+ ok( 1 == max_line_length( "\n\n" ), 'max_line_length: 1 == \n\n' ) ;
+ ok( 1 == max_line_length( "\n" x 500 ), 'max_line_length: 1 == 500 \n' ) ;
+ ok( 1 == max_line_length( 'a' ), 'max_line_length: 1 == a' ) ;
+ ok( 2 == max_line_length( "a\na" ), 'max_line_length: 2 == a\na' ) ;
+ ok( 2 == max_line_length( "a\na\n" ), 'max_line_length: 2 == a\na\n' ) ;
+ ok( 3 == max_line_length( "a\nab\n" ), 'max_line_length: 3 == a\nab\n' ) ;
+ ok( 3 == max_line_length( "a\nab\n" x 10_000 ), 'max_line_length: 3 == 10_000 a\nab\n' ) ;
+ ok( 3 == max_line_length( "a\nab\nabc" ), 'max_line_length: 3 == a\nab\nabc' ) ;
+
+ ok( 4 == max_line_length( "a\nab\nabc\n" ), 'max_line_length: 4 == a\nab\nabc\n' ) ;
+ ok( 5 == max_line_length( "a\nabcd\nabc\n" ), 'max_line_length: 5 == a\nabcd\nabc\n' ) ;
+ ok( 5 == max_line_length( "a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd" ), 'max_line_length: 5 == a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd' ) ;
+
+ note( 'Leaving tests_max_line_length()' ) ;
+ return ;
}
-
-
-
sub max_line_length {
- my $string = shift ;
+ my $string = shift ;
my $max = 0 ;
while ( $string =~ m/([^\n]*\n?)/msxg ) {
- $max = max( $max, length $1 ) ;
+ $max = max( $max, length $1 ) ;
}
- return( $max ) ;
+ return( $max ) ;
}
-sub tests_max_line_length {
- ok( 0 == max_line_length( q{} ), 'max_line_length: 0 == null string' ) ;
- ok( 1 == max_line_length( "\n" ), 'max_line_length: 1 == \n' ) ;
- ok( 1 == max_line_length( "\n\n" ), 'max_line_length: 1 == \n\n' ) ;
- ok( 1 == max_line_length( "\n" x 500 ), 'max_line_length: 1 == 500 \n' ) ;
- ok( 1 == max_line_length( 'a' ), 'max_line_length: 1 == a' ) ;
- ok( 2 == max_line_length( "a\na" ), 'max_line_length: 2 == a\na' ) ;
- ok( 2 == max_line_length( "a\na\n" ), 'max_line_length: 2 == a\na\n' ) ;
- ok( 3 == max_line_length( "a\nab\n" ), 'max_line_length: 3 == a\nab\n' ) ;
- ok( 3 == max_line_length( "a\nab\n" x 10000 ), 'max_line_length: 3 == 10000 a\nab\n' ) ;
- ok( 3 == max_line_length( "a\nab\nabc" ), 'max_line_length: 3 == a\nab\nabc' ) ;
-
- ok( 4 == max_line_length( "a\nab\nabc\n" ), 'max_line_length: 4 == a\nab\nabc\n' ) ;
- ok( 5 == max_line_length( "a\nabcd\nabc\n" ), 'max_line_length: 5 == a\nabcd\nabc\n' ) ;
- ok( 5 == max_line_length( "a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd" ), 'max_line_length: 5 == a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd' ) ;
+
+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' ) ;
+
+ SKIP: {
+ skip( 'Too hard to have a well known timezone on Windows', 6 ) if ( 'MSWin32' eq $OSNAME ) ;
+
+ local $ENV{TZ} = 'GMT' ;
+
+ $mysync = {
+ timestart => 2,
+ } ;
+
+ is( 'LOG_imapsync/1970_01_01_00_00_02_000__.txt', setlogfile( $mysync ),
+ 'setlogfile: default is like LOG_imapsync/1970_01_01_00_00_02_000__.txt' ) ;
+
+ $mysync = {
+ timestart => 2,
+ user1 => 'user1',
+ user2 => 'user2',
+ } ;
+
+ is( 'LOG_imapsync/1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ),
+ 'setlogfile: default is like LOG_imapsync/1970_01_01_00_00_02_000_user1_user2.txt' ) ;
+
+ $mysync->{logdir} = undef ;
+ $mysync->{logfile} = undef ;
+ is( 'LOG_imapsync/1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ),
+ 'setlogfile: logdir undef, LOG_imapsync/1970_01_01_00_00_02_000_user1_user2.txt' ) ;
+
+ $mysync->{logdir} = q{} ;
+ $mysync->{logfile} = undef ;
+ is( '1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ),
+ 'setlogfile: logdir empty, 1970_01_01_00_00_02_000_user1_user2.txt' ) ;
+
+ $mysync->{logdir} = 'vallogdir' ;
+ $mysync->{logfile} = undef ;
+ is( 'vallogdir/1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ),
+ 'setlogfile: logdir vallogdir, vallogdir/1970_01_01_00_00_02_000_user1_user2.txt' ) ;
+
+ $mysync = {
+ user1 => 'us/er1a*|?:"<>b',
+ user2 => 'u/ser2a*|?:"<>b',
+ } ;
+
+ is( 'LOG_imapsync/1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt', setlogfile( $mysync ),
+ 'setlogfile: logdir undef, LOG_imapsync/1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt' ) ;
+
+
+ } ;
+
+ note( 'Leaving tests_setlogfile()' ) ;
+ return ;
+}
+
+
+sub tests_move_slash {
+ note( 'Entering tests_move_slash()' ) ;
+
+ is( undef, move_slash( ), 'move_slash: no parameters => undef' ) ;
+ is( '_', move_slash( '/' ), 'move_slash: / => _' ) ;
+ is( '_abc_def_', move_slash( '/abc/def/' ), 'move_slash: /abc/def/ => _abc_def_' ) ;
+ note( 'Leaving tests_move_slash()' ) ;
return ;
}
+sub move_slash {
+ my $string = shift ;
+
+ if ( ! defined $string ) { return ; }
+
+ $string =~ tr{/}{_} ;
+
+ return( $string ) ;
+}
+
sub setlogfile {
my( $mysync ) = shift ;
+ my $suffix = ( filter_forbidden_characters( move_slash( $mysync->{user1} ) ) || q{} )
+ . '_' .
+ ( filter_forbidden_characters( move_slash( $mysync->{user2} ) ) || q{} ) ;
+
$mysync->{logdir} = defined $mysync->{logdir} ? $mysync->{logdir} : 'LOG_imapsync' ;
$mysync->{logfile} = defined $mysync->{logfile} ? "$mysync->{logdir}/$mysync->{logfile}" :
- logfile( $mysync->{timestart}, $mysync->{user2}, $mysync->{logdir} ) ;
+ logfile( $mysync->{timestart}, $suffix, $mysync->{logdir} ) ;
#myprint( "logdir = $mysync->{logdir}\n" ) ;
#myprint( "logfile = $mysync->{logfile}\n" ) ;
return( $mysync->{logfile} ) ;
}
-sub tests_setlogfile {
- my $mysync = {
- timestart => 2,
- user2 => 'user2',
+
+sub tests_logfile {
+ note( 'Entering tests_logfile()' ) ;
+
+ SKIP: {
+ # Too hard to have a well known timezone on Windows
+ skip( 'Too hard to have a well known timezone on Windows', 8 ) if ( 'MSWin32' eq $OSNAME ) ;
+
+ 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' ) ;
+ }
+ POSIX::tzset unless ('MSWin32' eq $OSNAME) ;
} ;
- ok( 'LOG_imapsync/1970_01_01_01_00_02_user2.txt' eq setlogfile( $mysync ),
- 'setlogfile: default is like LOG_imapsync/1970_01_01_01_00_02_user2.txt' ) ;
+ note( 'Leaving tests_logfile()' ) ;
+ return ;
+}
- $mysync->{logdir} = undef ;
- $mysync->{logfile} = undef ;
- ok( 'LOG_imapsync/1970_01_01_01_00_02_user2.txt' eq setlogfile( $mysync ),
- 'setlogfile: logdir undef, LOG_imapsync/1970_01_01_01_00_02_user2.txt' ) ;
- $mysync->{logdir} = q{} ;
- $mysync->{logfile} = undef ;
- ok( '1970_01_01_01_00_02_user2.txt' eq setlogfile( $mysync ),
- 'setlogfile: logdir empty, 1970_01_01_01_00_02_user2.txt' ) ;
- $mysync->{logdir} = 'vallogdir' ;
- $mysync->{logfile} = undef ;
- ok( 'vallogdir/1970_01_01_01_00_02_user2.txt' eq setlogfile( $mysync ),
- 'setlogfile: logdir vallogdir, vallogdir/1970_01_01_01_00_02_user2.txt' ) ;
+sub logfile {
+ my ( $time, $suffix, $dir ) = @_ ;
- $mysync->{logdir} = 'vallogdir' ;
- $mysync->{logfile} = 'vallogfile.txt' ;
- ok( 'vallogdir/vallogfile.txt' eq setlogfile( $mysync ),
- 'setlogfile: logdir vallogdir, logfile vallogfile.txt, vallogdir/vallogfile.txt' ) ;
+ $time ||= 0 ;
+ $suffix ||= q{} ;
+ $suffix =~ tr/ //ds ;
+ my $sep_suffix = ( $suffix ) ? '_' : q{} ;
+ $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 access, more than one sync withing one second is possible
+ # so we add millisecons
+ $date_str .= sprintf "_%03d", ($time - int( $time ) ) * 1000 ; # without rounding
+ my $logfile = "${dir}${sep_dir}${date_str}${sep_suffix}${suffix}.txt" ;
+ $debug and myprint( "date_str: $date_str\n" ) ;
+ $debug and myprint( "logfile : $logfile\n" ) ;
+ return( $logfile ) ;
+}
+
+
+
+sub tests_million_folders_baby_2 {
+ note( 'Entering tests_million_folders_baby_2()' ) ;
+
+ my %long ;
+ @long{ 1 .. 900_000 } = (1) x 900_000 ;
+ #myprint( %long, "\n" ) ;
+ my $pasglop = 0 ;
+ foreach my $elem ( 1 .. 900_000 ) {
+ #$debug and myprint( "$elem " ) ;
+ if ( not exists $long{ $elem } ) {
+ $pasglop++ ;
+ }
+ }
+ ok( 0 == $pasglop, 'tests_million_folders_baby_2: search among 900_000' ) ;
+ # myprint( "$pasglop\n" ) ;
+
+ note( 'Leaving tests_million_folders_baby_2()' ) ;
+ return ;
+}
+
+
+
+sub tests_always_fail {
+ note( 'Entering tests_always_fail()' ) ;
+
+ is( 0, 1, 'always_fail: 0 is 1' ) ;
+
+ note( 'Leaving tests_always_fail()' ) ;
+ return ;
+}
+
+sub logfileprepa {
+ my $logfile = shift ;
+
+ my $dirname = dirname( $logfile ) ;
+ do_valid_directory( $dirname ) || return( 0 ) ;
+ return( 1 ) ;
+}
+
+sub teelaunch {
+ my $mysync = shift ;
+ my $logfile = $mysync->{logfile} ;
+ logfileprepa( $logfile ) || croak "Error no valid directory to write log file $logfile : $OS_ERROR" ;
+
+ open my $logfile_handle, '>', $logfile
+ or croak( "Can not open $logfile for write: $OS_ERROR" ) ;
+ my $tee = IO::Tee->new( $logfile_handle, \*STDOUT ) ;
+ *STDERR = *$tee{IO} ;
+ select $tee ;
+ $tee->autoflush( 1 ) ;
+ $mysync->{logfile_handle} = $logfile_handle ;
+ $mysync->{tee} = $tee ;
+ return $logfile_handle ;
+}
+
+sub getpwuid_any_os {
+ my $uid = shift ;
+
+ return( scalar getlogin ) if ( 'MSWin32' eq $OSNAME ) ; # Windows system
+ return( scalar getpwuid $uid ) ; # Unix system
+
+
+}
+
+sub simulong {
+ my $max_seconds = shift ;
+ my $division = 5 ;
+ my $last = $division * $max_seconds ;
+ foreach my $i ( 1 .. ( $last ) ) {
+ myprint( "Are you still here $i/$last\n" ) ;
+ #myprint( "Are you still here $i/$last\n" . ( "Ah" x 40 . "\n") x 4000 ) ;
+ sleep( 1 / $division ) ;
+ }
+
+ return ;
+}
+
+
+
+sub printenv {
+ myprint( "Environment variables listing:\n",
+ ( map { "$_ => $ENV{$_}\n" } sort keys %ENV),
+ "Environment variables listing end\n" ) ;
+ return ;
+}
+
+sub testsexit {
+ my $mysync = shift ;
+ if ( ! ( $mysync->{ tests } or $mysync->{ testsdebug } or $mysync->{ testsunit } ) ) {
+ return ;
+ }
+ my $test_builder = Test::More->builder ;
+ tests( $mysync ) ;
+ testsdebug( $mysync ) ;
+ testunitsession( $mysync ) ;
+
+ my @summary = $test_builder->summary() ;
+ my @details = $test_builder->details() ;
+ my $nb_tests_run = scalar( @summary ) ;
+ my $nb_tests_expected = $test_builder->expected_tests() ;
+ my $nb_tests_failed = count_0s( @summary ) ;
+ my $tests_failed = report_failures( @details ) ;
+ if ( $nb_tests_failed or ( $nb_tests_run != $nb_tests_expected ) ) {
+ #$test_builder->reset( ) ;
+ myprint( "Summary of tests: failed $nb_tests_failed tests, run $nb_tests_run tests, expected to run $nb_tests_expected tests.\n",
+ "List of failed tests:\n", $tests_failed ) ;
+ exit $EXIT_TESTS_FAILED ;
+ }
+ exit ;
+ #return ;
+}
+
+sub after_get_options {
+ my $numopt = shift ;
+
+
+ # exit with --help option or no option at all
+ $debug and myprint( "numopt:$numopt\n" ) ;
+ myprint( usage( $sync ) ) and exit if ( $help or not $numopt ) ;
+
+ return ;
+}
+
+sub easyany {
+ my $mysync = shift ;
+
+ # Gmail
+ if ( $mysync->{gmail1} and $mysync->{gmail2} ) {
+ $debug and myprint( "gmail1 gmail2\n") ;
+ gmail12( $mysync ) ;
+ return ;
+ }
+ if ( $mysync->{gmail1} ) {
+ $debug and myprint( "gmail1\n" ) ;
+ gmail1( $mysync ) ;
+ }
+ if ( $mysync->{gmail2} ) {
+ $debug and myprint( "gmail2\n" ) ;
+ gmail2( $mysync ) ;
+ }
+ # Office 365
+ if ( $mysync->{office1} ) {
+ office1( $mysync ) ;
+ }
- return ;
-}
+ if ( $mysync->{office2} ) {
+ office2( $mysync ) ;
+ }
+ # Domino
+ if ( $mysync->{domino1} ) {
+ domino1( $mysync ) ;
+ }
-sub logfile {
- my ( $time, $suffix, $dir ) = @_ ;
+ if ( $mysync->{domino2} ) {
+ domino2( $mysync ) ;
+ }
- $time ||= 0 ;
- $suffix ||= q{} ;
- my $sep_suffix = ( $suffix ) ? '_' : q{} ;
- $dir ||= q{} ;
- my $sep_dir = ( $dir ) ? '/' : q{} ;
- my $date_str = POSIX::strftime( '%Y_%m_%d_%H_%M_%S', localtime $time ) ;
- my $logfile = "${dir}${sep_dir}${date_str}${sep_suffix}${suffix}.txt" ;
- $debug and myprint( "date_str: $date_str\n" ) ;
- $debug and myprint( "logfile : $logfile\n" ) ;
- return( $logfile ) ;
+ return ;
}
-sub tests_logfile {
- SKIP: {
- # Too hard to have a well known timezone on Windows
- skip( 'Too hard to have a well known timezone on Windows', 6 ) if ( 'MSWin32' eq $OSNAME ) ;
-
- local $ENV{TZ} = 'GMT' ;
- { POSIX::tzset unless ('MSWin32' eq $OSNAME) ;
- ok( '1970_01_01_00_00_00.txt' eq logfile( ), 'logfile: no args => 1970_01_01_00_00_00.txt' ) ;
- ok( '1970_01_01_00_00_00.txt' eq logfile( 0 ), 'logfile: 0 => 1970_01_01_00_00_00.txt' ) ;
- ok( '1970_01_01_00_01_01.txt' eq logfile( 61 ), 'logfile: 0 => 1970_01_01_00_01_01.txt' ) ;
- ok( '2010_08_24_14_00_00.txt' eq logfile( 1282658400 ), 'logfile: 1282658400 => 2010_08_24_14_00_00.txt' ) ;
- ok( '2010_08_24_14_01_01.txt' eq logfile( 1282658461 ), 'logfile: 1282658461 => 2010_08_24_14_01_01.txt' ) ;
- ok( '2010_08_24_14_01_01_poupinette.txt' eq logfile( 1282658461, 'poupinette' ), 'logfile: 1282658461 poupinette => 2010_08_24_14_01_01_poupinette.txt' ) ;
- }
- POSIX::tzset unless ('MSWin32' eq $OSNAME) ;
- } ;
+# From https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt
+sub gmail12 {
+ my $mysync = shift ;
+ # 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 10_000 computed from by Gmail documentation
+ $mysync->{maxbytesafter} ||= 1_000_000_000 ;
+ $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ;
+ $mysync->{maxsleep} = $MAX_SLEEP ;
+
+ push @exclude, '\[Gmail\]$' ;
return ;
}
+sub gmail1 {
+ my $mysync = shift ;
+ # Gmail at host2
+ $mysync->{host1} ||= 'imap.gmail.com' ;
+ $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ;
+ $mysync->{maxbytespersecond} ||= 40_000 ; # should be 20_000 computed from by Gmail documentation
+ $mysync->{maxbytesafter} ||= 2_500_000_000 ;
+ $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ;
+ $skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 1 ;
+ $mysync->{maxsleep} = $MAX_SLEEP ;
+
+ push @useheader, 'X-Gmail-Received', 'Message-Id' ;
+ push @regextrans2, 's,\[Gmail\].,,' ;
+ push @folderlast, '[Gmail]/All Mail' ;
+ return ;
+}
+sub gmail2 {
+ my $mysync = shift ;
+ # Gmail at host2
+ $mysync->{host2} ||= 'imap.gmail.com' ;
+ $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ;
+ $mysync->{maxbytespersecond} ||= 20_000 ; # should be 10_000 computed from by Gmail documentation
+ $mysync->{maxbytesafter} ||= 1_000_000_000 ; # In fact it is documented as half: 500_000_000
+ $maxsize ||= 25_000_000 ;
+ $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ;
+ $skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 1 ;
+ $expunge1 = ( defined $expunge1 ) ? $expunge1 : 1 ;
+ $addheader = ( defined $addheader ) ? $addheader : 1 ;
+ $mysync->{maxsleep} = $MAX_SLEEP ;
+
+ push @exclude, '\[Gmail\]$' ;
+ push @useheader, 'X-Gmail-Received', 'Message-Id' ;
+ push @regextrans2, 's,\[Gmail\].,,' ;
+ push @regextrans2, 's/[ ]+/_/g' ;
+ push @regextrans2, q{s/['\\^"]/_/g} ; # Verified this
+ push @folderlast, "[Gmail]/All Mail" ;
+ return ;
+}
+# From https://imapsync.lamiral.info/FAQ.d/FAQ.Exchange.txt
+sub office1 {
+ # Office 365 at host1
+ my $mysync = shift ;
+ $debug and myprint( "office1 configuration\n" ) ;
+ $mysync->{host1} ||= 'outlook.office365.com' ;
+ $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ;
+ return ;
+}
+sub office2 {
+ # Office 365 at host1
+ my $mysync = shift ;
+ $mysync->{host2} ||= 'outlook.office365.com' ;
+ $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ;
+ $maxsize ||= 45_000_000 ;
+ $mysync->{maxmessagespersecond} ||= 4 ;
+ push @regexflag, 's/\\Flagged//g' ;
+ $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ;
+ push @regexmess, 's,(.{10500}),$1\r\n,g' ;
+ return ;
+}
+sub exchange1 {
+ # Exchange 2010/2013 at host1
+ # Well nothing to do so far
+ return ;
+}
+sub exchange2 {
+ # Exchange 2010/2013 at host2
+ my $mysync = shift ;
+ $maxsize ||= 10_000_000 ;
+ $mysync->{maxmessagespersecond} ||= 4 ;
+ push @regexflag, 's/\\Flagged//g' ;
+ $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ;
+ push @regexmess, 's,(.{10500}),$1\r\n,g' ;
+ return ;
+}
+sub domino1 {
+ # Domino at host1
+ my $mysync = shift ;
-
-
-
-sub tests_million_folders_baby_2 {
- my %long ;
- @long{ 1 .. 900_000 } = (1) x 900_000 ;
- #myprint( %long, "\n" ) ;
- my $pasglop = 0 ;
- foreach my $elem ( 1 .. 900_000 ) {
- #$debug and myprint( "$elem " ) ;
- if ( not exists $long{ $elem } ) {
- $pasglop++ ;
- }
- }
- ok( 0 == $pasglop, 'tests_million_folders_baby_2: search among 900_000' ) ;
- # myprint( "$pasglop\n" ) ;
- return ;
+ $sep1 = q{\\} ;
+ $prefix1 = q{} ;
+ $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ;
+ return ;
}
+sub domino2 {
+ # Domino at host1
+ my $mysync = shift ;
-
-sub tests_always_fail {
- ok( 0 == 1, '0 == 1' ) ;
- ok( 1 == 1, '1 == 1' ) ;
- return ;
+ $sep2 = q{\\} ;
+ $prefix2 = q{} ;
+ $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ;
+ push @regextrans2, 's,^Inbox\\\\(.*),$1,i' ;
+ return ;
}
-sub logfileprepa {
- my $logfile = shift ;
- my $dirname = dirname( $logfile ) ;
- is_valid_directory( $dirname ) || return( 0 ) ;
- return( 1 ) ;
+sub tests_resolv {
+ note( 'Entering tests_resolv()' ) ;
+
+ # is( , resolv( ), 'resolv: => ' ) ;
+ is( undef, resolv( ), 'resolv: no args => undef' ) ;
+ is( undef, resolv( '' ), 'resolv: empty string => undef' ) ;
+ is( undef, resolv( 'hostnotexist' ), 'resolv: hostnotexist => undef' ) ;
+ is( '127.0.0.1', resolv( '127.0.0.1' ), 'resolv: 127.0.0.1 => 127.0.0.1' ) ;
+ is( '127.0.0.1', resolv( 'localhost' ), 'resolv: localhost => 127.0.0.1' ) ;
+ is( '5.135.158.182', resolv( 'imapsync.lamiral.info' ), 'resolv: imapsync.lamiral.info => 5.135.158.182' ) ;
+
+ # ip6-localhost ( in /etc/hosts )
+ is( '::1', resolv( 'ip6-localhost' ), 'resolv: ip6-localhost => ::1' ) ;
+ is( '::1', resolv( '::1' ), 'resolv: ::1 => ::1' ) ;
+ # ks2
+ is( '2001:41d0:8:d8b6::1', resolv( '2001:41d0:8:d8b6::1' ), 'resolv: 2001:41d0:8:d8b6::1 => 2001:41d0:8:d8b6::1' ) ;
+ is( '2001:41d0:8:d8b6::1', resolv( 'ks2ipv6.lamiral.info' ), 'resolv: ks2ipv6.lamiral.info => 2001:41d0:8:d8b6::1' ) ;
+ # ks3
+ is( '2001:41d0:8:bebd::1', resolv( '2001:41d0:8:bebd::1' ), 'resolv: 2001:41d0:8:bebd::1 => 2001:41d0:8:bebd::1' ) ;
+ is( '2001:41d0:8:bebd::1', resolv( 'ks3ipv6.lamiral.info' ), 'resolv: ks3ipv6.lamiral.info => 2001:41d0:8:bebd::1' ) ;
+
+
+ note( 'Leaving tests_resolv()' ) ;
+ return ;
}
-sub teelaunch {
- my $mysync = shift ;
- my $logfile = $mysync->{logfile} ;
- logfileprepa( $logfile ) || croak "Error no valid directory to write log file $logfile : $!" ;
- my $logfile_handle ;
- open $logfile_handle, '>', $logfile
- or croak( "Can not open $logfile for write: $!" ) ;
- my $tee = IO::Tee->new( $logfile_handle, \*STDOUT ) ;
- *STDERR = *$tee{IO} ;
- select $tee ;
- $tee->autoflush( 1 ) ;
- $mysync->{logfile_handle} = $logfile_handle ;
- $mysync->{tee} = $tee ;
- return $logfile_handle ;
-}
-sub getpwuid_any_os {
- my $uid = shift ;
- return( scalar getlogin ) if ( 'MSWin32' eq $OSNAME ) ; # Windows system
- return( scalar getpwuid $uid ) ; # Unix system
+sub resolv {
+ my $host = shift @ARG ;
+
+ if ( ! $host ) { return ; }
+ my $addr ;
+ if ( defined &Socket::getaddrinfo ) {
+ $addr = resolv_with_getaddrinfo( $host ) ;
+ return( $addr ) ;
+ }
+
+
+
+ my $iaddr = inet_aton( $host ) ;
+ if ( ! $iaddr ) { return ; }
+ $addr = inet_ntoa( $iaddr ) ;
+
+ return $addr ;
}
+sub resolv_with_getaddrinfo {
+ my $host = shift @ARG ;
+
+ if ( ! $host ) { return ; }
+ my ( $err, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ;
+ if ( $err ) {
+ myprint( "Cannot getaddrinfo of $host: $err\n" ) ;
+ return ;
+ }
-sub usage {
- my $localhost_info = localhost_info();
- my $thank = thank_author();
- my $imapsync_release = q{};
- $imapsync_release = check_last_release() if (not defined $releasecheck);
- my $escape_char = ( 'MSWin32' eq $OSNAME ) ? '^' : '\\';
- myprint( <<"EOF" ) ;
+ my @addr ;
+ while( my $ai = shift @res ) {
+ my ( $err, $ipaddr ) = Socket::getnameinfo( $ai->{addr}, Socket::NI_NUMERICHOST(), Socket::NIx_NOSERV() ) ;
+ if ( $err ) {
+ myprint( "Cannot getnameinfo of $host: $err\n" ) ;
+ return ;
+ }
+ $debug and myprint "$host => $ipaddr\n" ;
+ push @addr, $ipaddr ;
- usage: $0 [options]
+ my ( $err_r, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ;
+ $debug and myprint "$host => $ipaddr => $reverse\n" ;
+ }
+
+ return $addr[0] ;
+}
- Several options are mandatory.
- str means string
- int means integer
- reg means regular expression
- cmd means command
+sub tests_resolvrev {
+ note( 'Entering tests_resolvrev()' ) ;
+
+ # is( , resolvrev( ), 'resolvrev: => ' ) ;
+ is( undef, resolvrev( ), 'resolvrev: no args => undef' ) ;
+ is( undef, resolvrev( '' ), 'resolvrev: empty string => undef' ) ;
+ is( undef, resolvrev( 'hostnotexist' ), 'resolvrev: hostnotexist => undef' ) ;
+ is( 'localhost', resolvrev( '127.0.0.1' ), 'resolvrev: 127.0.0.1 => localhost' ) ;
+ is( 'localhost', resolvrev( 'localhost' ), 'resolvrev: localhost => localhost' ) ;
+ is( 'ks.lamiral.info', resolvrev( 'imapsync.lamiral.info' ), 'resolvrev: imapsync.lamiral.info => ks.lamiral.info' ) ;
+
+ # ip6-localhost ( in /etc/hosts )
+ is( 'ip6-localhost', resolvrev( 'ip6-localhost' ), 'resolvrev: ip6-localhost => ip6-localhost' ) ;
+ is( 'ip6-localhost', resolvrev( '::1' ), 'resolvrev: ::1 => ip6-localhost' ) ;
+ # ks2
+ is( 'ks2ipv6.lamiral.info', resolvrev( '2001:41d0:8:d8b6::1' ), 'resolvrev: 2001:41d0:8:d8b6::1 => ks2ipv6.lamiral.info' ) ;
+ is( 'ks2ipv6.lamiral.info', resolvrev( 'ks2ipv6.lamiral.info' ), 'resolvrev: ks2ipv6.lamiral.info => ks2ipv6.lamiral.info' ) ;
+ # ks3
+ is( 'ks3ipv6.lamiral.info', resolvrev( '2001:41d0:8:bebd::1' ), 'resolvrev: 2001:41d0:8:bebd::1 => ks3ipv6.lamiral.info' ) ;
+ is( 'ks3ipv6.lamiral.info', resolvrev( 'ks3ipv6.lamiral.info' ), 'resolvrev: ks3ipv6.lamiral.info => ks3ipv6.lamiral.info' ) ;
+
+
+ note( 'Leaving tests_resolvrev()' ) ;
+ return ;
+}
- --dry : Makes imapsync doing nothing, just print what would
- be done without --dry.
+sub resolvrev {
+ my $host = shift @ARG ;
+
+ if ( ! $host ) { return ; }
- --host1 str : Source or "from" imap server. Mandatory.
- --port1 int : Port to connect on host1. Default is 143, 993 if --ssl1
- --user1 str : User to login on host1. Mandatory.
- --showpasswords : Shows passwords on output instead of "MASKED".
- Useful to restart a complete run by just reading the log.
- --password1 str : Password for the user1.
- --host2 str : "destination" imap server. Mandatory.
- --port2 int : Port to connect on host2. Default is 143, 993 if --ssl2
- --user2 str : User to login on host2. Mandatory.
- --password2 str : Password for the user2.
+ if ( defined &Socket::getaddrinfo ) {
+ my $name = resolvrev_with_getaddrinfo( $host ) ;
+ return( $name ) ;
+ }
+
+ return ;
+}
- --passfile1 str : Password file for the user1. It must contain the
- password on the first line. This option avoids to show
- the password on the command line like --password1 does.
- --passfile2 str : Password file for the user2. Contains the password.
+sub resolvrev_with_getaddrinfo {
+ my $host = shift @ARG ;
+
+ if ( ! $host ) { return ; }
- --ssl1 : Use a SSL connection on host1.
- --ssl2 : Use a SSL connection on host2.
- --tls1 : Use a TLS connection on host1.
- --tls2 : Use a TLS connection on host2.
- --debugssl int : SSL debug mode from 0 to 4.
- --sslargs1 str : Pass any ssl parameter for host1 ssl or tls connection. Example:
- --sslargs1 SSL_verify_mode=1 --sslargs1 SSL_version=SSLv3
- 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
+ my ( $err, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ;
+ if ( $err ) {
+ myprint( "Cannot getaddrinfo of $host: $err\n" ) ;
+ return ;
+ }
- --timeout1 int : Connection timeout in seconds for host1.
- Default is 120 and 0 means no timeout at all.
- --timeout2 int : Connection timeout in seconds for host2.
- Default is 120 and 0 means no timeout at all.
+ my @name ;
+ while( my $ai = shift @res ) {
+ my ( $err, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ;
+ if ( $err ) {
+ myprint( "Cannot getnameinfo of $host: $err\n" ) ;
+ return ;
+ }
+ $debug and myprint "$host => $reverse\n" ;
+ push @name, $reverse ;
+ }
+
+ return $name[0] ;
+}
- --authmech1 str : Auth mechanism to use with host1:
- PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE.
- --authmech2 str : Auth mechanism to use with host2. See --authmech1
- --authuser1 str : User to auth with on host1 (admin user).
- Avoid using --authmech1 SOMETHING with --authuser1.
- --authuser2 str : User to auth with on host2 (admin user).
- --proxyauth1 : Use proxyauth on host1. Requires --authuser1.
- Required by Sun/iPlanet/Netscape IMAP servers to
- be able to use an administrative user.
- --proxyauth2 : Use proxyauth on host2. Requires --authuser2.
- --authmd51 : Use MD5 authentification for host1.
- --authmd52 : Use MD5 authentification for host2.
- --domain1 str : Domain on host1 (NTLM authentication).
- --domain2 str : Domain on host2 (NTLM authentication).
+sub tests_imapsping {
+ note( 'Entering tests_imapsping()' ) ;
+ is( undef, imapsping( ), 'imapsping: no args => undef' ) ;
+ is( undef, imapsping( 'hostnotexist' ), 'imapsping: hostnotexist => undef' ) ;
+ is( 1, imapsping( 'imapsync.lamiral.info' ), 'imapsping: imapsync.lamiral.info => 1' ) ;
+ is( 1, imapsping( 'ks2ipv6.lamiral.info' ), 'imapsping: ks2ipv6.lamiral.info => 1' ) ;
+ note( 'Leaving tests_imapsping()' ) ;
+ return ;
+}
- --folder str : Sync this folder.
- --folder str : and this one, etc.
- --folderrec str : Sync this folder recursively.
- --folderrec str : and this one, etc.
+sub imapsping {
+ my $host = shift ;
+ return tcpping( $host, $IMAP_SSL_PORT ) ;
+}
- --folderfirst str : Sync this folder first. --folderfirst "Work"
- --folderfirst str : then this one, etc.
- --folderlast str : Sync this folder last. --folderlast "[Gmail]/All Mail"
- --folderlast str : then this one, etc.
+sub tests_tcpping {
+ note( 'Entering tests_tcpping()' ) ;
- --nomixfolders : Do not merge folders when host1 is case sensitive
- while host2 is not (like Exchange). Only the first
- similar folder is synced (ex: Sent SENT sent -> Sent).
+ is( undef, tcpping( ), 'tcpping: no args => undef' ) ;
+ is( undef, tcpping( 'hostnotexist' ), 'tcpping: one arg => undef' ) ;
+ is( undef, tcpping( undef, 888 ), 'tcpping: arg undef, port => undef' ) ;
+ is( undef, tcpping( 'hostnotexist', 993 ), 'tcpping: hostnotexist 993 => undef' ) ;
+ is( undef, tcpping( 'hostnotexist', 888 ), 'tcpping: hostnotexist 888 => undef' ) ;
+ is( 1, tcpping( 'imapsync.lamiral.info', 993 ), 'tcpping: imapsync.lamiral.info 993 => 1' ) ;
+ is( 0, tcpping( 'imapsync.lamiral.info', 888 ), 'tcpping: imapsync.lamiral.info 888 => 0' ) ;
+ is( 1, tcpping( '5.135.158.182', 993 ), 'tcpping: 5.135.158.182 993 => 1' ) ;
+ is( 0, tcpping( '5.135.158.182', 888 ), 'tcpping: 5.135.158.182 888 => 0' ) ;
- --skipemptyfolders : Empty host1 folders are not created on host2.
+ # Net::Ping supports ipv6 only after release 1.50
+ # http://cpansearch.perl.org/src/RURBAN/Net-Ping-2.59/Changes
+ # Anyway I plan to avoid Net-Ping for that too long standing feature
+ # Net-Ping is integrated in Perl itself, who knows ipv6 for a long time
+ is( 1, tcpping( '2001:41d0:8:d8b6::1', 993 ), 'tcpping: 2001:41d0:8:d8b6::1 993 => 1' ) ;
+ is( 0, tcpping( '2001:41d0:8:d8b6::1', 888 ), 'tcpping: 2001:41d0:8:d8b6::1 888 => 0' ) ;
- --include reg : Sync folders matching this regular expression
- --include reg : or this one, etc.
- in case both --include --exclude options are
- use, include is done before.
- --exclude reg : Skips folders matching this regular expression
- Several folders to avoid:
- --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3.
- --exclude reg : or this one, etc.
+ note( 'Leaving tests_tcpping()' ) ;
+ return ;
+}
- --subfolder2 str : Move whole host1 folders hierarchy under this
- host2 folder str .
- It does it by adding two --regextrans2 options before
- all others. Add --debug to see what's really going on.
+sub tcpping {
+ if ( 2 != scalar( @ARG ) ) {
+ return ;
+ }
+ my ( $host, $port ) = @ARG ;
+ if ( ! $host ) { return ; }
+ if ( ! $port ) { return ; }
+
+ my $mytimeout = $TCP_PING_TIMEOUT ;
+ require Net::Ping ;
+ #my $p = Net::Ping->new( 'tcp' ) ;
+ my $p = Net::Ping->new( ) ;
+ $p->{port_num} = $port ;
+ $p->service_check( 1 ) ;
+ $p->hires( 1 ) ;
+ my ($ping_ok, $rtt, $ip ) = $p->ping( $host, $mytimeout ) ;
+ if ( ! defined $ping_ok ) { return ; }
+ my $rtt_approx = sprintf( "%.3f", $rtt ) ;
+ $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 ) {
+ return 1 ;
+ }else{
+ return 0 ;
+ }
+}
- --automap : guesses folders mapping, for folders like
- "Sent", "Junk", "Drafts", "All", "Archive", "Flagged".
- --f1f2 str1=str2 : Force folder str1 to be synced to str2,
- --f1f2 overrides --automap and --regextrans2.
- --regextrans2 reg : Apply the whole regex to each destination folders.
- --regextrans2 reg : and this one. etc.
- When you play with the --regextrans2 option, first
- add also the safe options --dry --justfolders
- Then, when happy, remove --dry, remove --justfolders.
- Have in mind that --regextrans2 is applied after prefix
- and separator inversion. For examples see
- http://imapsync.lamiral.info/FAQ.d/FAQ.Folders_Mapping.txt
+sub tests_sslcheck {
+ note( 'Entering tests_sslcheck()' ) ;
- --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
- it's often small and deleted at reboot.
- --tmpdir /var/tmp should be better.
- --pidfile str : The file where imapsync pid is written.
- --pidfilelocking : Abort if pidfile already exists. Usefull to avoid
- concurrent transfers on the same mailbox.
+ my $mysync ;
- --nolog : Turn off logging on file
- --logfile str : Change the default log filename (can be dirname/filename).
- --logdir str : Change the default log directory. Default is LOG_imapsync
+ is( undef, sslcheck( $mysync ), 'sslcheck: no sslcheck => undef' ) ;
- --prefix1 str : Remove prefix to all destination folders
- (usually INBOX. or INBOX/ or an empty string "")
- you have to use --prefix1 if host1 imap server
- does not have NAMESPACE capability, so imapsync
- suggests to use it. All other cases are bad.
- --prefix2 str : Add prefix to all host2 folders. See --prefix1
- --sep1 str : Host1 separator in case NAMESPACE is not supported.
- --sep2 str : Host2 separator in case NAMESPACE is not supported.
+ $mysync = {
+ sslcheck => 1,
+ } ;
- --skipmess reg : Skips messages maching the regex.
- Example: 'm/[\\x80-ff]/' # to avoid 8bits messages.
- --skipmess is applied before --regexmess
- --skipmess reg : or this one, etc.
+ is( 0, sslcheck( $mysync ), 'sslcheck: no host => 0' ) ;
- --pipemess cmd : Apply this cmd command to each message content
- before the copy.
- --pipemess cmd : and this one, etc.
+ $mysync = {
+ sslcheck => 1,
+ host1 => 'imapsync.lamiral.info',
+ tls1 => 1,
+ } ;
- --disarmreadreceipts : Disarms read receipts (host2 Exchange issue)
+ is( 0, sslcheck( $mysync ), 'sslcheck: tls1 => 0' ) ;
- --regexmess reg : Apply the whole regex to each message before transfer.
- Example: 's/\\000/ /g' # to replace null by space.
- --regexmess reg : and this one, etc.
+ $mysync = {
+ sslcheck => 1,
+ host1 => 'imapsync.lamiral.info',
+ } ;
- --regexflag reg : Apply the whole regex to each flags list.
- Example: 's/\"Junk"//g' # to remove "Junk" flag.
- --regexflag reg : and this one, etc.
- --delete : Deletes messages on host1 server after a successful
- transfer. Option --delete has the following behavior:
- it marks messages as deleted with the IMAP flag
- \\Deleted, then messages are really deleted with an
- EXPUNGE IMAP command.
+ is( 1, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info => 1' ) ;
+ is( 1, $mysync->{ssl1}, 'sslcheck: imapsync.lamiral.info => ssl1 1' ) ;
- --delete2 : Delete messages in host2 that are not in
- host1 server. Useful for backup or pre-sync.
- --delete2duplicates : Delete messages in host2 that are duplicates.
- Works only without --useuid since duplicates are
- detected with an header part of each message.
+ $mysync->{sslcheck} = 0 ;
+ is( undef, sslcheck( $mysync ), 'sslcheck: sslcheck off => undef' ) ;
- --delete2folders : Delete folders in host2 that are not in host1 server.
- For safety, first try it like this (it is safe):
- --delete2folders --dry --justfolders --nofoldersizes
- --delete2foldersonly reg : Deleted only folders matching regex.
- Example: --delete2foldersonly "/^Junk\$|^INBOX.Junk\$/"
- --delete2foldersbutnot reg : Do not delete folders matching regex.
- Example: --delete2foldersbutnot "/Tasks\$|Contacts\$|Foo\$/"
- --noexpunge : Do not expunge messages on host1.
- Expunge really deletes messages marked deleted.
- Expunge is made at the beginning, on host1 only.
- Newly transferred messages are also expunged if
- option --delete is given.
- No expunge is done on host2 account (unless --expunge2)
- --expunge1 : Expunge messages on host1 after messages transfer.
- --expunge2 : Expunge messages on host2 after messages transfer.
- --uidexpunge2 : uidexpunge messages on the host2 account
- that are not on the host1 account, requires --delete2
- --nomixfolders : Avoid merging folders that are considered different on
- host1 but the same on destination host2 because of
- case sensitivities and insensitivities.
+ note( 'Leaving tests_sslcheck()' ) ;
+ return ;
+}
- --syncinternaldates : Sets the internal dates on host2 same as host1.
- Turned on by default. Internal date is the date
- a message arrived on a host (mtime).
- --idatefromheader : Sets the internal dates on host2 same as the
- "Date:" headers.
+sub sslcheck {
+ my $mysync = shift ;
- --maxsize int : Skip messages larger (or equal) than int bytes
- --minsize int : Skip messages smaller (or equal) than int bytes
- --maxage int : Skip messages older than int days.
- final stats (skipped) don't count older messages
- see also --minage
- --minage int : Skip messages newer than int days.
- final stats (skipped) don't count newer messages
- You can do (+ are the messages selected):
- past|----maxage+++++++++++++++>now
- past|+++++++++++++++minage---->now
- past|----maxage+++++minage---->now (intersection)
- past|++++minage-----maxage++++>now (union)
+ if ( ! $mysync->{sslcheck} ) {
+ return ;
+ }
+ my $nb_on = 0 ;
+ $debug and myprint( "sslcheck\n" ) ;
+ if (
+ ( ! defined $mysync->{port1} )
+ and
+ ( ! defined $mysync->{tls1} )
+ and
+ ( ! defined $mysync->{ssl1} )
+ and
+ ( defined $mysync->{host1} )
+ and
+ ( 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" ) ;
+ $nb_on++ ;
+ }
- --search str : Selects only messages returned by this IMAP SEARCH
- command. Applied on both sides.
- --search1 str : Same as --search for selecting host1 messages only.
- --search2 str : Same as --search for selecting host2 messages only.
- --search CRIT equals --search1 CRIT --search2 CRIT
+ if (
+ ( ! defined $mysync->{port2} )
+ and
+ ( ! defined $mysync->{tls2} )
+ and
+ ( ! defined $mysync->{ssl2} )
+ and
+ ( defined $mysync->{host2} )
+ and
+ ( 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" ) ;
+ $nb_on++ ;
+ }
+ return $nb_on ;
+}
- --exitwhenover int : Stop syncing when total bytes transferred reached.
- Gmail per day allows
- 2500000000 = 2.5 GB downloaded from Gmail as host2
- 500000000 = 500 MB uploaded to Gmail as host1.
- --maxlinelength int : skip messages with a line length longer than int bytes.
- RFC 2822 says it must be no more than 1000 bytes.
+sub testslive {
+ 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' ;
+ return ;
+}
- --useheader str : Use this header to compare messages on both sides.
- Ex: Message-ID or Subject or Date.
- --useheader str and this one, etc.
+sub testslive6 {
+ my $mysync = shift ;
+ $mysync->{host1} = 'ks2ipv6.lamiral.info' ;
+ $mysync->{user1} = 'test1' ;
+ $mysync->{password1} = 'secret1' ;
+ $mysync->{host2} = 'ks2ipv6.lamiral.info' ;
+ $mysync->{user2} = 'test2' ;
+ $mysync->{password2} ='secret2' ;
+ return ;
+}
- --subscribed : Transfers subscribed folders.
- --subscribe : Subscribe to the folders transferred on the
- host2 that are subscribed on host1. On by default.
- --subscribeall : Subscribe to the folders transferred on the
- host2 even if they are not subscribed on host1.
- --nofoldersizes : Do not calculate the size of each folder in bytes
- and message counts. Default is to calculate them.
- --nofoldersizesatend: Do not calculate the size of each folder in bytes
- and message counts at the end. Default is on.
- --justfoldersizes : Exit after having printed the folder sizes.
+sub tests_backslash_caret {
+ note( 'Entering tests_backslash_caret()' ) ;
- --syncacls : Synchronises acls (Access Control Lists).
- --nosyncacls : Does not synchronize acls. This is the default.
- Acls in IMAP are not standardized, be careful.
+ is( "lalala", backslash_caret( "lalala" ), 'backslash_caret: lalala => lalala' ) ;
+ is( "lalala\n", backslash_caret( "lalala\n" ), 'backslash_caret: lalala => lalala 2nd' ) ;
+ is( '^', backslash_caret( '\\' ), 'backslash_caret: \\ => ^' ) ;
+ is( "^\n", backslash_caret( "\\\n" ), 'backslash_caret: \\ => ^' ) ;
+ is( "\\lalala", backslash_caret( "\\lalala" ), 'backslash_caret: \\lalala => \\lalala' ) ;
+ is( "\\lal\\ala", backslash_caret( "\\lal\\ala" ), 'backslash_caret: \\lal\\ala => \\lal\\ala' ) ;
+ is( "\\lalala\n", backslash_caret( "\\lalala\n" ), 'backslash_caret: \\lalala => \\lalala 2nd' ) ;
+ is( "lalala^\n", backslash_caret( "lalala\\\n" ), 'backslash_caret: lalala\\\n => lalala^\n' ) ;
+ is( "lalala^\nlalala^\n", backslash_caret( "lalala\\\nlalala\\\n" ), 'backslash_caret: lalala\\\nlalala\\\n => lalala^\nlalala^\n' ) ;
+ is( "lal\\ala^\nlalala^\n", backslash_caret( "lal\\ala\\\nlalala\\\n" ), 'backslash_caret: lal\\ala\\\nlalala\\\n => lal\\ala^\nlalala^\n' ) ;
- --usecache : Use cache to speedup.
- --nousecache : Do not use cache. Caveat: --useuid --nousecache creates
- duplicates on multiple runs.
- --useuid : Use uid instead of header as a criterium to recognize
- messages. Option --usecache is then implied unless
- --nousecache is used.
+ note( 'Leaving tests_backslash_caret()' ) ;
+ return ;
+}
- --debug : Debug mode.
- --debugfolders : Debug mode for the folders part only.
- --debugcontent : Debug content of the messages transfered. Huge ouput.
- --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.
- --debugmemory : Debug mode showing memory consumption after each copy.
+sub backslash_caret {
+ my $string = shift ;
+
+ $string =~ s{\\ $ }{^}gxms ;
- --errorsmax int : Exit when int number of errors is reached. Default is 50.
+ return $string ;
+}
- --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 connexion.
+sub usage {
+ my $mysync = shift ;
+
+ my $usage = q{} ;
+ my $usage_from_pod ;
+ my $usage_footer = usage_footer( $mysync ) ;
- --version : Print only software version.
- --noreleasecheck : Do not check for new imapsync release (a http request).
- --releasecheck : Check for new imapsync release (a http request).
- --noid : Do not send/receive ID command to imap servers.
- --justconnect : Just connect to both servers and print useful
- information. Need only --host1 and --host2 options.
- --justlogin : Just login to both host1 and host2 with users
- credentials, then exit.
- --justfolders : Do only things about folders (ignore messages).
+ # pod2usage writes on a filehandle only and I want a variable
+ open my $fh_pod2usage, ">", \$usage_from_pod or do {
+ warn $OS_ERROR ;
+ return ;
+ } ;
+
+ pod2usage(
+ -exitval => 'NOEXIT',
+ -noperldoc => 1,
+ -verbose => 99,
+ -sections => [ qw(NAME VERSION USAGE OPTIONS) ],
+ -indent => 1,
+ -loose => 1,
+ -output => $fh_pod2usage,
+ ) ;
+ close $fh_pod2usage ;
+
+ if ( 'MSWin32' eq $OSNAME ) {
+ $usage_from_pod = backslash_caret( $usage_from_pod ) ;
+ }
+ $usage = join( q{}, $usage_from_pod, $usage_footer ) ;
- --help : print this help.
+ return( $usage ) ;
+}
- 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"
+sub tests_usage {
+ my $usage ;
+ like( $usage = usage( $sync ), qr/Name:/, 'usage2: contains Name:' ) ;
+ myprint( $usage ) ;
+ like( $usage, qr/Version:/, 'usage2: contains Version:' ) ;
+ like( $usage, qr/Usage:/, 'usage2: contains Usage:' ) ;
+ like( $usage, qr/imapsync/, 'usage2: contains imapsync' ) ;
+ return ;
+}
- $0 $escape_char
- --host1 test1.lamiral.info --user1 test1 --password1 secret1 $escape_char
- --host2 test2.lamiral.info --user2 test2 --password2 secret2
+sub usage_footer {
+ my $mysync = shift ;
+
+ my $footer = q{} ;
-$localhost_info
+ my $localhost_info = localhost_info( ) ;
+ my $rcs = $mysync->{rcs} ;
+ my $homepage = homepage( ) ;
+ my $imapsync_release = q{} ;
+ $imapsync_release = check_last_release( ) if ( not defined $releasecheck ) ;
+
+ $footer =
+ qq{$localhost_info
$rcs
$imapsync_release
-$thank
-EOF
- return( 1 ) ;
+$homepage
+} ;
+ return( $footer ) ;
}
+
sub usage_complete {
- myprint( <<'EOF' ) ;
+ # Unused, I guess this function could be deleted
+ my $usage = <<'EOF' ;
--skipheader reg : Don't take into account header keyword
matching reg ex: --skipheader 'X.*'
--skipsize : Don't take message size into account to compare
messages on both sides. On by default.
- Use --no-skipsize for using size comparaison.
+ Use --no-skipsize for using size comparaison.
--allowsizemismatch : allow RFC822.SIZE != fetched msg size
consider also --skipsize to avoid duplicate messages
when running syncs more than one time per mailbox
@@ -9024,48 +11167,283 @@ sub usage_complete {
--split2 int : same thing on host2.
--nofixInboxINBOX : Don't fix Inbox INBOX mapping.
EOF
+ return( $usage ) ;
+}
+
+
+sub myGetOptions {
+# Started as a copy of Luke Ross Getopt::Long::CGI
+# 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.
+
+ my $mycgi = shift @ARG ;
+ my $arguments_ref = shift @ARG ;
+ my %options = @ARG ;
+
+ if ( not under_cgi_context( ) ) {
+ # Not CGI - pass upstream for normal command line handling
+ return Getopt::Long::GetOptionsFromArray( $arguments_ref, %options ) ;
+ }
+ my $b_ref = $options{'debugbasket=s'} ;
+
+ my $badthings = 0 ;
+ foreach my $key (sort keys %options) {
+ my $val = $options{$key};
+ #push( @{$b_ref}, "opt:[$key] val:[$val]" . ( ('SCALAR' eq ref($val) and defined $$val ) ? " [$$val]" : q{} ) . "\n" ) ;
+
+ if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/mxs ) {
+ push @{$b_ref}, "Unknown option type: [$key]\n" ;
+ $badthings++ ;
+ next ; # Unknown item
+ }
+
+ my $name = [split '|', $1, 1 ]->[0];
+
+ if (($3 || q{}) eq '+') {
+ ${ $val } = $mycgi->param($name); # "Incremental" integer
+ } elsif ($2) {
+ my @values = $mycgi->multi_param($name);
+ my $type = $2;
+ #myprint( "[$type][@values][", $3 || q{}, "][$val][", ref($val), "]\n" ) ;
+ if (($3 || q{}) eq '%' or ref($val) eq 'HASH') {
+ my %values = map { split /=/mxs, $_ } @values;
+
+ if ($type =~ m/i$/mxs) {
+ foreach my $k (keys %values) {
+ $values{$k} = int $values{$k} ;
+ }
+ } elsif ($type =~ m/f$/mxs) {
+ foreach my $k (keys %values) {
+ $values{$k} = 0 + $values{$k}
+ }
+ }
+ if ( 'REF' eq ref $val ) {
+ #push( @{$b_ref}, "refref($$val): " . ref($$val) . " %values= ", %values, "\n\n" ) ;
+ %{ ${ $val } } = %values;
+ } else {
+ #push( @{$b_ref}, "ref($val): " . ref($val) . " %values= ", %values, "\n\n" ) ;
+ %{ $val } = %values;
+ }
+ } else {
+ if ($type =~ m/i$/mxs) {
+ @values = map { int $_ } @values;
+ } elsif ($type =~ m/f$/mxs) {
+ @values = map { 0 + $_ } @values;
+ }
+ if (($3 || q{}) eq '@' or ref($val) eq 'ARRAY') {
+ @{ $val } = @values ;
+ } else {
+ ${ $val } = $values[0] ;
+ }
+ }
+ } else {
+ # Checkbox
+ # Considers only --name
+ # Should consider also --no-name and --noname
+ ${ $val } = $mycgi->param($name) ? 1 : undef ;
+ #push( @{$b_ref}, "param($name) ref($val): " . ref($val) . " val=[$$val]\n\n" ) ;
+ #myprint( "param($name) ref($val): " . ref($val) . " val=[$$val]\n\n" ) ;
+ #myprint( "param($name) ref($val): " . ref($val) . " \n\n" ) ;
+ }
+ }
+ if ( $badthings ) {
+ return ; # undef or ()
+ } else {
+ return( 1 ) ;
+ }
+}
+
+
+sub tests_get_options {
+ note( 'Entering tests_get_options()' ) ;
+
+ # CAVEAT: still setting global variables, be carefull
+ # with tests, the context increases! $debug stays on for example.
+ # API:
+ # * input arguments: two ways, command line or CGI
+ # * the program arguments
+ # * QUERY_STRING env variable
+ # * return
+ # * undef if bad things happened like
+ # * options not known
+ # * --delete 2 input
+ # * number of arguments or QUERY_STRING length
+ my $mysync ;
+ is( undef, get_options( $mysync, qw( --noexist ) ), 'get_options: --noexist => undef' ) ;
+ is( undef, get_options( $mysync, qw( --lalala --noexist --version ) ), 'get_options: --lalala --noexist --version => undef' ) ;
+ is( undef, get_options( $mysync, qw( --delete 2 ) ), 'get_options: --delete 2 => undef' ) ;
+ is( 1, get_options( $mysync, "--version" ), 'get_options: --version => 1' ) ;
+ is( 1, get_options( $mysync, "--help" ), 'get_options: --help => 1' ) ;
+ is( undef, get_options( $mysync, qw( --debug --noexist --version ) ), 'get_options: --debug --noexist --version => undef' ) ;
+
+ note( 'Leaving tests_get_options()' ) ;
+ return ;
+}
+
+sub tests_get_options_cgi {
+ note( 'Entering tests_get_options_cgi()' ) ;
+
+# 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
+ # * QUERY_STRING env variable
+ # * return
+ # * QUERY_STRING length
+
+ # CGI context
+ local $ENV{SERVER_SOFTWARE} = 'Votre serviteur' ;
+
+ # Real full test
+ # = 'host1=test1.lamiral.info&user1=test1&password1=secret1&host2=test2.lamiral.info&user2=test2&password2=secret2&debugenv=on'
+ my $mysync ;
+ require CGI ;
+ CGI->import( qw( -no_debug ) ) ;
+
+ # Testing boolean
+ $mysync->{cgi} = CGI->new( 'version=on&debugenv=on' ) ;
+ local $ENV{'QUERY_STRING'} = 'version=on&debugenv=on' ;
+ is( 22, get_options_cgi( $mysync ), 'get_options: QUERY_STRING => 22' ) ;
+ is( 1, $version, 'get_options: $version => 1' ) ;
+ # debugenv is not allowed in cgi context
+ is( undef, $mysync->{debugenv}, 'get_options: $mysync->{debugenv} => undef' ) ;
+
+ # QUERY_STRING in this test is only for return value of get_options_cgi
+ # 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_cgi( $mysync, ), 'get_options: QUERY_STRING => 36' ) ;
+ is( 'test1', $mysync->{user1}, 'get_options: $mysync->{user1} => test1' ) ;
+
+ # Testing @
+ $mysync->{cgi} = CGI->new( 'folder=fd1' ) ;
+ get_options_cgi( $mysync ) ;
+ is_deeply( [ 'fd1' ], [ @folder ], 'get_options: @folder => fd1' ) ;
+ $mysync->{cgi} = CGI->new( 'folder=fd1&folder=fd2' ) ;
+ get_options_cgi( $mysync ) ;
+ is_deeply( [ 'fd1', 'fd2' ], [ @folder ], 'get_options: @folder => fd1' ) ;
+
+ # Testing %
+ $mysync->{cgi} = CGI->new( 'f1f2=s1=d1&f1f2=s2=d2&f1f2=s3=d3' ) ;
+ get_options_cgi( $mysync ) ;
+ #$mysync->{f1f2} = { 's1' => 'd1', 's2' => 'd2' } ;
+ is_deeply( { 's1' => 'd1', 's2' => 'd2', 's3' => 'd3' },
+ $mysync->{f1f2}, 'get_options: f1f2 => s1=d1 s2=d2 s3=d3' ) ;
+
+ # Testing boolean ! with --noxxx, doesnot work
+ $mysync->{cgi} = CGI->new( 'nodry=on' ) ;
+ is( undef, $mysync->{dry}, 'get_options: --nodry => $mysync->{dry} => 0' ) ;
+
+ note( 'Leaving tests_get_options_cgi()' ) ;
return ;
}
-sub get_options {
- # In CGI context arguments are not in @ARGV but in QUERY_STRING variable (with GET).
- my $numopt = scalar @ARGV || length $ENV{'QUERY_STRING'} ;
- my $argv = join "\x00", @ARGV ;
+sub get_options_cgi {
+ # In CGI context arguments are not in @ARGV but in QUERY_STRING variable (with GET).
+ my $mysync = shift @ARG ;
+ my $mycgi = $mysync->{cgi} || return ;
+ my @arguments = @ARG ;
+ # final 0 is used to print usage when no option is given
+ my $numopt = length $ENV{'QUERY_STRING'} || 1 ;
+ $mysync->{f1f2} = {} ;
+ my $opt_ret = myGetOptions(
+ $mycgi,
+ \@arguments,
+ 'abort' => \$mysync->{abort},
+ 'host1=s' => \$mysync->{host1},
+ 'host2=s' => \$mysync->{host2},
+ 'user1=s' => \$mysync->{user1},
+ 'user2=s' => \$mysync->{user2},
+ 'password1=s' => \$mysync->{password1},
+ 'password2=s' => \$mysync->{password2},
+ 'dry!' => \$mysync->{dry},
+ 'version' => \$version,
+ 'ssl1!' => \$mysync->{ssl1},
+ 'ssl2!' => \$mysync->{ssl2},
+ 'tls1!' => \$mysync->{tls1},
+ 'tls2!' => \$mysync->{tls2},
+ 'justlogin!' => \$justlogin,
+ 'addheader!' => \$addheader,
+ 'automap!' => \$mysync->{automap},
+ 'justautomap!' => \$mysync->{justautomap},
+ 'gmail1' => \$mysync->{gmail1},
+ 'gmail2' => \$mysync->{gmail2},
+ 'office1' => \$mysync->{office1},
+ 'office2' => \$mysync->{office2},
+ 'exchange1' => \$mysync->{exchange1},
+ 'exchange2' => \$mysync->{exchange2},
+ 'domino1' => \$mysync->{domino1},
+ 'domino2' => \$mysync->{domino2},
+ 'f1f2=s%' => \$mysync->{f1f2},
+ 'folder=s' => \@folder,
+ 'testslive!' => \$mysync->{testslive},
+ 'testslive6!' => \$mysync->{testslive6},
+ ) ;
+
+ $debug and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ;
- if ( $argv =~ m/-delete\x002/x ) {
- myprint( "May be you mean --delete2 instead of --delete 2\n" ) ;
- exit 1 ;
+ if ( ! $opt_ret ) {
+ return ;
}
- $sync->{f1f2} = {} ;
- my $opt_ret = Imapsync::Getopt::Long::GetOptions(
+ return $numopt ;
+}
+
+sub get_options_cmd {
+ my $mysync = shift @ARG ;
+ my @arguments = @ARG ;
+ my $mycgi = $mysync->{cgi} ;
+ # final 0 is used to print usage when no option is given on command line
+ my $numopt = scalar @arguments || 0 ;
+ my $argv = join "\x00", @arguments ;
+
+ if ( $argv =~ m/-delete\x002/x ) {
+ output( $mysync, "May be you mean --delete2 instead of --delete 2\n" ) ;
+ return ;
+ }
+ $mysync->{f1f2} = {} ;
+ my $opt_ret = myGetOptions(
+ $mycgi,
+ \@arguments,
'debug!' => \$debug,
'debuglist!' => \$debuglist,
'debugcontent!' => \$debugcontent,
- 'debugsleep=f' => \$sync->{debugsleep},
+ 'debugsleep=f' => \$mysync->{debugsleep},
'debugflags!' => \$debugflags,
'debugimap!' => \$debugimap,
'debugimap1!' => \$debugimap1,
'debugimap2!' => \$debugimap2,
'debugdev!' => \$debugdev,
- 'debugmemory!' => \$sync->{debugmemory},
- 'debugfolders!' => \$sync->{debugfolders},
- 'debugssl=i' => \$sync->{debugssl},
- 'debugbasket=s' => \@debugbasket,
- 'debugcgi!' => \$debugcgi,
- 'host1=s' => \$host1,
- 'host2=s' => \$host2,
- 'port1=i' => \$port1,
- 'port2=i' => \$port2,
- 'inet4' => \$sync->{inet4},
- 'inet6' => \$sync->{inet6},
- 'user1=s' => \$user1,
- 'user2=s' => \$user2,
+ 'debugmemory!' => \$mysync->{debugmemory},
+ 'debugfolders!' => \$mysync->{debugfolders},
+ 'debugssl=i' => \$mysync->{debugssl},
+ 'debugbasket=s' => \@debugbasket,
+ 'debugcgi!' => \$debugcgi,
+ 'debugenv' => \$mysync->{debugenv},
+ 'simulong=i' => \$mysync->{simulong},
+ 'abort' => \$mysync->{abort},
+ 'host1=s' => \$mysync->{host1},
+ 'host2=s' => \$mysync->{host2},
+ 'port1=i' => \$mysync->{port1},
+ 'port2=i' => \$mysync->{port2},
+ 'inet4|ipv4' => \$mysync->{inet4},
+ '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},
'domain1=s' => \$domain1,
'domain2=s' => \$domain2,
- 'password1=s' => \$password1,
- 'password2=s' => \$password2,
+ 'password1=s' => \$mysync->{password1},
+ 'password2=s' => \$mysync->{password2},
'passfile1=s' => \$passfile1,
'passfile2=s' => \$passfile2,
'authmd5!' => \$authmd5,
@@ -9073,34 +11451,34 @@ sub get_options {
'authmd52!' => \$authmd52,
'sep1=s' => \$sep1,
'sep2=s' => \$sep2,
- 'folder=s' => \@folder,
- 'folderrec=s' => \@folderrec,
- 'include=s' => \@include,
- 'exclude=s' => \@exclude,
- 'folderfirst=s' => \@folderfirst,
- 'folderlast=s' => \@folderlast,
- 'prefix1=s' => \$prefix1,
- 'prefix2=s' => \$prefix2,
- 'subfolder2=s' => \$subfolder2,
- 'fixslash2!' => \$fixslash2,
- 'fixInboxINBOX!' => \$fixInboxINBOX,
- 'regextrans2=s' => \@regextrans2,
- 'mixfolders!' => \$mixfolders,
+ 'folder=s' => \@folder,
+ 'folderrec=s' => \@folderrec,
+ 'include=s' => \@include,
+ 'exclude=s' => \@exclude,
+ 'folderfirst=s' => \@folderfirst,
+ 'folderlast=s' => \@folderlast,
+ 'prefix1=s' => \$prefix1,
+ 'prefix2=s' => \$prefix2,
+ 'subfolder2=s' => \$subfolder2,
+ 'fixslash2!' => \$fixslash2,
+ 'fixInboxINBOX!' => \$fixInboxINBOX,
+ 'regextrans2=s' => \@regextrans2,
+ 'mixfolders!' => \$mixfolders,
'skipemptyfolders!' => \$skipemptyfolders,
- 'regexmess=s' => \@regexmess,
- 'skipmess=s' => \@skipmess,
- 'pipemess=s' => \@pipemess,
- 'pipemesscheck!' => \$pipemesscheck,
+ 'regexmess=s' => \@regexmess,
+ 'skipmess=s' => \@skipmess,
+ 'pipemess=s' => \@pipemess,
+ 'pipemesscheck!' => \$pipemesscheck,
'disarmreadreceipts!' => \$disarmreadreceipts,
- 'regexflag=s' => \@regexflag,
- 'filterflags!' => \$filterflags,
- 'flagscase!' => \$flagscase,
+ 'regexflag=s' => \@regexflag,
+ 'filterflags!' => \$filterflags,
+ 'flagscase!' => \$flagscase,
'syncflagsaftercopy!' => \$syncflagsaftercopy,
- 'delete|delete1!' => \$delete,
- 'delete2!' => \$delete2,
- 'delete2duplicates!' => \$delete2duplicates,
- 'delete2folders!' => \$delete2folders,
- 'delete2foldersonly=s' => \$delete2foldersonly,
+ 'delete|delete1!' => \$delete1,
+ 'delete2!' => \$delete2,
+ 'delete2duplicates!' => \$delete2duplicates,
+ 'delete2folders!' => \$delete2folders,
+ 'delete2foldersonly=s' => \$delete2foldersonly,
'delete2foldersbutnot=s' => \$delete2foldersbutnot,
'syncinternaldates!' => \$syncinternaldates,
'idatefromheader!' => \$idatefromheader,
@@ -9114,11 +11492,10 @@ sub get_options {
'search2=s' => \$search2,
'foldersizes!' => \$foldersizes,
'foldersizesatend!' => \$foldersizesatend,
- 'dry!' => \$dry,
- 'expunge!' => \$expunge,
- 'expunge1!' => \$expunge1,
- 'expunge2!' => \$expunge2,
- 'uidexpunge2!' => \$uidexpunge2,
+ 'dry!' => \$mysync->{dry},
+ 'expunge1|expunge!' => \$expunge1,
+ 'expunge2!' => \$expunge2,
+ 'uidexpunge2!' => \$uidexpunge2,
'subscribed!' => \$subscribed,
'subscribe!' => \$subscribe,
'subscribeall|subscribe_all!' => \$subscribeall,
@@ -9130,8 +11507,8 @@ sub get_options {
'version' => \$version,
'help' => \$help,
'timeout=i' => \$timeout,
- 'timeout1=i' => \$sync->{h1}->{timeout},
- 'timeout2=i' => \$sync->{h2}->{timeout},
+ 'timeout1=i' => \$mysync->{h1}->{timeout},
+ 'timeout2=i' => \$mysync->{h2}->{timeout},
'skipheader=s' => \$skipheader,
'useheader=s' => \@useheader,
'wholeheaderifneeded!' => \$wholeheaderifneeded,
@@ -9140,14 +11517,15 @@ sub get_options {
'allowsizemismatch!' => \$allowsizemismatch,
'fastio1!' => \$fastio1,
'fastio2!' => \$fastio2,
- 'ssl1!' => \$ssl1,
- 'ssl2!' => \$ssl2,
- 'ssl1_ssl_version=s' => \$sync->{h1}->{sslargs}->{SSL_version},
- 'ssl2_ssl_version=s' => \$sync->{h2}->{sslargs}->{SSL_version},
- 'sslargs1=s%' => \$sync->{h1}->{sslargs},
- 'sslargs2=s%' => \$sync->{h2}->{sslargs},
- 'tls1!' => \$tls1,
- 'tls2!' => \$tls2,
+ 'sslcheck!' => \$mysync->{sslcheck},
+ 'ssl1!' => \$mysync->{ssl1},
+ 'ssl2!' => \$mysync->{ssl2},
+ 'ssl1_ssl_version=s' => \$mysync->{h1}->{sslargs}->{SSL_version},
+ 'ssl2_ssl_version=s' => \$mysync->{h2}->{sslargs}->{SSL_version},
+ 'sslargs1=s%' => \$mysync->{h1}->{sslargs},
+ 'sslargs2=s%' => \$mysync->{h2}->{sslargs},
+ 'tls1!' => \$mysync->{tls1},
+ 'tls2!' => \$mysync->{tls2},
'uid1!' => \$uid1,
'uid2!' => \$uid2,
'authmech1=s' => \$authmech1,
@@ -9161,13 +11539,15 @@ sub get_options {
'buffersize=i' => \$buffersize,
'reconnectretry1=i' => \$reconnectretry1,
'reconnectretry2=i' => \$reconnectretry2,
- 'tests!' => \$tests,
- 'testsdebug|tests_debug!' => \$testsdebug,
- 'testslive!' => \$testslive,
- 'justlogin!' => \$justlogin,
- 'tmpdir=s' => \$tmpdir,
- 'pidfile=s' => \$sync->{pidfile},
- 'pidfilelocking!' => \$sync->{pidfilelocking},
+ 'tests!' => \$mysync->{ tests },
+ 'testsdebug|tests_debug!' => \$mysync->{ testsdebug },
+ 'testsunit=s@' => \$mysync->{testsunit},
+ 'testslive!' => \$mysync->{testslive},
+ 'testslive6!' => \$mysync->{testslive6},
+ 'justlogin!' => \$justlogin,
+ 'tmpdir=s' => \$tmpdir,
+ 'pidfile=s' => \$mysync->{pidfile},
+ 'pidfilelocking!' => \$mysync->{pidfilelocking},
'releasecheck!' => \$releasecheck,
'modulesversion|modules_version!' => \$modulesversion,
'usecache!' => \$usecache,
@@ -9179,119 +11559,278 @@ sub get_options {
'checkselectable!' => \$checkselectable,
'checkmessageexists!' => \$checkmessageexists,
'expungeaftereach!' => \$expungeaftereach,
- 'abletosearch!' => \$abletosearch,
- 'showpasswords!' => \$showpasswords,
- 'maxlinelength=i' => \$maxlinelength,
- 'maxlinelengthcmd=s' => \$maxlinelengthcmd,
- 'minmaxlinelength=i' => \$minmaxlinelength,
- 'debugmaxlinelength!' => \$debugmaxlinelength,
+ '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' => \$maxmessagespersecond,
- 'maxbytespersecond=i' => \$maxbytespersecond,
+ 'maxmessagespersecond=f' => \$mysync->{maxmessagespersecond},
+ 'maxbytespersecond=i' => \$mysync->{maxbytespersecond},
+ 'maxbytesafter=i' => \$mysync->{maxbytesafter},
+ 'maxsleep=f' => \$mysync->{maxsleep},
'skipcrossduplicates!' => \$skipcrossduplicates,
'debugcrossduplicates!' => \$debugcrossduplicates,
- 'log!' => \$sync->{log},
- 'logfile=s' => \$sync->{logfile},
- 'logdir=s' => \$sync->{logdir},
- 'errorsmax=i' => \$sync->{errorsmax},
- 'errorsdump!' => \$sync->{errorsdump},
+ 'log!' => \$mysync->{log},
+ 'logfile=s' => \$mysync->{logfile},
+ 'logdir=s' => \$mysync->{logdir},
+ 'errorsmax=i' => \$mysync->{errorsmax},
+ 'errorsdump!' => \$mysync->{errorsdump},
'fetch_hash_set=s' => \$fetch_hash_set,
- 'automap!' => \$sync->{automap},
- 'justautomap!' => \$sync->{justautomap},
- 'id!' => \$sync->{id},
- 'f1f2=s%' => \$sync->{f1f2},
- 'justfolderlists!' => \$sync->{justfolderlists},
- 'delete1emptyfolders' => \$sync->{delete1emptyfolders},
+ 'automap!' => \$mysync->{automap},
+ 'justautomap!' => \$mysync->{justautomap},
+ 'id!' => \$mysync->{id},
+ 'f1f2=s%' => \$mysync->{f1f2},
+ 'justfolderlists!' => \$mysync->{justfolderlists},
+ 'delete1emptyfolders' => \$mysync->{delete1emptyfolders},
) ;
+ $debug and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ;
+
+ if ( ! $opt_ret ) {
+ return ;
+ }
+ return $numopt ;
+}
- $debugcgi and myprint( map { "$_ => $ENV{$_}\n" } sort keys %ENV ) ;
- $debugcgi and myprint( "@debugbasket\n" ) ;
- $debug and myprint( "get options: [$opt_ret]\n" ) ;
+sub get_options {
+ my $mysync = shift @ARG ;
+ my @arguments = @ARG ;
+ my $mycgi = $mysync->{cgi} ;
- # just the version
- myprint( imapsync_version( ), "\n" ) and exit 0 if ( $version ) ;
- # $tmpdir is used in tests_pipemess()
- $tmpdir ||= File::Spec->tmpdir( ) ;
- if ( $tests or $testsdebug ) {
- $test_builder = Test::More->builder ;
- if ( $tests ) { tests( ) ; }
- if ( $testsdebug ) { testsdebug( ) ; }
- #$test_builder->reset( ) ;
- exit ;
+ if ( under_cgi_context( ) ) {
+ # CGI context
+ return get_options_cgi( $mysync, @arguments ) ;
+ }else{
+ # Command line context ;
+ return get_options_cmd( $mysync, @arguments ) ;
}
+ return ;
+}
+
+sub testunitsession {
+ my $mysync = shift ;
+
+ if ( ! $mysync ) { return ; }
+ if ( ! $mysync->{ testsunit } ) { return ; }
+
+ my @functions = @{ $mysync->{ testsunit } } ;
+
+ if ( ! @functions ) { return ; }
+
+ SKIP: {
+ if ( ! @functions ) { skip 'No test in normal run' ; }
+ testsunit( @functions ) ;
+ done_testing( ) ;
+ }
+ return ;
+}
- #$help = 1 if ! $numopt;
- load_modules( );
+sub tests_count_0s {
+ note( 'Entering tests_count_zeros()' ) ;
+ is( 0, count_0s( ), 'count_0s: no parameters => undef' ) ;
+ is( 1, count_0s( 0 ), 'count_0s: 0 => 1' ) ;
+ is( 0, count_0s( 1 ), 'count_0s: 1 => 0' ) ;
+ is( 1, count_0s( 1, 0, 1 ), 'count_0s: 1, 0, 1 => 1' ) ;
+ is( 2, count_0s( 1, 0, 1, 0 ), 'count_0s: 1, 0, 1, 0 => 2' ) ;
+ note( 'Leaving tests_count_zeros()' ) ;
+ return ;
+}
+sub count_0s {
+ my @array = @ARG ;
+
+ if ( ! @array ) { return 0 ; }
+ my $nb_zeros = 0 ;
+ map { $_ == 0 and $nb_zeros += 1 } @array ;
+ return $nb_zeros ;
+}
+
+sub tests_report_failures {
+ note( 'Entering tests_report_failures()' ) ;
+ is( undef, report_failures( ), 'report_failures: no parameters => undef' ) ;
+ is( "n° 1 - first\n", report_failures( ({'ok' => 0, name => 'first'}) ), 'report_failures: "first" failed => n° 1 - first' ) ;
+ is( q{}, report_failures( ( {'ok' => 1, name => 'first'} ) ), 'report_failures: "first" success =>' ) ;
+ is( "n° 2 - second\n", report_failures( ( {'ok' => 1, name => 'second'}, {'ok' => 0, name => 'second'} ) ), 'report_failures: "second" failed => n° 2 - second' ) ;
+ is( "n° 1 - first\nn° 2 - second\n", report_failures( ( {'ok' => 0, name => 'first'}, {'ok' => 0, name => 'second'} ) ), 'report_failures: both failed => n° 1 - first n° 2 - second' ) ;
+ note( 'Leaving tests_report_failures()' ) ;
+ return ;
+}
- # exit with --help option or no option at all
- $debug and myprint( "numopt:$numopt\n" ) ;
- usage( ) and exit if ( $help or not $numopt ) ;
+sub report_failures {
+ my @details = @ARG ;
+
+ if ( ! @details ) { return ; }
+
+ my $counter = 1 ;
+ my $report = q{} ;
+ foreach my $details ( @details ) {
+ if ( ! $details->{ 'ok' } ) {
+ my $name = $details->{ 'name' } || 'NONAME' ;
+ $report .= "n° $counter - $name\n" ;
+ }
+ $counter += 1 ;
+ }
+ return $report ;
- # don't go on if options are not all known.
- exit $EX_USAGE unless ( $opt_ret ) ;
+}
- # init live varaiables
- testslive( ) if ( $testslive ) ;
+sub tests_true {
+ note( 'Entering tests_true()' ) ;
+ is( 1, 1, 'true: 1 is 1' ) ;
+ note( 'Leaving tests_true()' ) ;
+ return ;
+}
+sub tests_testsunit {
+ note( 'Entering tests_testunit()' ) ;
+ is( undef, testsunit( ), 'testsunit: no parameters => undef' ) ;
+ is( undef, testsunit( undef ), 'testsunit: an undef parameter => undef' ) ;
+ is( undef, testsunit( q{} ), 'testsunit: an empty parameter => undef' ) ;
+ is( undef, testsunit( 'idonotexist' ), 'testsunit: a do not exist function as parameter => undef' ) ;
+ is( undef, testsunit( 'tests_true' ), 'testsunit: tests_true => undef' ) ;
+ note( 'Leaving tests_testunit()' ) ;
return ;
}
-sub testslive {
- $host1 = 'test1.lamiral.info' ;
- $user1 = 'test1' ;
- $password1 = 'secret1' ;
- $host2 = 'test2.lamiral.info' ;
- $user2 = 'test2' ;
- $password2 ='secret2' ;
+sub testsunit {
+ my @functions = @ARG ;
+
+ if ( ! @functions ) { #
+ myprint( "testsunit warning: no argument given\n" ) ;
+ return ;
+ }
+
+ foreach my $function ( @functions ) {
+ if ( ! $function ) {
+ myprint( "testsunit warning: argument is empty\n" ) ;
+ next ;
+ }
+ if ( ! exists &$function ) {
+ myprint( "testsunit warning: function $function does not exist\n" ) ;
+ next ;
+ }
+ if ( ! defined &$function ) {
+ myprint( "testsunit warning: function $function is not defined\n" ) ;
+ next ;
+ }
+ my $function_ref = \&{ $function } ;
+ &$function_ref() ;
+ }
return ;
}
sub testsdebug {
- SKIP: {
- skip 'No test in normal run' if ( not $testsdebug ) ;
+ my $mysync = shift ;
+ if ( ! $mysync->{ testsdebug } ) { return ; }
+ SKIP: {
+ if ( ! $mysync->{ testsdebug } ) {
+ skip 'No test in normal run' ;
+ }
+
+ note( 'Entering testsdebug()' ) ;
+ ok( ( ( not -d 'W/tmp/tests' ) or rmtree( 'W/tmp/tests/' ) ), 'testsdebug: rmtree W/tmp/tests' ) ;
#tests_bytes_display_string( ) ;
#tests_ucsecond( ) ;
#tests_mkpath( ) ;
- #eval { tests_mkpath( ) ; } or ok( 0 == 1, 'tests_mkpath fail badly?' ) ;
#tests_format_for_imap_arg( ) ;
#tests_is_a_release_number( ) ;
#tests_delete1emptyfolders( ) ;
#tests_memory_consumption( ) ;
#tests_imap2_folder_name() ;
#tests_length_ref( ) ;
- #tests_is_valid_directory( ) ;
- #tests_firstline( ) ;
#tests_diff_or_NA( ) ;
#tests_match_number( ) ;
#tests_all_defined( ) ;
#tests_guess_separator( ) ;
- tests_pipemess( ) ;
#tests_message_for_host2( ) ;
+ #tests_special_from_folders_hash( ) ;
+ #tests_do_valid_directory( ) ;
+ #tests_notmatch( ) ;
+ #tests_match( ) ;
+ #tests_get_options( ) ;
+ #tests_rand32( ) ;
+ #tests_string_to_file( ) ;
+ #tests_hashsynclocal( ) ;
+ #tests_output( ) ;
+ #tests_output_reset_with( ) ;
+ #tests_output_start( ) ;
+ #tests_hashsync( ) ;
+ #tests_check_last_release( ) ;
+ #tests_cpu_number( ) ;
+ #tests_load_and_delay( ) ;
+ #tests_loadavg( ) ;
+ #tests_backtick( ) ;
+ #tests_firstline( ) ;
+ #tests_pipemess( ) ;
+ #tests_not_long_imapsync_version_public( ) ;
+ #tests_get_options_cgi( ) ;
+ #tests_guess_special( ) ;
+####tests_reconnect_if_needed( ) ;
+ #tests_reconnect_12_if_needed( ) ;
+ #tests_sleep_max_bytes( ) ;
+ #tests_file_to_string( ) ;
+ #tests_under_cgi_context( ) ;
+ #tests_umask( ) ;
+ #tests_umask_str( ) ;
+ #tests_set_umask( ) ;
+ #tests_createhashfileifneeded( ) ;
+ #tests_filter_forbidden_characters( ) ;
+ #tests_logfile( ) ;
+ #tests_setlogfile( ) ;
+ #tests_move_slash( ) ;
+ #tests_testsunit( ) ;
+ #tests_always_fail( ) ;
+ #tests_count_0s( ) ;
+ #tests_report_failures( ) ;
+ #tests_max( ) ;
+ #tests_min( ) ;
+ #tests_sleep_if_needed( ) ;
+ #tests_imapsping( ) ;
+ #tests_tcpping( ) ;
+ #tests_sslcheck( ) ;
+ #tests_resolv( ) ;
+ #tests_resolvrev( ) ;
+ #tests_connect_socket( ) ;
+ #tests_probe_imapssl( ) ;
+ #tests_mailimapclient_connect( ) ;
+ #tests_guess_prefix( ) ;
+ #tests_usage( ) ;
+ #tests_version_from_rcs( ) ;
+ #tests_mailimapclient_connect_bug( ) ; # it fails with Mail-IMAPClient <= 3.39
+ tests_backslash_caret( ) ;
+
+ note( 'Leaving testsdebug()' ) ;
done_testing( ) ;
- note('End of imapsync --tests_debug') ;
}
return ;
}
+
+
sub tests {
+ my $mysync = shift ;
+ if ( ! $mysync->{ tests } ) { return ; }
- SKIP: {
- skip 'No test in normal run' if ( not $tests ) ;
+ SKIP: {
+ skip 'No test in normal run' if ( ! $mysync->{ tests } ) ;
+ note( 'Entering tests()' ) ;
tests_folder_routines( ) ;
tests_compare_lists( ) ;
- tests_regexmess();
+ tests_regexmess( ) ;
tests_skipmess( ) ;
tests_flags_regex();
tests_ucsecond( ) ;
tests_permanentflags();
tests_flags_filter( ) ;
tests_separator_invert( ) ;
- tests_imap2_folder_name() ;
- tests_command_line_nopassword();
+ tests_imap2_folder_name( ) ;
+ tests_command_line_nopassword( ) ;
tests_good_date( ) ;
- tests_max();
+ tests_max( ) ;
tests_remove_not_num();
tests_memory_consumption( ) ;
tests_is_a_release_number();
@@ -9305,7 +11844,7 @@ sub tests {
tests_clean_cache_2( ) ;
tests_touch( ) ;
tests_flagscase( ) ;
- eval { tests_mkpath( ) ; } or ok( 0 == 1, 'tests_mkpath fail badly?' ) ;
+ tests_mkpath( ) ;
tests_extract_header( ) ;
tests_decompose_header( ) ;
tests_epoch( ) ;
@@ -9316,7 +11855,6 @@ sub tests {
tests_cache_folder( ) ;
tests_time_remaining( ) ;
tests_decompose_regex( ) ;
- tests_Banner( ) ;
tests_backtick( ) ;
tests_bytes_display_string( ) ;
tests_header_line_normalize( ) ;
@@ -9340,149 +11878,63 @@ sub tests {
tests_quota_extract_storage_limit_in_bytes( ) ;
tests_quota_extract_storage_current_in_bytes( ) ;
tests_guess_special( ) ;
- tests_is_valid_directory( ) ;
+ tests_do_valid_directory( ) ;
tests_delete1emptyfolders( ) ;
tests_message_for_host2( ) ;
tests_length_ref( ) ;
- tests_firstline( ) ;
+ tests_firstline( ) ;
tests_diff_or_NA( ) ;
- #tests_always_fail( ) ;
tests_match_number( ) ;
tests_all_defined( ) ;
- done_testing( 693 ) ;
- note('End of imapsync --tests') ;
+ tests_special_from_folders_hash( ) ;
+ tests_notmatch( ) ;
+ tests_match( ) ;
+ tests_get_options( ) ;
+ tests_get_options_cgi( ) ;
+ tests_rand32( ) ;
+ tests_hashsynclocal( ) ;
+ tests_hashsync( ) ;
+ tests_output( ) ;
+ tests_output_reset_with( ) ;
+ tests_output_start( ) ;
+ tests_check_last_release( ) ;
+ tests_loadavg( ) ;
+ tests_cpu_number( ) ;
+ tests_load_and_delay( ) ;
+ #tests_imapsping( ) ;
+ #tests_tcpping( ) ;
+ tests_sslcheck( ) ;
+ tests_not_long_imapsync_version_public( ) ;
+ tests_reconnect_if_needed( ) ;
+ tests_reconnect_12_if_needed( ) ;
+ tests_sleep_if_needed( ) ;
+ tests_string_to_file( ) ;
+ tests_file_to_string( ) ;
+ tests_under_cgi_context( ) ;
+ tests_umask( ) ;
+ tests_umask_str( ) ;
+ tests_set_umask( ) ;
+ tests_createhashfileifneeded( ) ;
+ tests_move_slash( ) ;
+ tests_testsunit( ) ;
+ tests_count_0s( ) ;
+ tests_report_failures( ) ;
+ tests_min( ) ;
+ #tests_resolv( ) ;
+ #tests_resolvrev( ) ;
+ tests_connect_socket( ) ;
+ tests_probe_imapssl( ) ;
+ tests_mailimapclient_connect( ) ;
+ tests_usage( ) ;
+ tests_version_from_rcs( ) ;
+ tests_backslash_caret( ) ;
+ #tests_mailimapclient_connect_bug( ) ; # it fails with Mail-IMAPClient <= 3.39
+ #tests_always_fail( ) ;
+ done_testing( 1012 ) ;
+ note( 'Leaving tests()' ) ;
}
return ;
}
-# IMAPClient 3.xx ads
-
-package Mail::IMAPClient;
-
-sub Tls {
- my $self = shift ;
- my $value = shift ;
- if ( defined $value ) { $self->{TLS} = $value }
- return $self->{TLS};
-}
-
-sub Reconnect_counter {
- my $self = shift ;
- my $value = shift ;
- $self->{Reconnect_counter} = 0 if ( not defined $self->{Reconnect_counter} ) ;
- if ( defined $value ) { $self->{Reconnect_counter} = $value }
- return( $self->{Reconnect_counter} ) ;
-}
-
-
-sub Banner {
- my $self = shift ;
- my $value = shift ;
- if ( defined $value ) { $self->{ BANNER } = $value }
- return $self->{ BANNER };
-}
-
-sub capability_update {
- my $self = shift ;
-
- delete $self->{CAPABILITY} ;
- return( $self->capability ) ;
-}
-
-
-package Imapsync::Getopt::Long ;
-# Started as a copy of Luke Ross Getopt::Long::CGI
-# https://metacpan.org/release/Getopt-Long-CGI
-# So this section 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.
-
-use strict ;
-use warnings ;
-
-use Getopt::Long( ) ;
-
-
-sub GetOptions {
- my %options = @_ ;
-
- if ( not $ENV{SERVER_SOFTWARE} ) {
- # Not CGI - pass upstream for normal command line handling
- return Getopt::Long::GetOptions( %options ) ;
- }
- my $b_ref = $options{'debugbasket=s'} ;
- require CGI ;
- require CGI::Carp ;
- CGI::Carp->import( 'fatalsToBrowser' ) ;
-
- my $cgi = CGI->new( ) ;
- $cgi->param( 'debugcgi' ) and myprint( "<h2>Current Values</h2>\n" . $cgi->Dump ) ;
-
- foreach my $key (sort keys %options) {
- my $val = $options{$key};
- #push( @{$b_ref}, "opt:[$key] val:[$val]" . ( ('SCALAR' eq ref($val) and defined $$val ) ? " [$$val]" : q{} ) . "\n" ) ;
- if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/ ) {
- push @{$b_ref}, "Unknown opt: [$key]\n" ;
- next ; # Unknown item
- }
-
- my $name = [split '|', $1, 1 ]->[0];
-
- if (($3 || q{}) eq '+') {
- ${ $val } = $cgi->param($name); # "Incremental" integer
- } elsif ($2) {
- my @values = $cgi->param($name);
- my $type = $2;
- if (($3 || q{}) eq '%' or ref($val) eq 'HASH') {
- my %values = map { split /=/, $_, 1 } @values;
- if ($type =~ m/i$/) {
- foreach my $k (keys %values) {
- $values{$k} = int $values{$k} ;
- }
- } elsif ($type =~ m/f$/) {
- foreach my $k (keys %values) {
- $values{$k} = 0 + $values{$k}
- }
- }
- if ( ref($val) eq 'CODE') {
- while(my($k, $v) = each %values) {
- $val->($name, $k, $v);
- }
- } elsif ( 'REF' eq ref $val ) {
- #push( @{$b_ref}, "refref($$val): " . ref($$val) . " %values= ", %values, "\n\n" ) ;
- %{ ${ $val } } = %values;
- } else {
- #push( @{$b_ref}, "ref($val): " . ref($val) . " %values= ", %values, "\n\n" ) ;
- %{ $val } = %values;
- }
- } else {
- if ($type =~ m/i$/) {
- @values = map { int $_ } @values;
- } elsif ($type =~ m/f$/) {
- @values = map { 0 + $_ } @values;
- }
- if (($3 || q{}) eq '@' or ref($val) eq 'ARRAY') {
- if (ref($val) eq 'CODE') {
- $val->($name, \@values)
- } else {
- @{ $val } = @values ;
- }
- } else {
- if (ref($val) eq 'CODE') {
- $val->($name, $values[0]);
- } else {
- ${ $val } = $values[0];
- }
- }
- }
- } else {
- # Checkbox
- ${ $val } = $cgi->param($name) ? 1 : undef ;
- #push( @{$b_ref}, "param($name) ref($val): " . ref($val) . " val=[$$val]\n\n" ) ;
- }
- }
- return( 1 ) ;
-}
-
-