#!/usr/bin/perl
# $Id: imapsync,v 2.229 2022/09/14 18:08:24 gilles Exp gilles $
# structure
# pod documentation
# use pragmas
# main program
# global variables initialization
# get_options( ) ;
# default values
# folder loop
# subroutines
# sub usage
# pod documentation
=pod
=head1 NAME
imapsync - Email IMAP tool for syncing, copying, migrating
and archiving email mailboxes between two imap servers, one way,
and without duplicates.
=head1 VERSION
This documentation refers to Imapsync $Revision: 2.229 $
=head1 USAGE
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:
imapsync \
--host1 test1.lamiral.info --user1 test1 --password1 secret1 \
--host2 test2.lamiral.info --user2 test2 --password2 secret2
=head1 DESCRIPTION
We sometimes need to transfer mailboxes from one imap server to
one another.
Imapsync command is a tool allowing incremental and recursive imap
transfers from one mailbox to another. If you don't understand the
previous sentence, it's normal, it's pedantic computer-oriented
jargon.
All folders are transferred, recursively, meaning the whole folder
hierarchy is taken, all messages in them, and all message flags (\Seen
\Answered \Flagged etc.) are synced too.
Imapsync reduces the amount of data transferred by not transferring a
given message if it already resides on the destination side. Messages
that are on the destination side but not on the source side stay as
they are. See the --delete2 option to have strict sync and delete
them.
How does imapsync know a message is already on both sides? Same
specific headers and the transfer is done only once. By default, the
identification headers are "Message-Id:" and "Received:" lines but
this choice can be changed with the --useheader option, most often a
duplicate problem is solved by using --useheader "Message-Id"
All flags are preserved, unread messages will stay unread, read ones
will stay read, deleted will stay deleted. In the IMAP protocol, a
deleted message is not deleted, it is marked \Deleted and can be
undeleted. Real destruction comes with the EXPUNGE or UIDEXPUNGE IMAP
commands.
You can abort the transfer at any time and restart it later, imapsync
works well with bad connections and interruptions, by design. On a
terminal hit Ctr-c twice within two seconds to abort the program. Hit
Ctr-c just once makes imapsync reconnect to both imap servers.
How do you know the sync is finished and well done?
When imapsync ends by itself it mentions it with lines like those:
Exiting with return value 0 (EX_OK: successful termination) 0/50 nb_errors/max_errors PID 301
Removing pidfile /tmp/imapsync.pid
Log file is LOG_imapsync/2020_11_17_15_59_22_761_test1_test2.txt ( to change it, use --logfile filepath ; or use --nolog to turn off logging )
If you don't have those lines it means that either the sync process is
still running (or eventually hanging indefinitely) or that it ended
without a whisper, a strong kill -9 on Linux for example.
If you have those final lines then it means the sync process is properly
finished. It may have encountered problems though.
A good synchronization is mentioned by some lines above the last ones,
especially those three lines:
The sync looks good, all 1745 identified messages in host1 are on host2.
There is no unidentified message on host1.
Detected 0 errors
Imapsync mentions the total sizes of both accounts at the beginning of
the sync and also at the end. Sometimes, even with a strict sync,
those total sizes differ, and sometimes they differ a lot. The
difference is not a good criterion to conclude the sync went wrong.
Why? That's because message sizes given by the imap servers are not
always accurate, they are not always the same as the actual message
sizes of the messages transferred by imapsync. Imapsync use the sizes
given by the imap servers to calculate the big total size. They can
differ. In the early days, Imapsync used the sizes of the messages as
one of the criteria to identify the messages, different sizes implied
different messages; but it was a mistake, the same message had
different sizes on both sides sometimes, depending on the imap
servers.
Another explanation for a big total size difference is that Gmail
doesn't count the size of duplicate messages across folders twice,
while imapsync does.
A classical scenario is synchronizing a mailbox B from another mailbox
A where you just want to keep a strict copy of A in B. Strict meaning
all messages in A will be in B but no more.
For a strict synchronization, use the option --delete2. The option
--delete2 deletes the messages in the host2 folder B that are not in
the host1 folder A. If you also need to destroy host2 folders that are
not in host1 then use --delete2folders. See also --delete2foldersonly
and --delete2foldersbutnot to set up exceptions on folders to
destroy. INBOX will never be destroyed, it's a mandatory folder in
IMAP so imapsync doesn't even try to remove it.
A different scenario is to delete the messages from the source mailbox
after a successful transfer, it can be a good feature when migrating
mailboxes since messages will be only on one side. The source account
will only have messages that are not on the destination yet, ie,
messages that arrived after a sync or that failed to be transferred.
In that case, use the --delete1 option. Option --delete1 implies also
the option --expunge1 so all messages marked deleted on host1 will be
deleted. In IMAP protocol deleting a message does not delete it, it
marks it with the flag \Deleted, allowing an undelete. Expunging a
folder removes, definitively, all the messages marked as \Deleted in
this folder.
You can also decide to remove empty folders once all of their messages
have been transferred. Add --delete1emptyfolders to obtain this
behavior.
Imapsync is not adequate for maintaining two active imap accounts in
synchronization when the user plays independently on both sides. Use
offlineimap (written by John Goerzen) or mbsync (written by Michael
R. Elkins) for a 2 ways synchronization.
=head1 OPTIONS
usage: imapsync [options]
The standard options are the six values forming the credentials.
Three values on each side are needed to login into the IMAP
servers. These six values are a hostname, a username, and a password,
two times.
Here are the conventions used in the following descriptions of the
options:
str means a string
int means an integer number
flo means a float number
reg means a regular expression
cmd means a command
--dry : Makes imapsync do nothing for real; it just prints what
would be done without --dry.
=head2 OPTIONS/credentials
--host1 str : Source or "from" imap server.
--port1 int : Port to connect on host1.
Optional since default ports are the
well known ports imap/143 or imaps/993.
--user1 str : User to login on host1.
--password1 str : Password of user1.
--host2 str : "destination" imap server.
--port2 int : Port to connect on host2. Optional
--user2 str : User to login on host2.
--password2 str : Password of user2.
--showpasswords : Shows passwords on output instead of "MASKED".
Useful to restart a complete run by just reading
the command line used in the log,
or to debug passwords.
It's not a secure practice at all!
--passfile1 str : Password file for the user1. It must contain the
password on the first line. This option avoids showing
the password on the command line like --password1 does.
--passfile2 str : Password file for the user2.
You can also pass the passwords in the environment variables
IMAPSYNC_PASSWORD1 and IMAPSYNC_PASSWORD2. If you don't pass
the user1 password via --password1 nor --passfile1 nor $IMAPSYNC_PASSWORD1
then imapsync will prompt to enter the password on the terminal.
Same thing for user2 password.
=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
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
=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
--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 authentication for host1.
--authmd52 : Use MD5 authentication for host2.
--domain1 str : Domain on host1 (NTLM authentication).
--domain2 str : Domain on host2 (NTLM authentication).
--oauthaccesstoken1 str : The access token to authenticate with OAUTH2.
It will be combined with the --user1 value to form the
string to pass with XOAUTH2 authentication.
The password given by --password1 or --passfile1
is ignored but needed on the command line.
Instead of the access token itself, the value can be a
file containing the access token on the first line.
If the value is a file, imapsync reads its first line
and take this line as the access token. The advantage
of the file is that if the access token changes then
imapsync can read it again when it needs to reconnect
during a run.
--oauthaccesstoken2 str : same thing as --oauthaccesstoken1
--oauthdirect1 str : The direct string to pass with XOAUTH2 authentication.
The password given by --password1 or --passfile1 and
the user given by --user1 are ignored but they are
needed to be on the command line. Consider it a bug.
--oauthdirect2 str : same thing as oauthdirect1
=head2 OPTIONS/folders
--folder str : Sync this folder.
--folder str : and this one, etc.
--folderrec str : Sync this folder recursively.
--folderrec str : and this one, etc.
--folderfirst str : Sync this folder first. Ex. --folderfirst "INBOX"
--folderfirst str : then this one, etc.
--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
while host2 is not (like Exchange). Only the first
similar folder is synced. Example: with folders
"Sent", "SENT" and "sent" on host1, only "Sent"
will be synced to host2.
--skipemptyfolders : Empty host1 folders are not created on host2.
--include reg : Sync folders matching this regular expression
--include reg : or this one, etc.
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.
--exclude reg : or this one, etc.
--automap : guesses folders mapping, for folders well known as
"Sent", "Junk", "Drafts", "All", "Archive", "Flagged".
--f1f2 str1=str2 : Force folder str1 to be synced to str2,
--f1f2 overrides --automap and --regextrans2.
Use several --f1f2 options to map several folders.
Option --f1f2 is a one to one only folder mapping,
str1 and str2 have to be full path folder names.
--subfolder2 str : Syncs the whole host1 folders hierarchy under the
host2 folder named str.
It does it internally by adding three
--regextrans2 options before all others.
Add --debug to see what's really going on.
--subfolder1 str : Syncs the host1 folders hierarchy which is under folder
str to the root hierarchy of host2.
It's the couterpart of a sync done by --subfolder2
when doing it in the reverse order.
Backup/Restore scenario:
Use --subfolder2 str for a backup to the folder str
on host2. Then use --subfolder1 str for restoring
from the folder str, after inverting
host1/host2 user1/user2 values.
--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. So this option
should not be used most of the time.
--prefix2 str : Add prefix to all host2 folders. See --prefix1
--sep1 str : Host1 separator. This option should not be used
most of the time.
Imapsync gets the separator from the server itself,
by using NAMESPACE, or it tries to guess it
from the folders listing (it counts
characters / . \\ \ in folder names and choose the
more frequent, or finally / if nothing is found.
--sep2 str : Host2 separator. See --sep1
--regextrans2 reg : Apply the whole regex to each destination folders.
--regextrans2 reg : and this one. etc.
When you play with the --regextrans2 option, first
add also the safe options --dry --justfolders
Then, when happy, remove --dry for a run, then
remove --justfolders for the next ones.
Have in mind that --regextrans2 is applied after
the automatic prefix and separator inversion.
For examples see:
https://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
/tmp is often too small and deleted at reboot.
--tmpdir /var/tmp should be better.
--pidfile str : The file where imapsync pid is written,
it can be dirname/filename complete path.
The default name is imapsync.pid in tmpdir.
--pidfilelocking : Abort if pidfile already exists. Useful to avoid
concurrent transfers on the same mailbox.
=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/
The default logfile name is for example
LOG_imapsync/2019_12_22_23_57_59_532_user1_user2.txt
where:
2019_12_22_23_57_59_532 is nearly the date of the start
YYYY_MM_DD_HH_MM_SS_mmm
year_month_day_hour_minute_second_millisecond
and user1 user2 are the --user1 --user2 values.
=head2 OPTIONS/messages
--skipmess reg : Skips messages matching the regex.
Example: 'm/[\x80-\xff]/' # to avoid 8bits messages.
--skipmess is applied before --regexmess
--skipmess reg : or this one, etc.
--skipcrossduplicates : Avoid copying messages that are already copied
in another folder, good from Gmail to XYZ when
XYZ is not also Gmail.
Activated with --gmail1 unless --noskipcrossduplicates
--debugcrossduplicates : Prints which messages (UIDs) are skipped with
--skipcrossduplicates and in what other folders
they are.
--pipemess cmd : Apply this cmd command to each message content
before the copy.
--pipemess cmd : and this one, etc.
With several --pipemess, the output of each cmd
command (STDOUT) is given to the input (STDIN)
of the next command.
For example,
--pipemess cmd1 --pipemess cmd2 --pipemess cmd3
is like a Unix pipe:
"cat message | cmd1 | cmd2 | cmd3"
--disarmreadreceipts : Disarms read receipts (host2 Exchange issue)
--regexmess reg : Apply the whole regex to each message before transfer.
Example: 's/\000/ /g' # to replace null characters
by spaces.
--regexmess reg : and this one, etc.
--truncmess int : truncates messages when their size exceed the int
value, specified in bytes. Good to sync too big
messages or to "suppress" attachments.
Have in mind that this way, messages become
uncoherent somehow.
=head2 OPTIONS/labels
Gmail present labels as folders in imap. Imapsync can accelerate the sync
by syncing X-GM-LABELS, it will avoid to transfer messages when they are
already on host2 in another folder.
--synclabels : Syncs also Gmail labels when a message is copied to host2.
Activated by default with --gmail1 --gmail2 unless
--nosynclabels is added.
--resynclabels : Resyncs Gmail labels when a message is already on host2.
Activated by default with --gmail1 --gmail2 unless
--noresynclabels is added.
For Gmail syncs, see also:
https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt
=head2 OPTIONS/flags
If you encounter flag problems see also:
https://imapsync.lamiral.info/FAQ.d/FAQ.Flags.txt
--regexflag reg : Apply the whole regex to each flags list.
Example: 's/"Junk"//g' # to remove "Junk" flag.
--regexflag reg : then this one, etc.
--resyncflags : Resync flags for already transferred messages.
On by default.
--noresyncflags : Do not resync flags for already transferred messages.
May be useful when a user has already started to play
with its host2 account.
--filterbuggyflags : Filter flags known to be buggy and generators of errors
"BAD Invalid system flag" or "NO APPEND Invalid flag list".
=head2 OPTIONS/deletions
--delete1 : Deletes messages on host1 server after a successful
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. If expunging after each message
slows down too much the sync then use
--noexpungeaftereach to speed up, expunging will then be
done only twice per folder, one at the beginning and
one at the end of a folder sync.
--expunge1 : Expunge messages on host1 just before syncing a folder.
Expunge is done per folder.
Expunge aims is to really delete messages marked deleted.
An expunge is also done after each message copied
if option --delete1 is set (unless --noexpungeaftereach).
--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 the host2 account that are not in
the host1 account. Useful for backup or pre-sync.
--delete2 implies --uidexpunge2
--delete2duplicates : Deletes messages in host2 that are duplicates in host2.
Works only without --useuid since duplicates are
detected with an header part of each message.
NB: --delete2duplicates is far less violent than --delete2
since it removes only duplicates.
--delete2folders : Delete folders in host2 that are not in host1.
For safety, first try it like this, it is safe:
--delete2folders --dry --justfolders --nofoldersizes
and see what folders will be deleted.
--delete2foldersonly reg : Delete only folders matching the regex reg.
Example: --delete2foldersonly "/^Junk$|^INBOX.Junk$/"
This option activates --delete2folders
--delete2foldersbutnot reg : Do not delete folders matching the regex rex.
Example: --delete2foldersbutnot "/Tasks$|Contacts$|Foo$/"
This option activates --delete2folders
--noexpunge2 : Do not expunge messages on host2.
--nouidexpunge2 : Do not uidexpunge messages on the host2 account
that are not on the host1 account.
=head2 OPTIONS/dates
If you encounter problems with dates, see also:
https://imapsync.lamiral.info/FAQ.d/FAQ.Dates.txt
--syncinternaldates : Sets the internal dates on host2 as the same as host1.
Turned on by default. Internal date is the date
a message arrived on a host (Unix mtime usually).
--idatefromheader : Sets the internal dates on host2 as same as the
ones in "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.
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 (+ zone are the messages selected):
past|----maxage+++++++++++++++>now
past|+++++++++++++++minage---->now
past|----maxage+++++minage---->now (intersection)
past|++++minage-----maxage++++>now (union)
--search str : Selects only messages returned by this IMAP SEARCH
command. Applied on both sides.
For a complete set of what can be search see
https://imapsync.lamiral.info/FAQ.d/FAQ.Messages_Selection.txt
--search1 str : Same as --search but for selecting host1 messages only.
--search2 str : Same as --search but for selecting host2 messages only.
So --search CRIT equals --search1 CRIT --search2 CRIT
--noabletosearch : Makes --minage and --maxage options use the internal
dates given by a FETCH imap command instead of the
"Date:" header. Internal date is the arrival date
in the mailbox.
--noabletosearch equals --noabletosearch1 --noabletosearch2
--noabletosearch1 : Like --noabletosearch but for host1 only.
--noabletosearch2 : Like --noabletosearch but for host2 only.
--maxlinelength int : skip messages with a line length longer than int bytes.
RFC 2822 says it must be no more than 1000 bytes but
real life servers and email clients do more.
--useheader str : Use this header to compare messages on both sides.
Example: "Message-Id" or "Received" or "Date".
--useheader str and this one, etc.
--syncduplicates : Sync also duplicates. Off by default.
--usecache : Use cache to speed up next syncs. Off by default.
--nousecache : Do not use cache. Caveat: --useuid --nousecache creates
duplicates on multiple runs.
--useuid : Use UIDs instead of headers as a criterion to recognize
messages. Option --usecache is then implied unless
--nousecache is used.
=head2 OPTIONS/miscellaneous
--syncacls : Synchronizes acls (Access Control Lists).
Acls in IMAP are not standardized, be careful
since one acl code on one side may signify something
else on the other one.
--nosyncacls : Does not synchronize acls. This is the default.
--addheader : When a message has no headers to be identified,
--addheader adds a "Message-Id" header,
like "Message-Id: 12345@imapsync", where 12345
is the imap UID of the message on the host1 folder.
Useful to sync folders "Sent" or "Draft".
=head2 OPTIONS/debugging
--debug : Debug mode.
--debugfolders : Debug mode for the folders part only.
--debugcontent : Debug content of the messages transferred. Huge output.
--debugflags : Debug mode for flags.
--debugimap1 : IMAP debug mode for host1. Very verbose.
--debugimap2 : IMAP debug mode for host2. Very verbose.
--debugimap : IMAP debug mode for host1 and host2. Twice very verbose.
--debugmemory : Debug mode showing memory consumption after each copy.
--errorsmax int : Exit when int number of errors is reached. Default is 50.
--tests : Run local non-regression tests. Exit code 0 means all ok.
--testslive : Run a live test with test1.lamiral.info imap server.
Useful to check the basics. Needs internet connection.
--testslive6 : Run a live test with ks6ipv6.lamiral.info imap server.
Useful to check the ipv6 connectivity. Needs internet.
=head2 OPTIONS/specific
--gmail1 : sets --host1 to Gmail and other options. See FAQ.Gmail.txt
--gmail2 : sets --host2 to Gmail and other options. See FAQ.Gmail.txt
--office1 : sets --host1 to Office365 and other options. See FAQ.Office365.txt
--office2 : sets --host2 to Office365 and other options. See FAQ.Office365.txt
--exchange1 : sets options for Exchange. See FAQ.Exchange.txt
--exchange2 : sets options for Exchange. See FAQ.Exchange.txt
--domino1 : sets options for Domino. See FAQ.Domino.txt
--domino2 : sets options for Domino. See FAQ.Domino.txt
=head2 OPTIONS/behavior
--timeout1 flo : Connection timeout in seconds for host1.
Default is 120 and 0 means no timeout at all.
--timeout2 flo : Connection timeout in seconds for host2.
Default is 120 and 0 means no timeout at all.
Caveat, under CGI context, you may encounter a timeout
from the webserver, killing imapsync and the imap connections.
See the document INSTALL.OnlineUI.txt and search
for "Timeout" for how to deal with this issue.
--keepalive1 : https://metacpan.org/pod/Mail::IMAPClient#Keepalive
Some firewalls and network gears like to timeout connections
prematurely if the connection sits idle.
This option enables SO_KEEPALIVE on the host1 socket.
--keepalive1 is on by default since imapsync release 2.169
Use --nokeepalive1 to disable it.
--keepalive2 : Same as --keepalive2 but for host2.
Use --nokeepalive2 to disable it.
--maxmessagespersecond flo : limits the average number of messages
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 flo : 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 process to abort.
--exitwhenover int : Stop syncing and exits when int total bytes
transferred is reached.
--version : Print only the software version.
--noreleasecheck : Do not check for any new imapsync release.
--releasecheck : Check for new imapsync release.
it's an http request to
http://imapsync.lamiral.info/prj/imapsync/VERSION
--emailreport1 : Put the email final report in host1 INBOX
--emailreport2 : Put the email final report in host2 INBOX
--noemailreport1 : Do not put the email final report in host1 INBOX
--noemailreport2 : Do not put the email final report in host2 INBOX
--noid : Do not send/receive IMAP "ID" command to imap servers.
--justconnect : Just connect to both servers and print useful
information. Need only --host1 and --host2 options.
Obsolete since "imapsync --host1 imaphost" alone
implies --justconnect
--justlogin : Just login to both host1 and host2 with users
credentials, then exit.
--justfolders : Do only things about folders (ignore messages).
--help : print this help.
Example: to synchronize imap account "test1" on "test1.lamiral.info"
to imap account "test2" on "test2.lamiral.info"
with test1 password "secret1"
and test2 password "secret2"
imapsync \
--host1 test1.lamiral.info --user1 test1 --password1 secret1 \
--host2 test2.lamiral.info --user2 test2 --password2 secret2
=cut
# comment
=pod
=head1 SECURITY
You can use --passfile1 instead of --password1 to mention the password
since it is safer. With --password1 option, on Linux, any user on your
host can see the password by using the 'ps auxwwww' command. Using a
variable (like IMAPSYNC_PASSWORD1) is also dangerous because of the
'ps auxwwwwe' command. So, saving the password in a well protected
file (600 or rw-------) is the best solution.
Imapsync activates ssl or tls encryption by default, if possible.
What detailed behavior is under this "if possible"?
Imapsync activates ssl if the well known port imaps port (993) is open
on the imap servers. If the imaps port is closed then it open a normal
(clear) connection on port 143 but it looks for TLS support in the
CAPABILITY list of the servers. If TLS is supported then imapsync goes
to encryption with STARTTLS.
If the automatic ssl and the tls detections fail then imapsync will
not protect against sniffing activities on the network, especially for
passwords.
If you want to force ssl or tls just use --ssl1 --ssl2 or --tls1
--tls2
See also the document FAQ.Security.txt in the FAQ.d/ directory or at
https://imapsync.lamiral.info/FAQ.d/FAQ.Security.txt
=head1 EXIT STATUS
Imapsync will exit with a 0 status (return code) if everything went
good. Otherwise, it exits with a non-zero status. That's classical
Unix behavior. Here is the list of the exit code values (an integer
between 0 and 255). In Bourne Shells, this exit code value can be
retrieved within the variable value "$?" if you read it just after the
imapsync call.
The names reflect their meaning:
=for comment
egrep '^Readonly my.*\$EX' imapsync | egrep -o 'EX.*' | sed 's_^_ _'
EX_OK => 0 ; #/* successful termination */
EX_USAGE => 64 ; #/* command line usage error */
EX_NOINPUT => 66 ; #/* cannot open input */
EX_UNAVAILABLE => 69 ; #/* service unavailable */
EX_SOFTWARE => 70 ; #/* internal software error */
EXIT_CATCH_ALL => 1 ; # Any other error
EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num
EXIT_BY_FILE => 7 ;
EXIT_PID_FILE_ERROR => 8 ;
EXIT_CONNECTION_FAILURE => 10 ;
EXIT_TLS_FAILURE => 12 ;
EXIT_AUTHENTICATION_FAILURE => 16 ;
EXIT_SUBFOLDER1_NO_EXISTS => 21 ;
EXIT_WITH_ERRORS => 111 ;
EXIT_WITH_ERRORS_MAX => 112 ;
EXIT_OVERQUOTA => 113 ;
EXIT_ERR_APPEND => 114 ;
EXIT_ERR_FETCH => 115 ;
EXIT_ERR_CREATE => 116 ;
EXIT_ERR_SELECT => 117 ;
EXIT_TRANSFER_EXCEEDED => 118 ;
EXIT_ERR_APPEND_VIRUS => 119 ;
EXIT_TESTS_FAILED => 254 ; # Like Test::More API
EXIT_CONNECTION_FAILURE_HOST1 => 101 ;
EXIT_CONNECTION_FAILURE_HOST2 => 102 ;
EXIT_AUTHENTICATION_FAILURE_USER1 => 161 ;
EXIT_AUTHENTICATION_FAILURE_USER2 => 162 ;
=head1 LICENSE AND COPYRIGHT
Imapsync is free, open, public but not always gratis software cover by
the NOLIMIT Public License, now called NLPL. See the LICENSE file
included in the distribution or just read the following simple
sentence as it IS the license text:
"No limits to do anything with this work and this license."
In case it is not long enough, I repeat:
"No limits to do anything with this work and this license."
Look at https://imapsync.lamiral.info/LICENSE
=head1 AUTHOR
Gilles LAMIRAL <[email protected]>
Good feedback is always welcome.
Bad feedback is very often welcome.
Gilles LAMIRAL earns his living by writing, installing, configuring
and sometimes teaching free, open, and often gratis software. Imapsync
used to be "always gratis" but now it is only "often gratis" because
imapsync is sold by its author, your servitor, a good way to maintain
and support free open public software tools over decades.
=head1 BUGS AND LIMITATIONS
See https://imapsync.lamiral.info/FAQ.d/FAQ.Reporting_Bugs.txt
=head1 IMAP SERVERS supported
See https://imapsync.lamiral.info/S/imapservers.shtml
=head1 HUGE MIGRATION
If you have many mailboxes to migrate think about a little shell
program. Write a file called file.txt (for example) containing users
and passwords. The separator used in this example is ';'
The file.txt file contains:
user001_1;password001_1;user001_2;password001_2
user002_1;password002_1;user002_2;password002_2
user003_1;password003_1;user003_2;password003_2
user004_1;password004_1;user004_2;password004_2
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" \
--host2 imap.side2.org --user2 "$u2" --password2 "$p2" ...
done ; } < file.txt
On Windows the batch program can be:
FOR /F "tokens=1,2,3,4 delims=; eol=#" %%G IN (file.txt) DO imapsync ^
--host1 imap.side1.org --user1 %%G --password1 %%H ^
--host2 imap.side2.org --user2 %%I --password2 %%J ...
The ... have to be replaced by nothing or any imapsync option.
Welcome in shell or batch programming !
You will find already written scripts at
https://imapsync.lamiral.info/examples/
=head1 INSTALL
Imapsync works under any Unix with Perl.
Imapsync works under most Windows (2000, XP, Vista, Seven, Eight, Ten
and all Server releases 2000, 2003, 2008 and R2, 2012 and R2, 2016)
as a standalone binary software called imapsync.exe, usually launched
from a batch file in order to avoid always typing the options. There
is also a 32bit binary called imapsync_32bit.exe
Imapsync works under OS X as a standalone binary software called
imapsync_bin_Darwin
Purchase latest imapsync at
https://imapsync.lamiral.info/
You'll receive a link to a compressed tarball called
imapsync-x.xx.tgz where x.xx is the version number.
Untar the tarball where you want (on Unix):
tar xzvf imapsync-x.xx.tgz
Go into the directory imapsync-x.xx and read the INSTALL file.
As mentioned at https://imapsync.lamiral.info/#install
the INSTALL file can also be found at
https://imapsync.lamiral.info/INSTALL.d/INSTALL.ANY.txt
It is now split in several files for each system
https://imapsync.lamiral.info/INSTALL.d/
=head1 CONFIGURATION
There is no specific configuration file for imapsync, everything is
specified by the command line parameters and the default behavior.
=head1 HACKING
Feel free to hack imapsync as the NOLIMIT license permits it.
=head1 SIMILAR SOFTWARE
See also https://imapsync.lamiral.info/S/external.shtml
for a better up to date list.
List verified on Friday July 1, 2021.
imapsync: https://github.com/imapsync/imapsync (this is an imapsync copy, sometimes delayed, with --noreleasecheck by default since release 1.592, 2014/05/22)
imap_tools: https://web.archive.org/web/20161228145952/http://www.athensfbc.com/imap_tools/. The imap_tools code is now at https://github.com/andrewnimmo/rick-sanders-imap-tools
imaputils: https://github.com/mtsatsenko/imaputils (very old imap_tools fork)
Doveadm-Sync: https://wiki2.dovecot.org/Tools/Doveadm/Sync ( Dovecot sync tool )
davmail: http://davmail.sourceforge.net/
offlineimap: http://offlineimap.org/
fdm: https://github.com/nicm/fdm
mbsync: http://isync.sourceforge.net/
mailsync: http://mailsync.sourceforge.net/
mailutil: https://www.washington.edu/imap/ part of the UW IMAP toolkit. (well, seems abandoned now)
imaprepl: https://bl0rg.net/software/ http://freecode.com/projects/imap-repl/
imapcopy (Pascal): http://www.ardiehl.de/imapcopy/
imapcopy (Java): https://code.google.com/archive/p/imapcopy/
imapsize: http://www.broobles.com/imapsize/
migrationtool: http://sourceforge.net/projects/migrationtool/
imapmigrate: http://sourceforge.net/projects/cyrus-utils/
larch: https://github.com/rgrove/larch (derived from wonko_imapsync, good at Gmail)
wonko_imapsync: http://wonko.com/article/554 (superseded by larch)
pop2imap: http://www.linux-france.org/prj/pop2imap/ (I wrote that too)
exchange-away: http://exchange-away.sourceforge.net/
SyncBackPro: http://www.2brightsparks.com/syncback/sbpro.html
ImapSyncClient: https://github.com/ridaamirini/ImapSyncClient
MailStore: https://www.mailstore.com/en/products/mailstore-home/
mnIMAPSync: https://github.com/manusa/mnIMAPSync
imap-upload: http://imap-upload.sourceforge.net/ (A tool for uploading a local mbox file to IMAP4 server)
imapbackup: https://github.com/rcarmo/imapbackup (A Python script for incremental backups of IMAP mailboxes)
BitRecover email-backup 99 USD, 299 USD https://www.bitrecover.com/email-backup/.
ImportExportTools: https://addons.thunderbird.net/en-us/thunderbird/addon/importexporttools/ ImportExportTools for Mozilla Thunderbird by Paolo Kaosmos. ImportExportTools does not do IMAP.
rximapmail: https://sourceforge.net/projects/rximapmail/
CodeTwo: https://www.codetwo.com/ but CodeTwo does imap source to Office365 only.
=head1 HISTORY
I initially wrote imapsync in July 2001 because an enterprise, called
BaSystemes, paid me to install a new imap server without losing huge
old mailboxes located in a far away remote imap server, accessible by
an often broken low-bandwidth ISDN link.
I had to verify every mailbox was well transferred, all folders, all
messages, without wasting bandwidth or creating duplicates upon
resyncs. The imapsync design was made with the beautiful rsync command
in mind.
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).
So many changes happened since then that I wonder if it remains any
lines of the original copy_folder.pl in imapsync source code.
=cut
# use pragmas
#
use strict ;
use warnings ;
use Carp ;
use Cwd ;
use Compress::Zlib ;
use Data::Dumper ;
use Digest::HMAC_SHA1 qw( hmac_sha1 hmac_sha1_hex ) ;
use Digest::MD5 qw( md5 md5_hex md5_base64 ) ;
use Encode ;
use Encode::IMAPUTF7 ;
use English qw( -no_match_vars ) ;
use Errno qw(EAGAIN EPIPE ECONNRESET) ;
use Fcntl ;
use File::Basename ;
use File::Copy::Recursive ;
use File::Glob qw( :glob ) ;
use File::Path qw( mkpath rmtree ) ;
use File::Spec ;
use File::stat ;
use Getopt::Long ( ) ;
use IO::File ;
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 locale ;
use Mail::IMAPClient 3.30 ;
use MIME::Base64 ;
use Pod::Usage qw(pod2usage) ;
use POSIX qw( uname SIGALRM :sys_wait_h ) ;
use Sys::Hostname ;
use Term::ReadKey ;
use Test::More ;
use Time::HiRes qw( time sleep ) ;
use Time::Local ;
use Unicode::String ;
use Readonly ;
use Sys::MemInfo ;
use Regexp::Common ;
use Text::ParseWords ; # for quotewords()
use File::Tail ;
local $OUTPUT_AUTOFLUSH = 1 ;
# constants
# Let us do like sysexits.h
# /usr/include/sysexits.h
# and https://www.tldp.org/LDP/abs/html/exitcodes.html
# Should avoid 2 126 127 128..128+64=192 255
# Should use 0 1 3..125 193..254
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_NOUSER => 67 ; #/* addressee unknown */
#Readonly my $EX_NOHOST => 68 ; #/* host name unknown */
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 */
#Readonly my $EX_CANTCREAT => 73 ; #/* can't create (user) output file */
#Readonly my $EX_IOERR => 74 ; #/* input/output error */
#Readonly my $EX_TEMPFAIL => 75 ; #/* temp failure; user is invited to retry */
#Readonly my $EX_PROTOCOL => 76 ; #/* remote error in protocol */
#Readonly my $EX_NOPERM => 77 ; #/* permission denied */
#Readonly my $EX_CONFIG => 78 ; #/* configuration error */
# Mine
Readonly my $EXIT_CATCH_ALL => 1 ; # Any other error
Readonly my $EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num
Readonly my $EXIT_BY_FILE => 7 ;
Readonly my $EXIT_PID_FILE_ERROR => 8 ;
Readonly my $EXIT_CONNECTION_FAILURE => 10 ;
Readonly my $EXIT_TLS_FAILURE => 12 ;
Readonly my $EXIT_AUTHENTICATION_FAILURE => 16 ;
Readonly my $EXIT_SUBFOLDER1_NO_EXISTS => 21 ;
Readonly my $EXIT_WITH_ERRORS => 111 ;
Readonly my $EXIT_WITH_ERRORS_MAX => 112 ;
Readonly my $EXIT_OVERQUOTA => 113 ;
Readonly my $EXIT_ERR_APPEND => 114 ;
Readonly my $EXIT_ERR_FETCH => 115 ;
Readonly my $EXIT_ERR_CREATE => 116 ;
Readonly my $EXIT_ERR_SELECT => 117 ;
Readonly my $EXIT_TRANSFER_EXCEEDED => 118 ;
Readonly my $EXIT_ERR_APPEND_VIRUS => 119 ;
Readonly my $EXIT_ERR_FLAGS => 120 ;
Readonly my $EXIT_TESTS_FAILED => 254 ; # Like Test::More API
Readonly my $EXIT_CONNECTION_FAILURE_HOST1 => 101 ;
Readonly my $EXIT_CONNECTION_FAILURE_HOST2 => 102 ;
Readonly my $EXIT_AUTHENTICATION_FAILURE_USER1 => 161 ;
Readonly my $EXIT_AUTHENTICATION_FAILURE_USER2 => 162 ;
Readonly my %EXIT_TXT => (
$EX_OK => 'EX_OK: successful termination',
$EX_USAGE => 'EX_USAGE: command line usage error',
$EX_NOINPUT => 'EX_NOINPUT: cannot open input',
$EX_UNAVAILABLE => 'EX_UNAVAILABLE: service unavailable',
$EX_SOFTWARE => 'EX_SOFTWARE: internal software error',
$EXIT_CATCH_ALL => 'EXIT_CATCH_ALL',
$EXIT_BY_SIGNAL => 'EXIT_BY_SIGNAL',
$EXIT_BY_FILE => 'EXIT_BY_FILE',
$EXIT_PID_FILE_ERROR => 'EXIT_PID_FILE_ERROR' ,
$EXIT_CONNECTION_FAILURE => 'EXIT_CONNECTION_FAILURE',
$EXIT_TLS_FAILURE => 'EXIT_TLS_FAILURE',
$EXIT_AUTHENTICATION_FAILURE => 'EXIT_AUTHENTICATION_FAILURE',
$EXIT_SUBFOLDER1_NO_EXISTS => 'EXIT_SUBFOLDER1_NO_EXISTS',
$EXIT_WITH_ERRORS => 'EXIT_WITH_ERRORS',
$EXIT_WITH_ERRORS_MAX => 'EXIT_WITH_ERRORS_MAX',
$EXIT_OVERQUOTA => 'EXIT_OVERQUOTA',
$EXIT_ERR_APPEND => 'EXIT_ERR_APPEND',
$EXIT_ERR_APPEND_VIRUS => 'EXIT_ERR_APPEND_VIRUS',
$EXIT_ERR_FETCH => 'EXIT_ERR_FETCH',
$EXIT_ERR_FLAGS => 'EXIT_ERR_FLAGS',
$EXIT_ERR_CREATE => 'EXIT_ERR_CREATE',
$EXIT_ERR_SELECT => 'EXIT_ERR_SELECT',
$EXIT_TESTS_FAILED => 'EXIT_TESTS_FAILED',
$EXIT_TRANSFER_EXCEEDED => 'EXIT_TRANSFER_EXCEEDED',
$EXIT_CONNECTION_FAILURE_HOST1 => 'EXIT_CONNECTION_FAILURE_HOST1',
$EXIT_CONNECTION_FAILURE_HOST2 => 'EXIT_CONNECTION_FAILURE_HOST2',
$EXIT_AUTHENTICATION_FAILURE_USER1 => 'EXIT_AUTHENTICATION_FAILURE_USER1',
$EXIT_AUTHENTICATION_FAILURE_USER2 => 'EXIT_AUTHENTICATION_FAILURE_USER2',
) ;
Readonly my %EXIT_VALUE_OF_ERR_TYPE => (
ERR_APPEND_SIZE => $EXIT_ERR_APPEND,
ERR_OVERQUOTA => $EXIT_OVERQUOTA,
ERR_APPEND => $EXIT_ERR_APPEND,
ERR_APPEND_VIRUS => $EXIT_ERR_APPEND_VIRUS,
ERR_CREATE => $EXIT_ERR_CREATE,
ERR_SELECT => $EXIT_ERR_SELECT,
ERR_Host1_FETCH => $EXIT_ERR_FETCH,
ERR_FLAGS => $EXIT_ERR_FLAGS,
ERR_UNCLASSIFIED => $EXIT_WITH_ERRORS,
ERR_NOTHING_REPORTED => $EXIT_WITH_ERRORS,
ERR_TRANSFER_EXCEEDED => $EXIT_TRANSFER_EXCEEDED,
ERR_CONNECTION_FAILURE_HOST1 => $EXIT_CONNECTION_FAILURE_HOST1,
ERR_CONNECTION_FAILURE_HOST2 => $EXIT_CONNECTION_FAILURE_HOST2,
ERR_AUTHENTICATION_FAILURE_USER1 => $EXIT_AUTHENTICATION_FAILURE_USER1,
ERR_AUTHENTICATION_FAILURE_USER2 => $EXIT_AUTHENTICATION_FAILURE_USER2,
ERR_EXIT_TLS_FAILURE => $EXIT_TLS_FAILURE,
) ;
Readonly my %COMMENT_OF_ERR_TYPE => (
ERR_APPEND_SIZE => \&comment_err_append_size,
ERR_OVERQUOTA => \&comment_err_overquota,
ERR_APPEND => \&comment_err_blank,
ERR_APPEND_VIRUS => \&comment_err_blank,
ERR_CREATE => \&comment_err_blank,
ERR_SELECT => \&comment_err_blank,
ERR_Host1_FETCH => \&comment_err_blank,
ERR_FLAGS => \&comment_err_flags,
ERR_UNCLASSIFIED => \&comment_err_blank,
ERR_NOTHING_REPORTED => \&comment_err_blank,
ERR_TRANSFER_EXCEEDED => \&comment_err_transfer_exceeded,
ERR_CONNECTION_FAILURE_HOST1 => \&comment_err_connection_failure_host1,
ERR_CONNECTION_FAILURE_HOST2 => \&comment_err_connection_failure_host2,
ERR_AUTHENTICATION_FAILURE_USER1 => \&comment_err_authentication_failure_host1,
ERR_AUTHENTICATION_FAILURE_USER2 => \&comment_err_authentication_failure_host2,
ERR_EXIT_TLS_FAILURE => \&comment_err_blank,
) ;
sub comment_err_blank
{
return '' ;
}
sub comment_err_append_size
{
my $mysync = shift @ARG ;
my $comment = "The destination server refuses too big messages. Use --truncmess option. Read https://imapsync.lamiral.info/FAQ.d/FAQ.Messages_Too_Big.txt" ;
return $comment ;
}
sub comment_err_authentication_failure_host1
{
my $mysync = shift @ARG ;
my $comment = "Check the credentials for $mysync->{ user1 }." ;
return $comment ;
}
sub comment_err_authentication_failure_host2
{
my $mysync = shift @ARG ;
my $comment = "Check the credentials for $mysync->{ user2 }." ;
return $comment ;
}
sub comment_err_connection_failure_host1
{
my $mysync = shift @ARG ;
my $comment = "Check that host1 $mysync->{ host1 } on port $mysync->{ port1 } is the right IMAP server to be contacted for your mailbox." ;
return $comment ;
}
sub comment_err_connection_failure_host2
{
my $mysync = shift @ARG ;
my $comment = "Check that host1 $mysync->{ host2 } on port $mysync->{ port2 } is the right IMAP server to be contacted for your mailbox." ;
return $comment ;
}
sub comment_err_overquota
{
my $mysync = shift @ARG ;
my $comment = 'The destination mailbox is 100% full, get free space on it and then resume the sync.' ;
return $comment ;
}
sub comment_err_transfer_exceeded
{
my $mysync = shift @ARG ;
my $size_limit_human = bytes_display_string_dec( $mysync->{ exitwhenover } ) ;
my $comment = "The maximum transfer size for a single sync is reached ( over $size_limit_human ). Relaunch the sync to sync more." ;
return $comment ;
}
sub comment_err_flags
{
my $mysync = shift @ARG ;
my $comment = 'Many STORE errors with FLAGS. Retry with the option --noresyncflags' ;
return $comment ;
}
Readonly my $DEFAULT_LOGDIR => 'LOG_imapsync' ;
Readonly my $ERRORS_MAX => 50 ; # exit after 50 errors.
Readonly my $ERRORS_MAX_CGI => 500 ; # exit after 500 errors in CGI context.
Readonly my $INTERVAL_TO_EXIT => 2 ; # interval max to exit instead of reconnect
Readonly my $SPLIT => 100 ; # By default, 100 at a time, not more.
Readonly my $SPLIT_FACTOR => 10 ; # init_imap() calls Maxcommandlength( $SPLIT_FACTOR * $split )
# which means default Maxcommandlength is 10*100 = 1000 characters ;
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 $MINUS_TWO => -2 ;
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_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 ;
Readonly my $KIBI => 1024 ;
Readonly my $NUMBER_10 => 10 ;
Readonly my $NUMBER_42 => 42 ;
Readonly my $NUMBER_100 => 100 ;
Readonly my $NUMBER_200 => 200 ;
Readonly my $NUMBER_300 => 300 ;
Readonly my $NUMBER_123456 => 123_456 ;
Readonly my $NUMBER_654321 => 654_321 ;
Readonly my $NUMBER_20_000 => 20_000 ;
Readonly my $QUOTA_PERCENT_LIMIT => 90 ;
Readonly my $NUMBER_104_857_600 => 104_857_600 ;
Readonly my $SIZE_MAX_STR => 64 ;
Readonly my $NB_SECONDS_IN_A_DAY => 86_400 ;
Readonly my $STD_CHAR_PER_LINE => 80 ;
Readonly my $TRUE => 1 ;
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' ;
Readonly my $STR_use_releasecheck => q{Check if a new imapsync release is available by adding --releasecheck} ;
Readonly my $GMAIL_MAXSIZE => 35_651_584 ;
Readonly my $FORCE => 1 ;
# if ( 'MSWin32' eq $OSNAME )
# if ( 'darwin' eq $OSNAME )
# if ( 'linux' eq $OSNAME )
# global variables
# Currently working to finish with only $sync, $acc1, $acc2
# Not finished yet...
my(
$sync, $acc1, $acc2,
$debugdev, $debugmaxlinelength, $debugcgi,
@include, @exclude, @folderrec,
@folderfirst, @folderlast,
@h1_folders_all, %h1_folders_all,
@h2_folders_all, %h2_folders_all,
@h2_folders_from_1_wanted, %h2_folders_from_1_all,
%requested_folder,
$h1_folders_wanted_nb, $h1_folders_wanted_ct,
@h2_folders_not_in_1,
%h1_subscribed_folder, %h2_subscribed_folder,
%h2_folders_from_1_wanted,
%h2_folders_from_1_several,
$prefix1, $prefix2,
@regexmess, @skipmess, @pipemess, $pipemesscheck,
$syncflagsaftercopy,
$syncinternaldates,
$idatefromheader,
$minsize, $maxage, $minage,
$search,
@useheader, %useheader,
$skipsize, $allowsizemismatch, $buffersize,
$authmd5, $authmd51, $authmd52,
$subscribed, $subscribe, $subscribeall,
$help,
$nb_msg_skipped_dry_mode,
$h2_nb_msg_noheader,
$h1_bytes_processed,
$h1_nb_msg_end, $h1_bytes_end,
$h2_nb_msg_end, $h2_bytes_end,
$timestart_int,
$uid1, $uid2,
$split1, $split2,
$modulesversion,
$delete2folders, $delete2foldersonly, $delete2foldersbutnot,
$debugcache, $cacheaftercopy,
$wholeheaderifneeded, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess,
$checkmessageexists,
$messageidnodomain,
$fixInboxINBOX,
$maxlinelength, $maxlinelengthcmd,
$minmaxlinelength,
$fixcolonbug,
$create_folder_old,
$disarmreadreceipts,
$mixfolders,
$fetch_hash_set,
$cgidir,
%month_abrev,
$SSL_VERIFY_POLICY,
) ;
exit( single_sync( $sync, $acc1, $acc2 ) ) ;
sub single_sync
{
# main program
# global variables initialization
# I'm currently removing all global variables except $sync $acc1 $acc2
# passing each of them under
# $sync->{variable_name}
# or $acc1->{variable_name}
# or $acc1->{variable_name}
#
$acc1 = {} ;
$acc2 = {} ;
$sync->{ acc1 } = $acc1 ;
$sync->{ acc2 } = $acc2 ;
$acc1->{ Side } = 'Host1' ;
$acc2->{ Side } = 'Host2' ;
$acc1->{ N } = '1' ;
$acc2->{ N } = '2' ;
$sync->{timestart} = time ; # Is a float because of use Time::HiRres
$sync->{rcs} = q{$Id: imapsync,v 2.229 2022/09/14 18:08:24 gilles Exp gilles $} ;
$sync->{ memory_consumption_at_start } = memory_consumption_of_myself( ) || 0 ;
my @loadavg = loadavg( ) ;
$sync->{ total_bytes_transferred } = 0 ;
$sync->{ total_bytes_skipped } = 0 ;
$sync->{ nb_msg_transferred } = 0 ;
$sync->{ nb_msg_skipped } = $nb_msg_skipped_dry_mode = 0 ;
$sync->{ acc1 }->{ nb_msg_deleted } = 0 ;
$sync->{ acc2 }->{ nb_msg_deleted } = 0 ;
$sync->{ acc1 }->{ nb_msg_duplicate } = 0 ;
$sync->{ acc2 }->{ nb_msg_duplicate } = 0 ;
$sync->{ h1_nb_msg_noheader } = 0 ;
$h2_nb_msg_noheader = 0 ;
$sync->{ h1_nb_msg_start } = 0 ;
$sync->{ h1_bytes_start } = 0 ;
$sync->{ h2_nb_msg_start } = 0 ;
$sync->{ h2_bytes_start } = 0 ;
$sync->{ h1_nb_msg_processed } = $h1_bytes_processed = 0 ;
$sync->{ h2_nb_msg_crossdup } = 0 ;
#$h1_nb_msg_end = $h1_bytes_end = 0 ;
#$h2_nb_msg_end = $h2_bytes_end = 0 ;
$sync->{ nb_errors } = 0;
$sync->{ biggest_message_transferred } = 0;
%month_abrev = (
Jan => '00',
Feb => '01',
Mar => '02',
Apr => '03',
May => '04',
Jun => '05',
Jul => '06',
Aug => '07',
Sep => '08',
Oct => '09',
Nov => '10',
Dec => '11',
);
# Just create a CGI object if under cgi context only.
# Needed for the get_options() call
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 ) ;
$sync->{ cpu_number } = cpu_number( ) ;
$sync->{ heavy_load_reached } = heavy_load_reached( $sync ) ;
$sync->{ loadavg } = join( q{ }, $loadavg[ 0 ] )
. " on $sync->{cpu_number} cores and "
. ram_memory_info( $sync ) ;
# Is it the first myprint?
cgibuildheader( $sync ) ;
docker_context( $sync ) ;
print_output_if_needed( $sync ) ;
output_reset_with( $sync ) ;
# don't go on if options are not all known.
if ( ! defined $options_good ) { exit $EX_USAGE ; }
# If you want releasecheck not to be done by default (like the github maintainer),
# then just uncomment the first "$sync->{releasecheck} =" line, the line ending with "0 ;",
# the second line (ending with "1 ;") can then stay active or be commented,
# the result will be the same: no releasecheck by default (because 0 is then the defined value).
$sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 0 ;
#$sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 1 ;
# just the version
if ( $sync->{ version } ) {
myprint( imapsync_version( $sync ), "\n" ) ;
return 0 ;
}
#$sync->{debugenv} = 1 ;
$sync->{debugenv} and printenv( $sync ) ; # if option --debugenv
load_modules( ) ;
# after_get_options call usage and exit if --help or options were not well got
after_get_options( $sync, $options_good ) ;
#local $ENV{TZ} = 'GMT' if ( under_cgi_context( $sync ) and 'MSWin32' ne $OSNAME ) ;
#output( $sync, localtime(time) . " " . gmtime(time) . "\n" ) ;
make_var_array_to_a_hash( $sync ) ;
# Under CGI environment, fix caveat emptor potential issues
cgisetcontext( $sync ) ;
get_options_extra( $sync ) ;
# --gmail --gmail --exchange --office etc.
easyany( $sync ) ;
$sync->{ sanitize } = defined $sync->{ sanitize } ? $sync->{ sanitize } : 1 ;
sanitize( $sync ) ;
$sync->{ tmpdir } ||= File::Spec->tmpdir( ) ;
# Unit tests
my $unittestssuite = unittestssuite( $sync ) ;
if ( condition_to_leave_after_tests( $sync ) )
{
return $unittestssuite ;
}
# init live varaiables
if ( $sync->{ testslive } )
{
testslive_init( $sync ) ;
}
if ( $sync->{ testslive6 } )
{
testslive6_init( $sync ) ;
}
define_pidfile( $sync ) ;
if ( $sync->{ abortbyfile } ) { $sync->{ abort } = 1 ; }
install_signals( $sync ) ;
$sync->{ loglogfilename } = '../list_all_logs_auto.txt' ;
$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->{ emailreport1 } = defined $sync->{ emailreport1 } ? $sync->{ emailreport1 } : 0 ;
$sync->{ emailreport2 } = defined $sync->{ emailreport2 } ? $sync->{ emailreport2 } : 0 ;
# log and output
binmode STDOUT, ":encoding(UTF-8)" ;
if ( $sync->{ log } ) {
$sync->{ logdir } = setlogdir( $sync ) ;
$sync->{ logfile } = setlogfile( $sync, $sync->{ logfile } ) ;
$sync->{ tee } = teelaunch( $sync, $sync->{ logfile } ) ;
# now $sync->{tee} is a filehandle to STDOUT and the logfile
}
#binmode STDERR, ":encoding(UTF-8)" ;
# STDERR goes to the same place: LOG and STDOUT if logging is on
# or just STDOUT
#
stderr_to_stdout( $sync ) ;
if ( usecache_and_skipcrossduplicates( $sync ) )
{
$sync->{ nb_errors }++ ;
exit_clean( $sync, $EX_USAGE, "Error: can not have both --usecache and --skipcrossduplicates\n" ) ;
}
$timestart_int = int( $sync->{timestart} ) ;
$sync->{timebefore} = $sync->{timestart} ;
$sync->{ timestart_str } = localtimez( $sync->{timestart} ) ;
# The prints in the log starts here
myprint( localhost_info( $sync ), "\n" ) ;
myprint( "Transfer started at $sync->{ timestart_str }\n" ) ;
myprint( "PID is $PROCESS_ID my PPID is ", mygetppid( ), "\n" ) ;
announcelogfile( $sync ) ;
myprint( "Load is " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $sync->{cpu_number} cores\n" ) ;
#myprintf( "Memory consumption so far: %.1f MiB\n", memory_consumption_of_myself( ) / $KIBI / $KIBI ) ;
myprint( 'Current directory is ' . getcwd( ) . "\n" ) ;
myprint( 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ;
myprint( 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ;
$modulesversion = defined $modulesversion ? $modulesversion : 1 ;
$sync->{ warn_release } = ( $sync->{ releasecheck } ) ? check_last_release( ) : $STR_use_releasecheck ;
$wholeheaderifneeded = defined $wholeheaderifneeded ? $wholeheaderifneeded : 1;
# Activate --usecache if --useuid is set and there is no --nousecache
$sync->{ usecache } = 1 if ( $useuid and ( ! defined $sync->{ usecache } ) ) ;
$cacheaftercopy = 1 if ( $sync->{ usecache } and ( ! defined $cacheaftercopy ) ) ;
$sync->{ checkfoldersexist } = defined $sync->{ checkfoldersexist } ? $sync->{ checkfoldersexist } : 1 ;
$checkmessageexists = defined $checkmessageexists ? $checkmessageexists : 0 ;
$sync->{ expungeaftereach } = defined $sync->{ expungeaftereach } ? $sync->{ expungeaftereach } : 1 ;
# abletosearch is on by default
$sync->{abletosearch} = defined $sync->{abletosearch} ? $sync->{abletosearch} : 1 ;
$sync->{abletosearch1} = defined $sync->{abletosearch1} ? $sync->{abletosearch1} : $sync->{abletosearch} ;
$sync->{abletosearch2} = defined $sync->{abletosearch2} ? $sync->{abletosearch2} : $sync->{abletosearch} ;
$checkmessageexists = 0 if ( not $sync->{abletosearch1} ) ;
$sync->{ trylogin } = defined $sync->{ trylogin } ? $sync->{ trylogin } : 1 ;
$sync->{showpasswords} = defined $sync->{showpasswords} ? $sync->{showpasswords} : 0 ;
$sync->{ fixslash2 } = defined $sync->{ fixslash2 } ? $sync->{ fixslash2 } : 1 ;
$fixInboxINBOX = defined $fixInboxINBOX ? $fixInboxINBOX : 1 ;
$create_folder_old = defined $create_folder_old ? $create_folder_old : 0 ;
$mixfolders = defined $mixfolders ? $mixfolders : 1 ;
$sync->{automap} = defined $sync->{automap} ? $sync->{automap} : 0 ;
$sync->{ delete2duplicates } = determine_delete2duplicates( $sync ) ;
$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( $sync, @ARGV ) ) ;
myprint( "Temp directory is $sync->{ tmpdir } ( to change it use --tmpdir dirpath )\n" ) ;
myprint( output( $sync ) ) ;
output_reset_with( $sync ) ;
do_valid_directory( $sync->{ tmpdir } ) || croak "Error creating tmpdir $sync->{ tmpdir } : $OS_ERROR" ;
remove_pidfile_not_running( $sync->{ pidfile } ) ;
# if another imapsync is running then tail -f its logfile and exit
# useful in cgi context
if ( $sync->{ tail } and tail( $sync ) )
{
exit_clean( $sync, $EX_OK, "Tail -f finished. Now finishing myself processus $PROCESS_ID\n" ) ;
exit $EX_OK ;
}
if ( ! write_pidfile( $sync ) ) {
myprint( "Exiting with return value $EXIT_PID_FILE_ERROR ($EXIT_TXT{$EXIT_PID_FILE_ERROR}) $sync->{nb_errors}/$sync->{errorsmax} nb_errors/max_errors PID $PROCESS_ID\n" ) ;
exit $EXIT_PID_FILE_ERROR ;
}
# New place for abort
# abort before simulong in order to be able to abort a simulong sync
if ( $sync->{ abort } )
{
abort( $sync ) ;
# well, the abort job is done, because even when not succeeded
# in aborting another run, this run has to end without doing any
# thing else
exit $EX_OK ;
}
if ( $sync->{ memorystress } ) { tests_memory_stress() ; }
# simulong is just a loop printing some lines for xx seconds with option "--simulong xx".
simulong( $sync ) ;
# New place for cgi_exit_on_heavy_load 2019_03_03
# because I want to log it
# Can break here if load is too heavy
# Have in mind the CGI header has already a 503 Service Unavailable printed.
cgi_exit_on_heavy_load( $sync ) ;
$fixcolonbug = defined $fixcolonbug ? $fixcolonbug : 1 ;
if ( $sync->{ usecache } and $fixcolonbug ) { tmpdir_fix_colon_bug( $sync ) } ;
$modulesversion and myprint( "Modules version list ( use --no-modulesversion to turn off printing this Perl modules list ):\n", modulesversion(), "\n" ) ;
check_lib_version( $sync ) or
croak "imapsync needs perl lib Mail::IMAPClient release 3.30 or superior.\n";
if ( $sync->{ justbanner } )
{
myprint( "Exiting because of --justbanner\n" ) ;
exit_clean( $sync, $EX_OK ) ;
}
# turn on RFC standard flags correction like \SEEN -> \Seen
$sync->{ flagscase } = defined $sync->{ flagscase } ? $sync->{ flagscase } : 1 ;
# Use PERMANENTFLAGS if available
$sync->{ filterflags } = defined $sync->{ filterflags } ? $sync->{ filterflags } : 1 ;
filterbuggyflags( $sync ) ;
# sync flags just after an APPEND, some servers ignore the flags given in the APPEND
# like MailEnable IMAP server.
# Off by default since it takes time.
$syncflagsaftercopy = defined $syncflagsaftercopy ? $syncflagsaftercopy : 0 ;
# update flags on host2 for already transferred messages
$sync->{resyncflags} = defined $sync->{resyncflags} ? $sync->{resyncflags} : 1 ;
if ( $sync->{resyncflags} ) {
myprint( "Info: will resync flags for already transferred messages. Use --noresyncflags to not resync flags.\n" ) ;
}else{
myprint( "Info: will not resync flags for already transferred messages. Use --resyncflags to resync flags.\n" ) ;
}
sslcheck( $sync ) ;
#print Data::Dumper->Dump( [ \$sync ] ) ;
$split1 ||= $SPLIT ;
$split2 ||= $SPLIT ;
#$sync->{host1} || missing_option( $sync, '--host1' ) ;
$sync->{host1} = sanitize_host( $sync->{host1} ) ;
$sync->{port1} ||= ( $sync->{ssl1} ) ? $IMAP_SSL_PORT : $IMAP_PORT ;
#$sync->{host2} || missing_option( $sync, '--host2' ) ;
$sync->{host2} = sanitize_host( $sync->{host2} ) ;
$sync->{port2} ||= ( $sync->{ssl2} ) ? $IMAP_SSL_PORT : $IMAP_PORT ;
$acc1->{ debugimap } = $acc2->{ debugimap } = 1 if ( $sync->{ debugimap } ) ;
# Set on debug mode if one of the imap dialogs are in debug.
# imap dialog without the debug mode is scary and useless.
$sync->{ debug } = 1 if ( $acc1->{ debugimap } or $acc2->{ debugimap } ) ;
# By default, don't take size to compare
$skipsize = (defined $skipsize) ? $skipsize : 1;
$uid1 = defined $uid1 ? $uid1 : 1;
$uid2 = defined $uid2 ? $uid2 : 1;
$subscribe = defined $subscribe ? $subscribe : 1;
# Allow size mismatch by default
$allowsizemismatch = defined $allowsizemismatch ? $allowsizemismatch : 1;
if ( defined $delete2foldersbutnot or defined $delete2foldersonly ) {
$delete2folders = 1 ;
}
my %SSL_VERIFY_STR ;
Readonly $SSL_VERIFY_POLICY => IO::Socket::SSL::SSL_VERIFY_NONE( ) ;
Readonly %SSL_VERIFY_STR => (
IO::Socket::SSL::SSL_VERIFY_NONE( ) => 'SSL_VERIFY_NONE, ie, do not check the server certificate.' ,
IO::Socket::SSL::SSL_VERIFY_PEER( ) => 'SSL_VERIFY_PEER, ie, check the server certificate.' ,
) ;
$IO::Socket::SSL::DEBUG = defined( $sync->{debugssl} ) ? $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( qq{Host1: SSL default mode is like --sslargs1 "SSL_verify_mode=$SSL_VERIFY_POLICY", meaning for host1 $SSL_VERIFY_STR{$SSL_VERIFY_POLICY}\n} ) ;
myprint( 'Host1: Use --sslargs1 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " to have $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} of host1\n" ) ;
# $sync->{ acc1 }->{sslargs}->{SSL_verify_mode}
}
if ( $sync->{ssl2} ) {
myprint( qq{Host2: SSL default mode is like --sslargs2 "SSL_verify_mode=$SSL_VERIFY_POLICY", meaning for host2 $SSL_VERIFY_STR{$SSL_VERIFY_POLICY}\n} ) ;
myprint( 'Host2: Use --sslargs2 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " to have $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} of host2\n" ) ;
}
# ID on by default since 1.832
$sync->{id} = defined $sync->{id} ? $sync->{id} : 1 ;
if ( $sync->{justconnect}
or not $sync->{user1}
or not $sync->{user2}
or not $sync->{host1}
or not $sync->{host2}
)
{
my $justconnect = justconnect( $sync ) ;
myprint( debugmemory( $sync, " after justconnect() call" ) ) ;
exit_clean( $sync, $EX_OK,
"Exiting after a justconnect on host(s): $justconnect\n"
) ;
}
#$sync->{user1} || missing_option( $sync, '--user1' ) ;
#$sync->{user2} || missing_option( $sync, '--user2' ) ;
$syncinternaldates = defined $syncinternaldates ? $syncinternaldates : 1;
# Turn on expunge if there is not explicit option --noexpunge1 and option
# --delete1 is given.
# Done because --delete1 --noexpunge1 is very dangerous on the second run:
# the Deleted flag is then synced to all previously transferred messages.
# So --delete1 implies --expunge1 is a better usability default behavior.
if ( $sync->{ delete1 } ) {
if ( ! defined $sync->{ expunge1 } ) {
myprint( "Info: turning on --expunge1 because --delete1 --noexpunge1 is very dangerous on the second run.\n" ) ;
$sync->{ expunge1 } = 1 ;
}
myprint( "Info: if expunging after each message slows down too much the sync then use --noexpungeaftereach to speed up\n" ) ;
}
if ( $sync->{ uidexpunge2 } and not Mail::IMAPClient->can( 'uidexpunge' ) ) {
myprint( "Failure: uidexpunge not supported (IMAPClient release < 3.17), use nothing or --expunge2 instead\n" ) ;
$sync->{nb_errors}++ ;
exit_clean( $sync, $EX_SOFTWARE ) ;
}
if ( ( $sync->{ delete2 } or $sync->{ delete2duplicates } ) and not defined $sync->{ uidexpunge2 } ) {
if ( Mail::IMAPClient->can( 'uidexpunge' ) ) {
myprint( "Info: will act as --uidexpunge2\n" ) ;
$sync->{ uidexpunge2 } = 1 ;
}elsif ( not defined $sync->{ expunge2 } ) {
myprint( "Info: will act as --expunge2 (no uidexpunge support)\n" ) ;
$sync->{ expunge2 } = 1 ;
}
}
if ( $sync->{ delete1 } and $sync->{ delete2 } ) {
myprint( "Warning: using --delete1 and --delete2 together is almost always a bad idea. "
. "You should probably launch two runs, the first with --delete2 for a strict sync, "
. "then the second with --delete1 to remove messages from the source account. "
. "Exiting imapsync.\n" ) ;
$sync->{ nb_errors }++ ;
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 ;
}
if ( $syncinternaldates ) {
myprint( 'Info: turned ON syncinternaldates, ',
"will set the internal dates (arrival dates) on host2 same as host1.\n" ) ;
}else{
myprint( "Info: turned OFF syncinternaldates\n" ) ;
}
if ( defined $authmd5 and $authmd5 ) {
$authmd51 = 1 ;
$authmd52 = 1 ;
}
if ( defined $authmd51 and $authmd51 ) {
$acc1->{ authmech } ||= 'CRAM-MD5' ;
}
else{
$acc1->{ authmech } ||= $acc1->{ authuser } ? 'PLAIN' : 'LOGIN' ;
}
if ( defined $authmd52 and $authmd52 ) {
$acc2->{ authmech } ||= 'CRAM-MD5';
}
else{
$acc2->{ authmech } ||= $acc2->{ authuser } ? 'PLAIN' : 'LOGIN';
}
$acc1->{ authmech } = uc $acc1->{ authmech } ;
$acc2->{ authmech } = uc $acc2->{ authmech } ;
if ( defined $acc1->{ proxyauth } && !$acc1->{ authuser } )
{
missing_option( $sync, 'With --proxyauth1, --authuser1' ) ;
}
if ( defined $acc2->{ proxyauth } && !$acc2->{ authuser } )
{
missing_option( $sync, 'With --proxyauth2, --authuser2' ) ;
}
myprint( "Host1: will try to use $acc1->{ authmech } authentication on host1\n") ;
myprint( "Host2: will try to use $acc2->{ authmech } authentication on host2\n") ;
$sync->{ timeout } = defined $sync->{ timeout } ?$sync->{ timeout } : $DEFAULT_TIMEOUT ;
$sync->{ acc1 }->{timeout} = defined $sync->{ acc1 }->{timeout} ? $sync->{ acc1 }->{timeout} : $sync->{ timeout } ;
myprint( "Host1: imap connection timeout is $sync->{ acc1 }->{timeout} seconds\n") ;
$sync->{ acc2 }->{timeout} = defined $sync->{ acc2 }->{timeout} ? $sync->{ acc2 }->{timeout} : $sync->{ timeout } ;
myprint( "Host2: imap connection timeout is $sync->{ acc2 }->{timeout} seconds\n" ) ;
keepalive1( $sync ) ;
keepalive2( $sync ) ;
if ( under_cgi_context( $sync ) )
{
myprint( "Under CGI context, a timeout can occur from the webserver, see https://imapsync.lamiral.info/INSTALL.d/INSTALL.OnlineUI.txt\n" ) ;
}
$sync->{ syncacls } = defined $sync->{ syncacls } ? $sync->{ syncacls } : 0 ;
# No folders sizes at the beginning if --justfolders, unless really wanted.
if (
$sync->{ justfolders }
and not defined $sync->{ foldersizes }
and not $sync->{ justfoldersizes } )
{
$sync->{ foldersizes } = 0 ;
$sync->{ foldersizesatend } = 1 ;
}
$sync->{ foldersizes } = ( defined $sync->{ foldersizes } ) ? $sync->{ foldersizes } : 1 ;
$sync->{ foldersizesatend } = ( defined $sync->{ foldersizesatend } ) ? $sync->{ foldersizesatend } : $sync->{ foldersizes } ;
#$sync->{ checknoabletosearch } = ( defined $sync->{ checknoabletosearch } ) ? $sync->{ checknoabletosearch } : 1 ;
set_checknoabletosearch( $sync ) ;
$acc1->{ fastio } = defined $acc1->{ fastio } ? $acc1->{ fastio } : 0 ;
$acc2->{ fastio } = defined $acc2->{ fastio } ? $acc2->{ fastio } : 0 ;
$acc1->{ reconnectretry } = defined $acc1->{ reconnectretry } ? $acc1->{ reconnectretry } : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ;
$acc2->{ reconnectretry } = defined $acc2->{ reconnectretry } ? $acc2->{ reconnectretry } : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ;
# IMAP compression on by default
#$acc1->{ compress } = defined $acc1->{ compress } ? $acc1->{ compress } : 0 ;
#$acc2->{ compress } = defined $acc2->{ compress } ? $acc2->{ compress } : 0 ;
if ( ! @useheader ) { @useheader = qw( Message-Id Received ) ; }
# Make a hash %useheader of each --useheader 'key' in uppercase
for ( @useheader ) { $sync->{useheader}->{ uc $_ } = undef } ;
#myprint( Data::Dumper->Dump( [ \%useheader ] ) ) ;
#exit ;
myprint( "Host1: IMAP server [$sync->{host1}] port [$sync->{port1}] user [$sync->{user1}]\n" ) ;
myprint( "Host2: IMAP server [$sync->{host2}] port [$sync->{port2}] user [$sync->{user2}]\n" ) ;
get_password1( $sync ) ;
get_password2( $sync ) ;
# --dry1 make imapsync not fetching messages from host1, it is on when --dry is on.
# Use --dry --nodry1 to make imapsync fetching messages from host1,
# It is useful when debugging transformation options like --pipemess or --regexmess
$sync->{dry1} = defined $sync->{dry1} ? $sync->{dry1} : $sync->{dry} ;
$sync->{dry_message} = q{} ;
if( $sync->{dry} ) {
$sync->{dry_message} = "\t(not really since --dry mode)" ;
}
$sync->{ search1 } ||= $search if ( $search ) ;
$sync->{ 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} ;
}
$pipemesscheck = ( defined $pipemesscheck ) ? $pipemesscheck : 1 ;
if ( @pipemess and $pipemesscheck ) {
myprint( 'Checking each --pipemess command, '
. join( q{, }, @pipemess )
. ", with an space string. ( Can avoid this check with --nopipemesscheck )\n" ) ;
my $string = pipemess( q{ }, @pipemess ) ;
# string undef means something was bad.
if ( not ( defined $string ) ) {
$sync->{nb_errors}++ ;
exit_clean( $sync, $EX_USAGE,
"Error: one of --pipemess command is bad, check it\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 ) ;
# string undef means something was bad.
if ( not ( defined $string ) ) {
$sync->{nb_errors}++ ;
exit_clean( $sync, $EX_USAGE,
"Error: --maxlinelengthcmd command is bad, check it\n"
) ;
}
myprint( "Ok with --maxlinelengthcmd $maxlinelengthcmd\n" ) ;
}
if ( @regexmess ) {
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 ) ) {
#errors_incr( $sync, 'Warning: one of --regexmess option may be bad, check them' ) ;
exit_clean( $sync, $EX_USAGE,
"Error: one of --regexmess option is bad, check it\n"
) ;
}
myprint( "Ok with each --regexmess\n" ) ;
}
if ( @skipmess ) {
myprint( "Checking each --skipmess command with an space string.\n" ) ;
my $match = skipmess( q{ } ) ;
# match undef means one of the eval regex was bad.
if ( not ( defined $match ) ) {
$sync->{nb_errors}++ ;
exit_clean( $sync, $EX_USAGE,
"Error: one of --skipmess option is bad, check it\n"
) ;
}
myprint( "Ok with each --skipmess\n" ) ;
}
if ( $sync->{ regexflag } ) {
myprint( "Checking each --regexflag command with an space string.\n" ) ;
my $string = regexflags( $sync, q{ } ) ;
# string undef means one of the eval regex was bad.
if ( not ( defined $string ) ) {
$sync->{nb_errors}++ ;
exit_clean( $sync, $EX_USAGE,
"Error: one of --regexflag option is bad, check it\n"
) ;
}
myprint( "Ok with each --regexflag\n" ) ;
}
$sync->{imap1} = login_imap( $sync->{host1}, $sync->{port1}, $sync->{user1}, $sync->{password1},
$sync->{ssl1}, $sync->{tls1},
$uid1, $split1, $sync->{ acc1 }, $sync ) ;
$sync->{imap2} = login_imap( $sync->{host2}, $sync->{port2}, $sync->{user2}, $sync->{password2},
$sync->{ssl2}, $sync->{tls2},
$uid2, $split2, $sync->{ acc2 }, $sync ) ;
$sync->{ debug } and $sync->{imap1} and myprint( 'Host1 Buffer I/O: ', $sync->{imap1}->Buffer(), "\n" ) ;
$sync->{ debug } and $sync->{imap2} and myprint( 'Host2 Buffer I/O: ', $sync->{imap2}->Buffer(), "\n" ) ;
if ( ! $sync->{imap1} || ! $sync->{imap2} )
{
exit_most_errors( $sync ) ;
}
myprint( "Host1: state Authenticated\n" ) ;
myprint( "Host2: state Authenticated\n" ) ;
myprint( 'Host1 capability once authenticated: ', join(q{ }, @{ $sync->{imap1}->capability() || [] }), "\n" ) ;
#myprint( Data::Dumper->Dump( [ $sync->{imap1} ] ) ) ;
#myprint( "imap4rev1: " . $sync->{imap1}->imap4rev1() . "\n" ) ;
myprint( 'Host2 capability once authenticated: ', join(q{ }, @{ $sync->{imap2}->capability() || [] }), "\n" ) ;
imap_id_stuff( $sync ) ;
#quota( $sync, $sync->{imap1}, 'h1' ) ; # quota on host1 is useless and pollute host2 output.
quota( $sync, $sync->{imap2}, 'h2' ) ;
maxsize_setting( $sync ) ;
acc_compress_imap( $acc1 ) ;
acc_compress_imap( $acc2 ) ;
if ( $sync->{ justlogin } ) {
$sync->{imap1}->logout( ) ;
$sync->{imap2}->logout( ) ;
exit_clean( $sync, $EX_OK, "Exiting because of --justlogin\n" ) ;
}
#
# Folder stuff
#
$h1_folders_wanted_nb = 0 ; # counter of folders to be done.
$h1_folders_wanted_ct = 0 ; # counter of folders done.
# All folders on host1 and host2
@h1_folders_all = sort $sync->{imap1}->folders( ) ;
@h2_folders_all = sort $sync->{imap2}->folders( ) ;
myprint( 'Host1: found ', scalar @h1_folders_all , " folders.\n" ) ;
myprint( 'Host2: found ', scalar @h2_folders_all , " folders.\n" ) ;
foreach my $f ( @h1_folders_all )
{
$h1_folders_all{ $f } = 1
}
foreach my $f ( @h2_folders_all )
{
$h2_folders_all{ $f } = 1 ;
$sync->{h2_folders_all_UPPER}{ uc $f } = 1 ;
}
$sync->{h1_folders_all} = \%h1_folders_all ;
$sync->{h2_folders_all} = \%h2_folders_all ;
private_folders_separators_and_prefixes( ) ;
# Make a hash of subscribed folders in both servers.
for ( $sync->{imap1}->subscribed( ) ) { $h1_subscribed_folder{ $_ } = 1 } ;
for ( $sync->{imap2}->subscribed( ) ) { $h2_subscribed_folder{ $_ } = 1 } ;
if ( defined $sync->{ subfolder1 } ) {
subfolder1( $sync ) ;
}
if ( defined $sync->{ subfolder2 } ) {
subfolder2( $sync ) ;
}
if ( $fixInboxINBOX and ( my $reg = fix_Inbox_INBOX_mapping( \%h1_folders_all, \%h2_folders_all ) ) ) {
push @{ $sync->{ regextrans2 } }, $reg ;
}
if ( ( $sync->{ folder } and scalar @{ $sync->{ folder } } )
or $subscribed
or scalar @folderrec )
{
# folders given by option --folder
if ( $sync->{ folder } and scalar @{ $sync->{ folder } } ) {
add_to_requested_folders( @{ $sync->{ 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( $sync->{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 ) ;
}
}
# consider (optional) includes and excludes
if ( scalar @include ) {
foreach my $include ( @include ) {
# No, do not add /x after the regex, never.
# Users would kill you!
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 ;
# No, do not add /x after the regex, never.
# Users would kill you!
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" ) ;
}
}
# sort before is not very powerful
# it adds --folderfirst and --folderlast even if they don't exist on host1
#@h1_folders_wanted = sort_requested_folders( ) ;
$sync->{h1_folders_wanted} = [ sort_requested_folders( ) ] ;
# Remove no selectable folders
if ( $sync->{ checkfoldersexist } ) {
my @h1_folders_wanted_exist ;
myprint( "Host1: Checking wanted folders exist. Use --nocheckfoldersexist to avoid this check (shared of public namespace targeted).\n" ) ;
foreach my $folder ( @{ $sync->{h1_folders_wanted} } ) {
( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Checking $folder exists on host1\n" ) ;
if ( ! exists $h1_folders_all{ $folder } ) {
myprint( "Host1: warning! ignoring folder $folder because it is not in host1 whole folders list.\n" ) ;
next ;
}else{
push @h1_folders_wanted_exist, $folder ;
}
}
@{ $sync->{h1_folders_wanted} } = @h1_folders_wanted_exist ;
}else{
myprint( "Host1: Not checking that wanted folders exist. Remove --nocheckfoldersexist to get this check.\n" ) ;
}
setcheckselectable( $sync ) ;
checkselectable( $sync ) ;
# Local bugfix. OpenFind folders named like "kk \*123" are in fact "kk *123" (no \)
#foreach my $folder ( @{ $sync->{ h1_folders_wanted } } )
#{
# $folder =~ s{ \\\*}{ *}g ;
#}
# this hack is because LWP post does not pass well a hash in the $form parameter
# but it does pass well an array
#%{ $sync->{f1f2h} } = split_around_equal( @{ $sync->{f1f2} } ) ;
make_f1f2_array_to_a_hash( $sync ) ;
automap( $sync ) ;
foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) {
my $h2_fold ;
$h2_fold = imap2_folder_name( $sync, $h1_fold ) ;
$h2_folders_from_1_wanted{ $h2_fold }++ ;
if ( 1 < $h2_folders_from_1_wanted{ $h2_fold } ) {
$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( $sync, $h1_fold ) ;
$h2_folders_from_1_all{ $h2_fold }++ ;
# Follows a fix to avoid deleting folder $sync->{ subfolder2 }
# because it usually does not exist on host1.
if ( $sync->{ subfolder2 } )
{
$h2_folders_from_1_all{ $sync->{ h2_prefix } . $sync->{ subfolder2 } }++ ;
$h2_folders_from_1_all{ $sync->{ subfolder2 } }++ ;
}
}
myprint( << 'END_LISTING' ) ;
++++ Listing folders
All foldernames are presented between brackets like [X] where X is the foldername.
When a foldername contains non-ASCII characters it is presented in the form
[X] = [Y] where
X is the imap foldername you have to use in command line options and
Y is the utf8 output just printed for convenience, to recognize it.
END_LISTING
myprint(
"Host1: folders list (first the raw imap format then the [X] = [Y]):\n",
$sync->{imap1}->list( ),
"\n",
jux_utf8_list( @h1_folders_all ),
"\n",
"Host2: folders list (first the raw imap format then the [X] = [Y]):\n",
$sync->{imap2}->list( ),
"\n",
jux_utf8_list( @h2_folders_all ),
"\n",
q{}
) ;
if ( $subscribed ) {
myprint(
'Host1 subscribed folders list: ',
jux_utf8_list( sort keys %h1_subscribed_folder ), "\n",
) ;
}
@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" ) ;
}
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 ( keys %{ $sync->{f1f2h} } ) {
myprint( "Folders mapping from --f1f2 options, it overrides --automap:\n" ) ;
foreach my $h1_fold ( keys %{ $sync->{f1f2h} } ) {
my $h2_fold = $sync->{f1f2h}{$h1_fold} ;
my $warn = q{} ;
if ( not exists $h1_folders_all{ $h1_fold } ) {
$warn = "BUT $h1_fold does NOT exist on host1!" ;
}
myprintf( "%-40s -> %-40s %s\n",
jux_utf8( $h1_fold ), jux_utf8( $h2_fold ), $warn ) ;
}
myprint( "\n" ) ;
}
exit_clean( $sync, $EX_OK, "Exiting because of --justfolderlists\n" ) if ( $sync->{ justfolderlists } ) ;
exit_clean( $sync, $EX_OK, "Exiting because of --justautomap\n" ) if ( $sync->{ justautomap } ) ;
debugsleep( $sync ) ;
if ( $sync->{ skipemptyfolders } )
{
myprint( "Host1: will not syncing empty folders on host1. Use --noskipemptyfolders to create them anyway on host2\n") ;
}
if ( $sync->{ checknoabletosearch } )
{
myprint( "Checking SEARCH ALL works on both accounts. To avoid that check, use --nochecknoabletosearch\n" ) ;
my $check1 = checknoabletosearch( $sync, $sync->{ imap1 }, 'INBOX', 'Host1' ) ;
my $check2 = checknoabletosearch( $sync, $sync->{ imap2 }, 'INBOX', 'Host2' ) ;
if ( $check1 or $check2 )
{
myprint( "At least one account can not SEARCH ALL. So acting like --noabletosearch\n" ) ;
$sync->{abletosearch} = 0 ;
$sync->{abletosearch1} = 0 ;
$sync->{abletosearch2} = 0 ;
}
else
{
myprint( "Good! SEARCH ALL works on both accounts.\n" ) ;
}
}
if ( $sync->{ foldersizes } ) {
foldersizes_at_the_beggining( $sync ) ;
#foldersizes_at_the_beggining_old( $sync ) ;
}
if ( $sync->{ justfoldersizes } )
{
exit_clean( $sync, $EX_OK, "Exiting because of --justfoldersizes\n" ) ;
}
$sync->{can_do_stats} = 1 ;
if ( $sync->{ delete1emptyfolders } ) {
delete1emptyfolders( $sync ) ;
}
delete_folders_in_2_not_in_1( ) if $delete2folders ;
# folder loop
$h1_folders_wanted_nb = scalar @{ $sync->{h1_folders_wanted} } ;
myprint( "++++ Looping on each one of $h1_folders_wanted_nb folders to sync\n" ) ;
$sync->{begin_transfer_time} = time ;
my %uid_candidate_for_deletion ;
my %uid_candidate_no_deletion ;
$sync->{ h2_folders_of_md5 } = { } ;
FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } )
{
$sync->{ h1_current_folder } = $h1_fold ;
eta_print( $sync ) ;
abortifneeded( $sync ) ;
if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
my $h2_fold = imap2_folder_name( $sync, $h1_fold ) ;
$sync->{ h2_current_folder } = $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 ) ) ;
myprint( debugmemory( $sync, " at folder loop" ) ) ;
# host1 can not be fetched read only, select is needed because of expunge.
select_folder( $sync, $sync->{imap1}, $h1_fold, 'Host1' ) or next FOLDER ;
debugsleep( $sync ) ;
my $h1_msgs_all_hash_ref ;
my @h1_msgs ;
my $h1_msgs_nb ;
my $h1_msgs_nb_from_select ;
$h1_msgs_nb_from_select = count_from_select( $sync->{imap1}->History ) ;
myprint( "Host1: folder [$h1_fold] has $h1_msgs_nb_from_select messages in total (mentioned by SELECT)\n" ) ;
if ( $sync->{ skipemptyfolders } and 0 == $h1_msgs_nb_from_select ) {
myprint( "Host1: skipping empty host1 folder [$h1_fold]\n" ) ;
next FOLDER ;
}
# Code added from https://github.com/imapsync/imapsync/issues/95
# Thanks jh1995
# Goal: do not create folder if --search or --max/minage return 0 message.
# even if there are messages by SELECT (no not real empty, empty for the user point of vue).
if ( $sync->{ skipemptyfolders } or $sync->{ dry } )
{
$h1_msgs_all_hash_ref = { } ;
@h1_msgs = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref, $sync->{ search1 }, $sync->{abletosearch1}, $h1_fold ) ;
$h1_msgs_nb = scalar( @h1_msgs ) ;
if ( 0 == $h1_msgs_nb and $sync->{ skipemptyfolders } ) {
myprint( "Host1: skipping empty host1 folder [$h1_fold] (0 message found by SEARCH)\n" ) ;
next FOLDER ;
}
}
if ( ! exists $h2_folders_all{ $h2_fold } ) {
# In --dry mode I could count the messages to be transfered instead of 0
# Messages transferred : 0 (could be 0 without dry mode)
if ( ! create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold ) )
{
if ( $sync->{ dry } )
{
$nb_msg_skipped_dry_mode += $h1_msgs_nb ;
}
next FOLDER ;
}
}
acls_sync( $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( $sync, $sync->{imap2}, $h2_fold, 'Host2' )
or ( create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold )
and select_folder( $sync, $sync->{imap2}, $h2_fold, 'Host2' ) )
or next FOLDER ;
my @select_results = $sync->{imap2}->Results( ) ;
my $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" ) ;
$sync->{ permanentflags2 } = permanentflags( $sync, @select_results ) ;
myprint( "Host2: folder [$h2_fold] permanentflags: $sync->{ permanentflags2 }\n" ) ;
if ( $sync->{ expunge1 } )
{
myprint( "Host1: Expunging $h1_fold $sync->{dry_message}\n" ) ;
if ( ! $sync->{dry} )
{
$sync->{imap1}->expunge( ) ;
}
}
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" ) ;
if ( ! $sync->{dry} ) { $sync->{imap2}->subscribe( $h2_fold ) } ;
}
next FOLDER if ( $sync->{ justfolders } ) ;
if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
if ( ! defined $h1_msgs_nb )
{
$h1_msgs_all_hash_ref = { } ;
@h1_msgs = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref, $sync->{ search1 }, $sync->{abletosearch1}, $h1_fold );
$h1_msgs_nb = scalar @h1_msgs ;
}else{
# select_msgs already done.
}
if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages\n" ) ;
( $sync->{ debug } or $sync->{ debuglist } ) and myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages, LIST gives: @h1_msgs\n" ) ;
$sync->{ debug } and myprint( "Host1: selecting messages of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ;
my $h2_msgs_all_hash_ref = { } ;
my @h2_msgs = select_msgs( $sync->{imap2}, $h2_msgs_all_hash_ref, $sync->{ search2 }, $sync->{abletosearch2}, $h2_fold ) ;
if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
my $h2_msgs_nb = scalar @h2_msgs ;
myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages\n" ) ;
( $sync->{ debug } or $sync->{ debuglist } ) and myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages, LIST gives: @h2_msgs\n" ) ;
$sync->{ debug } and myprint( "Host2: selecting messages of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ;
my $cache_base = "$sync->{ tmpdir }/imapsync_cache/" ;
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 = $sync->{imap1}->uidvalidity( ) || q{} ;
my $h2_uidvalidity = $sync->{imap2}->uidvalidity( ) || q{} ;
if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
if ( $sync->{ usecache } ) {
myprint( "Local cache directory: $cache_dir ( " . length( $cache_dir ) . " characters long )\n" ) ;
mkpath( "$cache_dir" ) ;
( $cache_1_2_ref, $cache_2_1_ref )
= get_cache( $cache_dir, \@h1_msgs, \@h2_msgs, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ;
myprint( 'CACHE h1 h2: ', scalar keys %{ $cache_1_2_ref } , " files\n" ) ;
$sync->{ debug } and myprint( '[',
map ( { "$_->$cache_1_2_ref->{$_} " } keys %{ $cache_1_2_ref } ), " ]\n" ) ;
}
my %h1_hash = ( ) ;
my %h2_hash = ( ) ;
my ( %h1_msgs, %h2_msgs ) ;
@h1_msgs{ @h1_msgs } = ( ) ;
@h2_msgs{ @h2_msgs } = ( ) ;
my @h1_msgs_in_cache = sort { $a <=> $b } keys %{ $cache_1_2_ref } ;
my @h2_msgs_in_cache = sort { $a <=> $b } keys %{ $cache_2_1_ref } ;
my ( %h1_msgs_not_in_cache, %h2_msgs_not_in_cache ) ;
%h1_msgs_not_in_cache = %h1_msgs ;
%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 = sort { $a <=> $b } keys %h1_msgs_not_in_cache ;
#myprint( "h1_msgs_not_in_cache: [@h1_msgs_not_in_cache]\n" ) ;
my @h2_msgs_not_in_cache = sort { $a <=> $b } keys %h2_msgs_not_in_cache ;
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 $sync->{ usecache } ;
@h1_msgs_not_in_cache = ( ) ;
@h2_msgs_not_in_cache = ( ) ;
#myprint( "delete2: @h2_msgs_delete2_not_in_cache\n" ) ;
}
if ( $sync->{ debug } or ( 5000 <= scalar( @h1_msgs_not_in_cache ) ) )
{
myprint( "Host1: parsing headers of folder [$h1_fold]. It can take time for huge folders. Be patient.\n" ) ;
}
my ( $h1_heads_ref, $h1_fir_ref ) = ( {}, {} ) ;
$h1_heads_ref = $sync->{ imap1 }->parse_headers( [ @h1_msgs_not_in_cache ], @useheader ) if ( @h1_msgs_not_in_cache ) ;
$sync->{ debug } and myprint( "Host1: parsing headers of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ;
@{ $h1_fir_ref }{ @h1_msgs } = ( undef ) ;
$sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold]\n" ) ;
my @h1_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ;
if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h1_common_fetch_param, 'X-GM-LABELS' ; }
if ( $sync->{ abletosearch1 } )
{
$h1_fir_ref = $sync->{ imap1 }->fetch_hash( \@h1_msgs, @h1_common_fetch_param, $h1_fir_ref )
if ( @h1_msgs ) ;
}
else
{
my $fetch_hash_uids = $fetch_hash_set || "1:*" ;
$h1_fir_ref = $sync->{ imap1 }->fetch_hash( $fetch_hash_uids, @h1_common_fetch_param, $h1_fir_ref )
if ( @h1_msgs ) ;
}
$sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ;
if ( ! $h1_fir_ref )
{
my $error = join( q{}, "Host1: folder $h1_fold : Could not fetch_hash ",
scalar @h1_msgs, ' msgs: ', $sync->{imap1}->LastError || q{}, "\n" ) ;
errors_incr( $sync, $error ) ;
next FOLDER ;
}
my @h1_msgs_duplicate;
foreach my $m ( @h1_msgs_not_in_cache )
{
my $rc = parse_header_msg( $sync, $sync->{imap1}, $m, $h1_fold, $h1_heads_ref, $h1_fir_ref, 'Host1', \%h1_hash ) ;
if ( ! defined $rc )
{
my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0;
myprint( "Host1: $h1_fold/$m size $h1_size ignored (no wanted headers so we ignore this message. To solve this: use --addheader)\n" ) ;
$sync->{ total_bytes_skipped } += $h1_size ;
$sync->{ nb_msg_skipped } += 1 ;
$sync->{ h1_nb_msg_noheader } +=1 ;
$sync->{ 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;
$sync->{ acc1 }->{ nb_msg_duplicate } += 1;
if ( ! $sync->{ syncduplicates } ) {
$sync->{ nb_msg_skipped } += 1 ;
$sync->{ h1_nb_msg_processed } +=1 ;
}
}
}
my $h1_msgs_duplicate_nb = scalar @h1_msgs_duplicate ;
myprint( "Host1: folder [$h1_fold] selected $h1_msgs_nb messages, duplicates $h1_msgs_duplicate_nb\n" ) ;
$sync->{ debug } and myprint( 'Host1: whole time parsing headers took ', timenext( $sync ), " s\n" ) ;
# Getting headers and metada can be so long that host2 might be disconnected here
if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
if ( $sync->{ debug } or ( 5000 <= scalar( @h2_msgs_not_in_cache ) ) )
{
myprint( "Host2: parsing headers of folder [$h2_fold]. It can take time for huge folders. Be patient.\n" ) ;
}
my ( $h2_heads_ref, $h2_fir_ref ) = ( {}, {} );
$h2_heads_ref = $sync->{ imap2 }->parse_headers( [ @h2_msgs_not_in_cache ], @useheader ) if ( @h2_msgs_not_in_cache );
$sync->{ debug } and myprint( "Host2: parsing headers of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ;
$sync->{ debug } and myprint( "Host2: getting flags idate and sizes of folder [$h2_fold]\n" ) ;
@{ $h2_fir_ref }{ @h2_msgs } = ( ); # fetch_hash can select by uid with last arg as ref
my @h2_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ;
if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h2_common_fetch_param, 'X-GM-LABELS' ; }
if ( $sync->{ abletosearch2 } and scalar( @h2_msgs ) ) {
$h2_fir_ref = $sync->{ imap2 }->fetch_hash( \@h2_msgs, @h2_common_fetch_param, $h2_fir_ref ) ;
}else{
my $fetch_hash_uids = $fetch_hash_set || "1:*" ;
$h2_fir_ref = $sync->{ imap2 }->fetch_hash( $fetch_hash_uids, @h2_common_fetch_param, $h2_fir_ref )
if ( @h2_msgs ) ;
}
$sync->{ debug } and myprint( "Host2: getting flags idate and sizes of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ;
my @h2_msgs_duplicate;
foreach my $m (@h2_msgs_not_in_cache) {
my $rc = parse_header_msg( $sync, $sync->{imap2}, $m, $h2_fold, $h2_heads_ref, $h2_fir_ref, 'Host2', \%h2_hash ) ;
my $h2_size = $h2_fir_ref->{$m}->{'RFC822.SIZE'} || 0 ;
if (! defined $rc ) {
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
$sync->{ acc2 }->{ nb_msg_duplicate } += 1 ;
push @h2_msgs_duplicate, $m ;
}
}
# %h2_folders_of_md5
foreach my $md5 ( keys %h2_hash ) {
$sync->{ h2_folders_of_md5 }->{ $md5 }->{ $h2_fold } ++ ;
}
# %h1_folders_of_md5
foreach my $md5 ( keys %h1_hash ) {
$sync->{ h1_folders_of_md5 }->{ $md5 }->{ $h2_fold } ++ ;
}
my $h2_msgs_duplicate_nb = scalar @h2_msgs_duplicate ;
myprint( "Host2: folder [$h2_fold] selected $h2_msgs_nb messages, duplicates $h2_msgs_duplicate_nb\n" ) ;
$sync->{ debug } and myprint( 'Host2 whole time parsing headers took ', timenext( $sync ), " s\n" ) ;
$sync->{ 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;
#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;
# Deletions on account2.
if( $sync->{ delete2duplicates } and not exists $h2_folders_from_1_several{ $h2_fold } ) {
my @h2_expunge ;
foreach my $h2_msg ( @h2_msgs_duplicate ) {
myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2 $sync->{dry_message}\n" ) ;
push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ;
if ( ! $sync->{ dry } ) {
$sync->{ imap2 }->delete_message( $h2_msg ) ;
$sync->{ acc2 }->{ nb_msg_deleted } += 1 ;
}
}
my $cnt = scalar @h2_expunge ;
if( @h2_expunge and not $sync->{ expunge2 } ) {
myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ;
$sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ;
}
if ( $sync->{ expunge2 } ){
myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ;
$sync->{imap2}->expunge( ) if ! $sync->{dry} ;
}
}
if( $sync->{ delete2 } and not exists $h2_folders_from_1_several{ $h2_fold } ) {
# 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 $sync->{ uidexpunge2 };
if ( ! ( $sync->{ dry } or $isdel ) ) {
$sync->{ imap2 }->delete_message( $h2_msg );
$sync->{ acc2 }->{ nb_msg_deleted } += 1;
}
}
}
foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) {
myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2 $sync->{dry_message}\n" ) ;
push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 };
if ( ! $sync->{dry} ) {
$sync->{ imap2 }->delete_message( $h2_msg );
$sync->{ acc2 }->{ nb_msg_deleted } += 1;
}
}
my $cnt = scalar @h2_expunge ;
if( @h2_expunge and not $sync->{ expunge2 } ) {
myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ;
$sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ;
}
if ( $sync->{ expunge2 } ) {
myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ;
$sync->{imap2}->expunge( ) if ! $sync->{dry} ;
}
}
if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } ) {
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 ) {
$sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [$m_id]\n" ) ;
$uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ;
}
}else{
$sync->{ 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" ) ;
$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" ) ;
$uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
}
if ( 0 == $h2_folders_from_1_several{ $h2_fold } ) {
# last host1 folder going to $h2_fold
myprint( "Last host1 folder going to $h2_fold\n" ) ;
foreach my $h2_msg ( keys %{ $uid_candidate_for_deletion{ $h2_fold } } ) {
$sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion\n" ) ;
if ( exists $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg } ) {
$sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg canceled deletion\n" ) ;
}else{
myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted $sync->{dry_message}\n" ) ;
push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ;
if ( ! $sync->{ dry} ) {
$sync->{ imap2 }->delete_message( $h2_msg ) ;
$sync->{ acc2 }->{ nb_msg_deleted } += 1 ;
}
}
}
}
my $cnt = scalar @h2_expunge ;
if( @h2_expunge and not $sync->{ expunge2 } ) {
myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ;
$sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ;
}
if ( $sync->{ expunge2 } ) {
myprint( "Host2: Expunging host2 folder $h2_fold $sync->{dry_message}\n" ) ;
$sync->{imap2}->expunge( ) if ! $sync->{dry} ;
}
$h2_folders_from_1_several{ $h2_fold }-- ;
}
my $h2_uidnext = $sync->{imap2}->uidnext( $h2_fold ) ;
$sync->{ debug } and myprint( "Host2: uidnext is $h2_uidnext\n" ) ;
$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 ; }
my @h1_msgs_to_delete ;
MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) {
abortifneeded( $sync ) ;
if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
#myprint( "h1_nb_msg_processed: $sync->{ h1_nb_msg_processed }\n" ) ;
my $h1_size = $h1_hash{$m_id}{'s'};
my $h1_msg = $h1_hash{$m_id}{'m'};
my $h1_idate = $h1_hash{$m_id}{'D'};
#my $labels = labels( $sync->{imap1}, $h1_msg ) ;
#print "LABELS: $labels\n" ;
if ( ( not exists $h2_hash{ $m_id } )
and ( not ( exists $sync->{ h2_folders_of_md5 }->{ $m_id } )
or not $sync->{ skipcrossduplicates } ) )
{
# copy
my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $cache_dir ) ;
if ( $h2_msg and $sync->{ delete1 } and not $sync->{ expungeaftereach } ) {
# not expunged
push @h1_msgs_to_delete, $h1_msg ;
}
# A bug here with imapsync 1.920, fixed in 1.921
# Added $h2_msg in the condition. Errors of APPEND were not counted as missing messages on host2!
if ( $h2_msg and not $sync->{ dry } )
{
$sync->{ h2_folders_of_md5 }->{ $m_id }->{ $h2_fold } ++ ;
}
#
if( $sync->{ delete2 } and ( exists $h2_folders_from_1_several{ $h2_fold } ) and $h2_msg ) {
myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ;
$uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
}
if ( total_bytes_max_reached( $sync ) ) {
# Still a bug when using --delete1 --noexpungeaftereach
# same thing below on all total_bytes_max_reached!
last FOLDER ;
}
next MESS;
}
else
{
# already on host2
if ( exists $h2_hash{ $m_id } )
{
my $h2_msg = $h2_hash{$m_id}{'m'} ;
$sync->{ debug } and myprint( "Host1: found that msg $h1_fold/$h1_msg equals Host2 $h2_fold/$h2_msg\n" ) ;
if ( $sync->{ usecache } )
{
$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 $sync->{ h2_folders_of_md5 }->{ $m_id } )
{
my @folders_dup = keys %{ $sync->{ h2_folders_of_md5 }->{ $m_id } } ;
( $sync->{ debug } or $sync->{ debugcrossduplicates } ) and myprint( "Host1: found that msg $h1_fold/$h1_msg is also in Host2 folders @folders_dup\n" ) ;
$sync->{ h2_nb_msg_crossdup } +=1 ;
}
$sync->{ total_bytes_skipped } += $h1_size ;
$sync->{ nb_msg_skipped } += 1 ;
$sync->{ 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'};
if ( $sync->{resyncflags} ) {
sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $h1_fir_ref, $h2_fir_ref ) ;
}
# Good
my $h2_size = $h2_hash{$m_id}{'s'};
$sync->{ debug } and myprint(
"Host1: size msg $h1_fold/$h1_msg = $h1_size <> $h2_size = Host2 $h2_fold/$h2_msg\n" ) ;
if ( $sync->{ resynclabels } )
{
resynclabels( $sync, $h1_msg, $h2_msg, $h1_fir_ref, $h2_fir_ref, $h1_fold )
}
}
if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
if ( $sync->{ delete1 } ) {
push @h1_msgs_to_delete, $h1_msg ;
}
}
# END MESS: loop
# @h1_msgs_in_cache are already synced too.
delete_message_on_host1( $sync, $h1_fold, $sync->{ expunge1 }, @h1_msgs_to_delete, @h1_msgs_in_cache ) ;
if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
# MESS_IN_CACHE:
if ( ! $sync->{ delete1 } )
{
foreach my $h1_msg ( @h1_msgs_in_cache )
{
my $h2_msg = $cache_1_2_ref->{ $h1_msg } ;
$debugcache and myprint( "cache messages update flags $h1_msg->$h2_msg\n" ) ;
if ( $sync->{resyncflags} )
{
sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $h1_fir_ref, $h2_fir_ref ) ;
}
my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } || 0 ;
$sync->{ total_bytes_skipped } += $h1_size;
$sync->{ nb_msg_skipped } += 1;
$sync->{ h1_nb_msg_processed } +=1 ;
}
}
if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
@h1_msgs_to_delete = ( ) ;
#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 )
{
abortifneeded( $sync ) ;
$sync->{ debug } and myprint( "Copy by uid $h1_fold/$h1_msg\n" ) ;
if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $cache_dir ) ;
if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } and $h2_msg ) {
myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ;
$uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
}
last FOLDER if total_bytes_max_reached( $sync ) ;
}
if ( $sync->{ expunge1 } ){
myprint( "Host1: Expunging folder $h1_fold $sync->{dry_message}\n" ) ;
if ( ! $sync->{dry} ) { $sync->{imap1}->expunge( ) } ;
}
if ( $sync->{ expunge2 } ){
myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ;
if ( ! $sync->{dry} ) { $sync->{imap2}->expunge( ) } ;
}
$sync->{ debug } and myprint( 'Time: ', timenext( $sync ), " s\n" ) ;
}
eta_print( $sync ) ;
myprint( "++++ End looping on each folder\n" ) ;
if ( $sync->{ delete1 } and $sync->{ delete1emptyfolders } ) {
delete1emptyfolders( $sync ) ;
}
( $sync->{ debug } or $sync->{debugfolders} ) and myprint( 'Time: ', timenext( $sync ), " s\n" ) ;
if ( $sync->{ foldersizesatend } ) {
myprint( << 'END_SIZE' ) ;
Folders sizes after the synchronization.
You can remove this foldersizes listing by using "--nofoldersizesatend"
END_SIZE
foldersizesatend( $sync ) ;
}
do_and_print_stats( $sync ) ;
if ( $sync->{ nb_errors } )
{
myprint( errors_listing( $sync ) ) ;
}
if ( $sync->{ testslive } or $sync->{ testslive6 } )
{
tests_live_result( $sync->{ nb_errors } ) ;
}
final_emails_reports( $sync ) ;
#$sync->{imap1}->State( 0 ); # Unconnected
if ( ! lost_connection( $sync, $sync->{imap1}, "for host1 [$sync->{host1}]" ) ) { $sync->{imap1}->logout( ) ; }
if ( ! lost_connection( $sync, $sync->{imap2}, "for host2 [$sync->{host2}]" ) ) { $sync->{imap2}->logout( ) ; }
if ( $sync->{ nb_errors } )
{
my $exit_value = exit_value( $sync, $sync->{ most_common_error } ) ;
exit_clean( $sync, $exit_value ) ;
}
else
{
exit_clean( $sync, $EX_OK ) ;
}
return ;
}
# END of sub single_sync
# subroutines
sub myprint
{
#print @ARG ;
print { $sync->{ tee } || \*STDOUT } @ARG ;
return ;
}
sub myprintf
{
printf { $sync->{ tee } || \*STDOUT } @ARG ;
return ;
}
sub mysprintf
{
my( $format, @list ) = @ARG ;
return sprintf $format, @list ;
}
sub output_start
{
my $mysync = shift @ARG ;
if ( not $mysync ) { return ; }
my @output = @ARG ;
$mysync->{ output } = join( q{}, @output ) . ( $mysync->{ output } || q{} ) ;
return $mysync->{ output } ;
}
sub tests_output_start
{
note( 'Entering tests_output_start()' ) ;
my $mysync = { } ;
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' ) ;
note( 'Leaving tests_output_start()' ) ;
return ;
}
sub tests_output
{
note( 'Entering tests_output()' ) ;
my $mysync = { } ;
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 output
{
my $mysync = shift @ARG ;
if ( not $mysync ) { return ; }
my @output = @ARG ;
$mysync->{ output } .= join( q{}, @output ) ;
return $mysync->{ output } ;
}
sub tests_output_reset_with
{
note( 'Entering tests_output_reset_with()' ) ;
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 output_reset_with
{
my $mysync = shift @ARG ;
if ( not $mysync ) { return ; }
my @output = @ARG ;
$mysync->{ output } = join( q{}, @output ) ;
return $mysync->{ output } ;
}
sub tests_print_output_if_needed
{
note( 'Entering tests_print_output_if_needed()' ) ;
is( undef, print_output_if_needed( ), 'print_output_if_needed: no args => undef' ) ;
my $mysync = { } ;
is( q{}, print_output_if_needed( $mysync ), 'print_output_if_needed: undef => undef' ) ;
output( $mysync, "Hello\n" ) ;
is( "Hello\n", print_output_if_needed( $mysync ), 'print_output_if_needed: Hello => Hello' ) ;
$mysync->{ dockercontext } = 1 ;
is( "Hello\n", print_output_if_needed( $mysync ), 'print_output_if_needed: dockercontext + Hello => Hello' ) ;
$mysync->{ version } = 1 ;
is( q{}, print_output_if_needed( $mysync ), 'print_output_if_needed: dockercontext + Hello + --version => ""' ) ;
$mysync->{ dockercontext } = 0 ;
is( "Hello\n", print_output_if_needed( $mysync ), 'print_output_if_needed: Hello + --version => Hello' ) ;
note( 'Leaving tests_print_output_if_needed()' ) ;
return ;
}
sub print_output_if_needed
{
my $mysync = shift @ARG ;
if ( ! defined $mysync ) { return ; }
my $output = output( $mysync ) ;
if ( $mysync->{ version } && under_docker_context( $mysync ) )
{
return q{} ;
}
else
{
myprint( $output ) ;
return $output ;
}
}
sub stderr_to_stdout
{
my $mysync = shift @ARG ;
if ( $mysync->{ tee} )
{
*STDERR = *${ $mysync->{ tee } }{ IO } ;
}
else
{
*STDERR = *STDOUT ;
}
return ;
}
sub determine_delete2duplicates
{
my $mysync = shift @ARG ;
if ( defined $mysync->{ delete2duplicates } )
{
return $mysync->{ delete2duplicates } ;
}
if ( $mysync->{ syncduplicates } )
{
return 0 ;
}
if ( $sync->{ delete2 } )
{
return 1 ;
}
return ;
}
sub define_pidfile
{
my $mysync = shift @ARG ;
$mysync->{ pidfilelocking } = defined $mysync->{ pidfilelocking } ? $mysync->{ pidfilelocking } : 0 ;
my $host1 = $mysync->{ host1 } || q{} ;
my $user1 = $mysync->{ user1 } || q{} ;
my $host2 = $mysync->{ host2 } || q{} ;
my $user2 = $mysync->{ user2 } || q{} ;
my $account1_filtered = filter_forbidden_characters( slash_to_underscore( $host1 . '_' . $user1 ) ) || q{} ;
my $account2_filtered = filter_forbidden_characters( slash_to_underscore( $host2 . '_' . $user2 ) ) || q{} ;
my $pidfile_basename ;
if ( $ENV{ 'NET_SERVER_SOFTWARE' } and ( $ENV{ 'NET_SERVER_SOFTWARE' } =~ /Net::Server::HTTP/ ) )
{
# under local webserver
$pidfile_basename = 'imapsync' . '_' . $account1_filtered . '_' . $account2_filtered . '.pid' ;
}
else
{
$pidfile_basename = 'imapsync.pid' ;
}
$mysync->{ pidfile } = defined $mysync->{ pidfile } ? $mysync-> { pidfile } : $mysync->{ tmpdir } . "/$pidfile_basename" ;
$mysync->{ abortfile } = abortfile( $mysync, $PROCESS_ID ) ;
return ;
}
sub abortfile
{
my $mysync = shift @ARG ;
my $pid = shift @ARG ;
my $abortfile ;
if ( $mysync->{ abort } )
{
$abortfile = $mysync->{ pidfile } . "abort$pid" ;
}
else
{
$abortfile = $mysync->{ pidfile } . "abort$PROCESS_ID" ;
}
return $abortfile ;
}
sub tests_kill_zero
{
note( 'Entering tests_kill_zero()' ) ;
SKIP: {
if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_kill_zero avoided on Windows', 8 ) ; }
is( 1, kill( 'ZERO', $PROCESS_ID ), "kill ZERO : myself $PROCESS_ID => 1" ) ;
is( 2, kill( 'ZERO', $PROCESS_ID, $PROCESS_ID ), "kill ZERO : myself $PROCESS_ID $PROCESS_ID => 2" ) ;
if ( (-e '/.dockerenv' ) or ( 0 == $EFFECTIVE_USER_ID) )
{
is( 1, kill( 'ZERO', 1 ), "kill ZERO : pid 1 => 1 (docker context or root)" ) ;
is( 2, kill( 'ZERO', $PROCESS_ID, 1 ), "kill ZERO : myself + pid 1, $PROCESS_ID 1 => 2 (docker context or root)" ) ;
}
else
{
is( 0, kill( 'ZERO', 1 ), "kill ZERO : pid 1 => 0 (non root)" ) ;
is( 1, kill( 'ZERO', $PROCESS_ID, 1 ), "kill ZERO : myself + pid 1, $PROCESS_ID 1 => 1 (one is non root)" ) ;
}
my $pid_1 = fork( ) ;
if ( $pid_1 )
{
# parent
}
else
{
# child
sleep 3 ;
exit ;
}
my $pid_2 ;
$pid_2 = fork( ) ;
if ( $pid_2 )
{
# I am the parent
ok( defined( $pid_2 ), "kill_zero: initial fork ok. I am the parent $PROCESS_ID" ) ;
ok( $pid_2 , "kill_zero: initial fork ok, child pid is $pid_2" ) ;
is( 3, kill( 'ZERO', $PROCESS_ID, $pid_2, $pid_1 ), "kill ZERO : myself $PROCESS_ID and child $pid_2 and brother $pid_1 => 3" ) ;
is( $pid_2, waitpid( $pid_2, 0 ), "kill_zero: child $pid_2 no more there => waitpid return $pid_2" ) ;
}
else
{
# I am the child
note( 'This one fails under Windows, kill ZERO returns 0 instead of 2' ) ;
is( 2, kill( 'ZERO', $PROCESS_ID, $pid_1 ), "kill ZERO : myself child $PROCESS_ID brother $pid_1 => 2" ) ;
myprint( "I am the child pid $PROCESS_ID, Exiting\n" ) ;
exit ;
}
wait( ) ;
# End of SKIP block
}
note( 'Leaving tests_kill_zero()' ) ;
return ;
}
sub tests_killpid_by_parent
{
note( 'Entering tests_killpid_by_parent()' ) ;
SKIP: {
if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_killpid_by_parent avoided on Windows', 7 ) ; }
is( undef, killpid( ), 'killpid: no args => undef' ) ;
note( "killpid: trying to kill myself pid $PROCESS_ID, hope I will not succeed" ) ;
is( undef, killpid( $PROCESS_ID ), 'killpid: myself => undef' ) ;
local $SIG{'QUIT'} = sub { myprint "GOT SIG QUIT! I am PID $PROCESS_ID. Exiting\n" ; exit ; } ;
my $pid ;
$pid = fork( ) ;
if ( $pid )
{
# I am the parent
ok( defined( $pid ), "killpid: initial fork ok. I am the parent $PROCESS_ID" ) ;
ok( $pid , "killpid: initial fork ok, child pid is $pid" ) ;
is( 2, kill( 'ZERO', $PROCESS_ID, $pid ), "kill ZERO : myself $PROCESS_ID and child $pid => 2" ) ;
is( 1, killpid( $pid ), "killpid: child $pid killed => 1" ) ;
is( -1, waitpid( $pid, 0 ), "killpid: child $pid no more there => waitpid return -1" ) ;
}
else
{
# I am the child
myprint( "I am the child pid $PROCESS_ID, sleeping 1 + 3 seconds then kill myself\n" ) ;
sleep 1 ;
myprint( "I am the child pid $PROCESS_ID, slept 1 second, should be killed by my parent now, PPID " . mygetppid( ) . "\n" ) ;
sleep 3 ;
# this test should not be run. If it happens => failure.
ok( 0 == 1, "killpid: child pid $PROCESS_ID not dead => failure" ) ;
myprint( "I am the child pid $PROCESS_ID, killing myself failure... Exiting\n" ) ;
exit ;
}
# End of SKIP block
}
note( 'Leaving tests_killpid_by_parent()' ) ;
return ;
}
sub tests_killpid_by_brother
{
note( 'Entering tests_killpid_by_brother()' ) ;
SKIP: {
if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_killpid_by_brother avoided on Windows', 2 ) ; }
local $SIG{'QUIT'} = sub { myprint "GOT SIG QUIT! I am PID $PROCESS_ID. Exiting\n" ; exit ; } ;
my $pid_parent = $PROCESS_ID ;
myprint( "I am the parent pid $pid_parent\n" ) ;
my $pid_1 = fork( ) ;
if ( $pid_1 )
{
# parent
}
else
{
# child
#while ( 1 ) { } ;
sleep 2 ;
sleep 2 ;
# this test should not be run. If it happens => failure.
# Well under Windows this always fails, shit!
ok( 0 == 1 or ( 'MSWin32' eq $OSNAME ) , "killpid: child pid $PROCESS_ID killing by brother but not dead => failure" ) ;
myprint( "I am the child pid $PROCESS_ID, killing by brother failed... Exiting\n" ) ;
exit ;
}
my $pid_2 ;
$pid_2 = fork( ) ;
if ( $pid_2 )
{
# parent
}
else
{
# I am the child
myprint( "I am the child pid $PROCESS_ID, my brother has pid $pid_1\n" ) ;
is( 1, killpid( $pid_1 ), "killpid: brother $pid_1 killed => 1" ) ;
sleep 2 ;
exit ;
}
#sleep 1 ;
is( $pid_1, waitpid( $pid_1, 0), "I am the parent $PROCESS_ID waitpid _1( $pid_1 )" ) ;
is( $pid_2, waitpid( $pid_2, 0 ), "I am the parent $PROCESS_ID waitpid _2( $pid_2 )" ) ;
# End of SKIP block
}
note( 'Leaving tests_killpid_by_brother()' ) ;
return ;
}
sub killpid
{
my $pidtokill = shift @ARG ;
if ( ! $pidtokill ) {
myprint( "No process to kill.\n" ) ;
return ;
}
if ( $PROCESS_ID == $pidtokill ) {
myprint( "I will not kill myself pid $PROCESS_ID via killpid. Sractch it!\n" ) ;
return ;
}
# First ask for suicide
if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) {
myprint( "Sending signal QUIT to PID $pidtokill \n" ) ;
kill 'QUIT', $pidtokill ;
sleep 3 ;
waitpid( $pidtokill, WNOHANG) ;
}else{
myprint( "Can not send signal kill ZERO to PID $pidtokill.\n" ) ;
return ;
}
#while ( waitpid( $pidtokill, WNOHANG) > 0 ) { } ;
# Then murder
if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) {
myprint( "Sending signal KILL to PID $pidtokill \n" ) ;
kill 'KILL', $pidtokill ;
sleep 1 ;
waitpid( $pidtokill, WNOHANG) ;
}else{
myprint( "Process PID $pidtokill ended.\n" ) ;
return 1;
}
# Well ...
if ( kill( 'ZERO', $pidtokill ) or ( 'xMSWin32' eq $OSNAME ) ) {
myprint( "Process PID $pidtokill seems still there. Can not do much.\n" ) ;
return ;
}else{
myprint( "Process PID $pidtokill ended.\n" ) ;
return 1;
}
return ;
}
sub tests_abort
{
note( 'Entering tests_abort()' ) ;
# Well, the abort behavior is tested by test.sh
is( undef, abort( ), 'abort: no args => undef' ) ;
note( 'Leaving tests_abort()' ) ;
return ;
}
sub abort
{
my $mysync = shift @ARG ;
myprint( "In abort\n" ) ;
if ( not $mysync ) { return ; }
if ( ! -r $mysync->{pidfile} ) {
myprint( "In abort: Can not read pidfile $mysync->{pidfile}\n" ) ;
return ;
}
my $pidtokill = firstline( $mysync->{pidfile} ) ;
if ( ! $pidtokill ) {
myprint( "In abort: No process to abort in $mysync->{pidfile}\n" ) ;
return ;
}
if ( ! match_a_pid_number( $pidtokill ) )
{
myprint( "In abort: pid $pidtokill in $mysync->{pidfile} is not a pid number\n" ) ;
return ;
}
if ( $mysync->{abortbyfile} )
{
abortbyfile( $mysync, $pidtokill ) ;
}
else
{
killpid( $pidtokill ) ;
}
return ;
}
sub abortbyfile
{
my $mysync = shift @ARG ;
my $pidtokill = shift @ARG ;
my $abortfile = abortfile( $mysync, $pidtokill ) ;
myprint( "touching $abortfile\n" ) ;
touch( $abortfile ) ;
return ;
}
sub tests_under_docker_context
{
note( 'Entering tests_under_docker_context()' ) ;
is( undef, under_docker_context( ), 'under_docker_context: no args => undef' ) ;
my $mysync = { } ;
$mysync->{ dockercontext } = 1 ;
is( 1, under_docker_context( $mysync ), 'under_docker_context: --dockercontext => 1' ) ;
$mysync->{ dockercontext } = 0 ;
is( 0, under_docker_context( $mysync ), 'under_docker_context: --nodockercontext => 0' ) ;
$mysync = { } ;
# Is not it a stupid test?
if ( under_docker_context( $mysync ) )
{
is( 1, under_docker_context( $mysync ), 'under_docker_context: docker context => 1' ) ;
}
else
{
is( 0, under_docker_context( $mysync ), 'under_docker_context: not docker context => 0' ) ;
}
note( 'Leaving tests_under_docker_context()' ) ;
return ;
}
sub under_docker_context
{
my $mysync = shift @ARG ;
if ( ! defined $mysync ) { return ; }
if ( defined $mysync->{ dockercontext } )
{
return( $mysync->{ dockercontext } ) ;
}
if ( -e '/.dockerenv' )
{
return 1 ;
}
else
{
return 0 ;
}
return ;
}
sub docker_context
{
my $mysync = shift @ARG ;
if ( ! under_docker_context( $mysync ) )
{
return ;
}
output( $mysync, "Docker context detected with the file /.dockerenv\n" ) ;
# No pidfile by default
$mysync->{ pidfile } = defined( $mysync->{ pidfile } ) ? $mysync->{ pidfile } : q{} ;
# No log by default
if ( defined( $mysync->{ log } ) )
{
output( $mysync, "Logging in Docker context. Be sure you added access to it with a mount or similar. See https://docs.docker.com/storage/volumes/\n" ) ;
}
else
{
output( $mysync, "No log by default in Docker context. Use --log to trigger logging to the logfile.\n" ) ;
$mysync->{ log } = 0 ;
}
# In case something is written relatively to .
my $tmp_dir = "/var/tmp/uid_$EFFECTIVE_USER_ID" ;
mkpath( $tmp_dir ) ; # silly? No. it is for imapsync --version being ok.
do_valid_directory( $tmp_dir ) ;
output( $mysync, "Changing current directory to $tmp_dir\n" ) ;
chdir $tmp_dir ;
return ;
}
sub cgibegin
{
my $mysync = shift @ARG ;
if ( ! under_cgi_context( $mysync ) ) { return ; }
require CGI ;
CGI->import( qw( -no_debug -utf8 ) ) ;
require CGI::Carp ;
CGI::Carp->import( qw( fatalsToBrowser ) ) ;
$mysync->{cgi} = CGI->new( ) ;
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 under_cgi_context
{
my $mysync = shift @ARG ;
# Under cgi context
if ( $ENV{SERVER_SOFTWARE} ) {
return 1 ;
}
# Not in cgi context
return ;
}
sub cgibuildheader
{
my $mysync = shift @ARG ;
if ( ! under_cgi_context( $mysync ) ) { return ; }
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; charset=UTF-8',
-status => '200 OK to abort syncing IMAP boxes. ' . load_message( $mysync ),
) ;
}
elsif( $mysync->{ heavy_load_reached } )
{
# https://tools.ietf.org/html/rfc2616#section-10.5.4
# 503 Service Unavailable
# The server is currently unable to handle the request due to a temporary overloading or maintenance of the server.
$httpheader = $mysync->{cgi}->header(
-type => 'text/plain; charset=UTF-8',
-status => '503 Service Unavailable. ' . "Be back later. " . load_message( $mysync ),
) ;
}
else
{
$httpheader = $mysync->{cgi}->header(
-type => 'text/plain; charset=UTF-8',
-status => '200 OK to sync IMAP boxes. ' . load_message( $mysync ),
-cookie => $cookie,
) ;
}
output_start( $mysync, $httpheader ) ;
return ;
}
sub load_message
{
my $mysync = shift @ARG ;
my $message = "Load on " . hostname() . " is $mysync->{ loadavg }" ;
return $message ;
}
sub cgi_exit_on_heavy_load
{
# Exit on heavy load in CGI context
my $mysync = shift @ARG ;
if ( ! under_cgi_context( $mysync ) ) { return ; }
if ( $mysync->{ abort } ) { return ; } # keep going to abort since some ressources will be free soon
if ( $mysync->{ heavy_load_reached } )
{
$mysync->{ nb_errors }++ ;
exit_clean( $mysync, $EX_UNAVAILABLE,
"Server is on heavy load. Be back later. " . load_message( $mysync ) . "\n"
) ;
}
return ;
}
sub tests_heavy_load_reached
{
note( 'Entering tests_is_heavy_load_reached()' ) ;
like( heavy_load_reached( ), qr{^(0|1)$}xms, 'heavy_load_reached: no args => 0 or 1' ) ;
my $mysync = { } ;
like( heavy_load_reached( $mysync ), qr{^(0|1)$}xms, 'heavy_load_reached: { } => 0 or 1' ) ;
$mysync->{ exitonload } = 0 ;
is( 0, heavy_load_reached( $mysync ), 'heavy_load_reached: exitonload=0 => 0 ' ) ;
note( 'Leaving tests_heavy_load_reached()' ) ;
return ;
}
sub heavy_load_reached
{
my $mysync = shift @ARG ;
my $heavy_load_reached = 0 ;
if ( defined( $mysync->{ exitonload } ) && ( ! $mysync->{ exitonload } ) )
{
return 0 ;
}
my $heavy_load_reached_by_memory = heavy_load_reached_by_memory( $mysync ) ;
my $heavy_load_reached_by_cpu = heavy_load_reached_by_cpu( $mysync ) ;
if ( $heavy_load_reached_by_memory || $heavy_load_reached_by_cpu )
{
$heavy_load_reached = 1 ;
}
else
{
$heavy_load_reached = 0 ;
}
return $heavy_load_reached ;
}
sub tests_heavy_load_reached_by_cpu
{
note( 'Entering tests_heavy_load_reached_by_cpu()' ) ;
note( join( " ", loadavg( ), 'heavy_load_reached_by_cpu ', heavy_load_reached_by_cpu( ) ) ) ;
like( heavy_load_reached_by_cpu( ), qr{^(0|1)$}xms, 'heavy_load_reached_by_cpu: no args => 0 or 1' ) ;
my $mysync = { } ;
like( heavy_load_reached_by_cpu( $mysync ), qr{^(0|1)$}xms, 'heavy_load_reached_by_cpu: { } => 0 or 1' ) ;
note( 'Leaving tests_heavy_load_reached_by_cpu()' ) ;
return ;
}
sub heavy_load_reached_by_cpu
{
my $mysync = shift @ARG ;
my $heavy_load_reached = 0 ;
my $load_and_delay = load_per_cpu( $mysync ) ;
if ( $load_and_delay )
{
$heavy_load_reached = 1 ;
}
else
{
$heavy_load_reached = 0 ;
}
return $heavy_load_reached ;
}
sub tests_load_per_cpu
{
note( 'Entering tests_load_per_cpu()' ) ;
note( join( " ", 'loadavg:', loadavg( ), 'cpu_number:', cpu_number( ), 'load_per_cpu ', load_per_cpu( ) ) ) ;
like( load_per_cpu( ), qr{^([0-9.]+)$}xms, 'load_per_cpu: no args => number' ) ;
my $mysync = { } ;
like( load_per_cpu( $mysync ), qr{^([0-9.]+)$}xms, 'load_per_cpu: { } => number' ) ;
note( 'Leaving tests_load_per_cpu()' ) ;
return ;
}
sub load_per_cpu
{
my $mysync = shift @ARG ;
return load_and_delay( 1, cpu_number( ), loadavg( ) ) ;
}
sub tests_heavy_load_reached_by_memory
{
note( 'Entering tests_heavy_load_reached_by_memory()' ) ;
like( heavy_load_reached_by_memory( ), qr{^(0|1)$}xms, 'heavy_load_reached_by_memory: no args => 0 or 1' ) ;
my $mysync = { } ;
like( heavy_load_reached_by_memory( $mysync ), qr{^(0|1)$}xms, 'heavy_load_reached_by_memory: { } => 0 or 1' ) ;
note( 'Leaving tests_heavy_load_reached_by_memory()' ) ;
return ;
}
sub heavy_load_reached_by_memory
{
my $mysync = shift @ARG ;
my $heavy_load_reached = 0 ;
my $heavy_load_percent_threshold = heavy_load_percent_threshold( $mysync ) ;
my $memory_consumption_all_pids_percent = memory_consumption_all_pids_percent( $mysync ) ;
if ( $memory_consumption_all_pids_percent > $heavy_load_percent_threshold )
{
$heavy_load_reached = 1 ;
}
else
{
$heavy_load_reached = 0 ;
}
return $heavy_load_reached ;
}
sub tests_heavy_load_percent_threshold
{
note( 'Entering tests_heavy_load_percent_threshold()' ) ;
note( heavy_load_percent_threshold( ) . " (%)" ) ;
like( heavy_load_percent_threshold( ), qr{^\d+$}xms, 'heavy_load_percent_threshold: no args => integer' ) ;
my $mysync = { } ;
like( heavy_load_percent_threshold( ), qr{^\d+$}xms, 'heavy_load_percent_threshold: { } => integer' ) ;
note( 'Leaving tests_heavy_load_percent_threshold()' ) ;
return ;
}
sub heavy_load_percent_threshold
{
my $mysync = shift @ARG ;
my $total_memory_bytes = total_ram_memory_bytes( ) || return 0 ;
my $memory_footprint_average_bytes = 250_000_000 ;
my $heavy_load_percent_threshold = max( 0, int( 100 * ( $total_memory_bytes - ( 4 * $memory_footprint_average_bytes ) ) / $total_memory_bytes ) ) ;
return $heavy_load_percent_threshold ;
}
sub tests_set_umask
{
note( 'Entering tests_set_umask()' ) ;
my $save_umask = umask ;
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" ) ;
}
umask $save_umask ;
note( 'Leaving tests_set_umask()' ) ;
return ;
}
sub set_umask
{
my $mysync = shift @ARG ;
my $previous_umask = umask_str( ) ;
my $new_umask = umask_str( $UMASK_PARANO ) ;
output( $mysync, "Umask set with $new_umask (was $previous_umask)\n" ) ;
if ( $new_umask eq $UMASK_PARANO ) {
return 1 ;
}
return ;
}
sub tests_umask_str
{
note( 'Entering tests_umask_str()' ) ;
my $save_umask = umask ;
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" ) ;
}
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' ) ;
note( 'Leaving tests_umask_str()' ) ;
return ;
}
sub umask_str
{
my $value = shift @ARG ;
if ( defined $value ) {
umask oct( $value ) ;
}
my $current = umask ;
return( sprintf( '%#04o', $current ) ) ;
}
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 make_var_array_to_a_hash
{
my $mysync = shift @ARG ;
%{ $mysync->{ varh } } = split_around_equal( @{ $mysync->{ var } } ) ;
return ;
}
sub cgisetcontext
{
my $mysync = shift @ARG ;
if ( ! under_cgi_context( $mysync ) ) { return ; }
output( $mysync, "Under cgi context\n" ) ;
set_umask( $mysync ) ;
# Remove all content in unsafe evaled options
@{ $mysync->{ regextrans2 } } = ( ) ;
@{ $mysync->{ regexflag } } = buggyflagsregex( ) ;
@regexmess = ( ) ;
@skipmess = ( ) ;
@pipemess = ( ) ;
$delete2foldersonly = undef ;
$delete2foldersbutnot = undef ;
$maxlinelengthcmd = undef ;
# Set safe default values (I hope...)
#$mysync->{pidfile} = 'imapsync.pid' ;
$mysync->{ pidfilelocking } = 1 ;
$mysync->{ errorsmax } = $ERRORS_MAX_CGI ;
$modulesversion = 0 ;
$mysync->{ releasecheck } = defined $mysync->{ releasecheck } ? $mysync->{ releasecheck } : 1 ;
$mysync->{ usecache } = 0 ;
$mysync->{ showpasswords } = 0 ;
$mysync->{ acc1 }->{ debugimap } = 0 ;
$mysync->{ acc2 }->{ debugimap } = 0 ;
$mysync->{ acc1 }->{ reconnectretry } = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ;
$mysync->{ acc2 }->{ reconnectretry } = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ;
$pipemesscheck = 0 ;
$mysync->{ hashfile } = $CGI_HASHFILE ;
my $hashsynclocal = hashsynclocal( $mysync ) || die "Can not get hashsynclocal. Exiting\n" ;
if ( $ENV{ 'NET_SERVER_SOFTWARE' } and ( $ENV{ 'NET_SERVER_SOFTWARE' } =~ /Net::Server::HTTP/ ) )
{
# under local webserver
$cgidir = q{.} ;
}
else
{
$cgidir = $CGI_TMPDIR_TOP . '/' . $hashsynclocal ;
}
-d $cgidir or mkpath $cgidir or die "Can not create $cgidir: $OS_ERROR\n" ;
$mysync->{ tmpdir } = $cgidir ;
$mysync->{ logdir } = '' ;
chdir $cgidir or die "Can not cd to $cgidir: $OS_ERROR\n" ;
output( $mysync, cgienvcontext( $mysync ) ) ;
$mysync->{ debug } and output( $mysync, 'Current directory is ' . getcwd( ) . "\n" ) ;
$mysync->{ debug } and output( $mysync, 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ;
$mysync->{ debug } and output( $mysync, 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ;
$mysync->{ skipemptyfolders } = defined $mysync->{ skipemptyfolders } ? $mysync->{ skipemptyfolders } : 1 ;
# Out of memory with messages over 1 GB ?
$mysync->{ maxsize } = defined $mysync->{ maxsize } ? $mysync->{ maxsize } : 1_000_000_000 ;
# tail -f behaviour on by default
$mysync->{ tail } = defined $mysync->{ tail } ? $mysync->{ tail } : 1 ;
# not sure it's for good
@useheader = qw( Message-Id Received ) ;
# addheader on by default
$mysync->{ addheader } = defined $mysync->{ addheader } ? $mysync->{ addheader } : 1 ;
# sync duplicates by default in cgi context
$mysync->{ syncduplicates } = defined $mysync->{ syncduplicates } ? $mysync->{ syncduplicates } : 1 ;
# log the logfile name by default in cgi context
$mysync->{ loglogfile } = defined $mysync->{ loglogfile } ? $mysync->{ loglogfile } : 1 ;
# exit on heavy load
$mysync->{ exitonload } = defined $mysync->{ exitonload } ? $mysync->{ exitonload } : 1 ;
return ;
}
sub tests_cgienvcontext
{
note( 'Entering tests_cgienvcontext()' ) ;
is( '', cgienvcontext( ), 'cgienvcontext: no args => empty' ) ;
my $mysync = { } ;
is( '', cgienvcontext( $mysync ), 'cgienvcontext: undef => empty' ) ;
# environment SERVER_SOFTWARE alone
local $ENV{SERVER_SOFTWARE} = 'Chateau Lami' ;
is( "SERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE=Chateau Lami' ) ;
# environment REMOTE_HOST and SERVER_SOFTWARE
$mysync = { } ;
local $ENV{REMOTE_HOST} = 'Votre serviteur' ;
is( "REMOTE_HOST is Votre serviteur\nSERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE + REMOTE_HOST' ) ;
# environment REMOTE_HOST and SERVER_SOFTWARE and --var REMOTE_HOST
$mysync->{ varh }->{REMOTE_HOST} = 'Another Servant' ;
is( "REMOTE_HOST is Another Servant and Votre serviteur\nSERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE + REMOTE_HOST + --var REMOTE_HOST' ) ;
# environment SERVER_SOFTWARE --var REMOTE_HOST only
local $ENV{REMOTE_HOST} = undef ;
$mysync = { } ;
$mysync->{ varh }->{REMOTE_HOST} = 'Another Servant' ;
is( "REMOTE_HOST is Another Servant\nSERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE + --var REMOTE_HOST' ) ;
# environment SERVER_SOFTWARE --var REMOTE_HOST only
local $ENV{REMOTE_HOST} = undef ;
local $ENV{SERVER_SOFTWARE} = undef ;
$mysync = { } ;
$mysync->{ varh }->{REMOTE_HOST} = 'Another Servant' ;
is( "REMOTE_HOST is Another Servant\n", cgienvcontext( $mysync ), 'cgienvcontext: --var REMOTE_HOST' ) ;
note( 'Leaving tests_cgienvcontext()' ) ;
return ;
}
sub cgienvcontext
{
my $mysync = shift @ARG ;
if ( ! defined $mysync ) { return '' ; }
my $output = '' ;
for my $envvar ( qw( REMOTE_ADDR REMOTE_HOST HTTP_REFERER HTTP_USER_AGENT SERVER_SOFTWARE SERVER_NAME SERVER_ADDR SERVER_PORT SERVER_ADMIN HTTP_COOKIE ) )
{
# $envval comes from the web server via an environment variable
# $varval comes from the command line parameter --val or the cgi parameter val
my $envval = $ENV{ $envvar } || q{} ;
my $varval = $mysync->{ varh }->{ $envvar } ;
if ( $envval and not $varval )
{
$output .= "$envvar is $envval\n" ;
}
elsif ( not $envval and $varval )
{
$output .= "$envvar is $varval\n" ;
}
elsif ( $envval and $varval )
{
$output .= "$envvar is $varval and $envval\n" ;
}
}
return $output ;
}
sub announcelogfile
{
my $mysync = shift @ARG ;
if ( $mysync->{ log } )
{
myprint( "Log file is $mysync->{ logfile } ( to change it, use --logfile path ; or use --nolog to turn off logging )\n" ) ;
loglogfile( $mysync ) ;
}
else
{
myprint( "No log file because of option --nolog\n" ) ;
}
return ;
}
sub tests_loglogfile
{
note( 'Entering tests_loglogfile()' ) ;
is( undef, loglogfile( ), 'loglogfile: no args => undef' ) ;
my $mysync = { } ;
is( undef, loglogfile( $mysync ), 'loglogfile: undef => undef' ) ;
$mysync->{ loglogfile } = 1 ;
$mysync->{ log } = 1 ;
is( undef, loglogfile( $mysync ), 'loglogfile: no logfile => undef' ) ;
$mysync->{ logfile } = "logfile.txt" ;
$mysync->{ loglogfilename } = "W/tmp/tests/list_all_logs_auto.txt" ;
like( loglogfile( $mysync ), qr{logfile.txt}xms, 'loglogfile: logfile=logfile.txt => ' ) ;
note( 'Leaving tests_loglogfile()' ) ;
return ;
}
sub loglogfile
{
my $mysync = shift @ARG ;
if ( ! $mysync->{ loglogfile } ) { return ; }
if ( ! $mysync->{ log } ) { return ; }
if ( ! $mysync->{ logfile } ) { return ; }
my $loglogfilename = $mysync->{ loglogfilename } || return ;
my $absolutelogfilepath = absolutelogfilepath( $mysync ) ;
if ( condition_to_loglogfile( $mysync ) )
{
myprint( "Writing log file name $absolutelogfilepath to $loglogfilename\n" ) ;
append_to_file( $absolutelogfilepath, $loglogfilename ) ;
}
return $absolutelogfilepath ;
}
sub condition_to_loglogfile
{
my $mysync = shift @ARG ;
if ( defined $mysync->{ cmdcgi } and scalar( @{ $mysync->{ cmdcgi } } ) )
{
return 1 ;
}
else
{
return 0 ;
}
}
sub absolutelogfilepath
{
my $mysync = shift @ARG ;
# Fixme: add case when the logfile name is already absolute
my $cwd = getcwd( ) ;
my $absolutelogfilepath = "$cwd/$mysync->{ logfile }" ;
return $absolutelogfilepath ;
}
sub append_to_file
{
my $string = shift @ARG ;
my $filename = shift @ARG ;
if ( open( my $fh, '>>', $filename ) )
{
print $fh "$string\n" ;
close $fh ;
}
else
{
myprint( "Could not append $string to file $filename $!\n" ) ;
}
return ;
}
sub checkselectable
{
my $mysync = shift @ARG ;
if ( $mysync->{ checkselectable } ) {
my @h1_folders_wanted_selectable ;
myprint( "Host1: Checking wanted folders are selectable. Use --nocheckselectable to avoid this check.\n" ) ;
foreach my $folder ( @{ $mysync->{ h1_folders_wanted } } )
{
( $mysync->{ debug } or $mysync->{ debugfolders } ) and myprint( "Checking $folder is selectable on host1\n" ) ;
# It does an imap command LIST "" $folder and then search for no \Noselect
if ( ! $mysync->{ imap1 }->selectable( $folder ) )
{
myprint( "Host1: warning! ignoring folder $folder because it is not selectable\n" ) ;
}else
{
push @h1_folders_wanted_selectable, $folder ;
}
}
@{ $mysync->{ h1_folders_wanted } } = @h1_folders_wanted_selectable ;
( $mysync->{ debug } or $mysync->{ debugfolders } )
and myprint( 'Host1: checking folders took ', timenext( $mysync ), " s\n" ) ;
}
else
{
myprint( "Host1: Not checking that wanted folders are selectable. Use --checkselectable to force this check.\n" ) ;
}
return ;
}
sub setcheckselectable
{
my $mysync = shift @ARG ;
my $h1_folders_wanted_nb = scalar @{ $mysync->{ h1_folders_wanted } } ;
# 152 because 98% of host1 accounts have less than 152 folders on /X service.
# command to get this value:
# datamash_file_op_index G_Host1_Nb_folders.txt perc:98 4 %16.1f
if ( ! defined $mysync->{ checkselectable } )
{
if ( 152 >= $h1_folders_wanted_nb )
{
$mysync->{ checkselectable } = 1 ;
}else{
myprint( "Host1: Not checking that $h1_folders_wanted_nb wanted folders are selectable. Use --checkselectable to force this check.\n" ) ;
$mysync->{ checkselectable } = 0 ;
}
}
return ;
}
sub debugsleep
{
my $mysync = shift @ARG ;
if ( defined $mysync->{debugsleep} ) {
myprint( "Info: sleeping $mysync->{debugsleep}s\n" ) ;
sleep $mysync->{debugsleep} ;
}
return ;
}
# Globals:
# $fetch_hash_set
#
sub foldersize
{
# size of one folder
my ( $mysync, $side, $imap, $search_cmd, $abletosearch, $folder ) = @ARG ;
if ( ! all_defined( $mysync, $side, $imap, $folder ) )
{
return ;
}
# FTGate is RFC buggy with EXAMINE it does not act as SELECT
#if ( ! $imap->examine( $folder ) ) {
if ( ! $imap->select( $folder ) ) {
my $error = join q{},
"$side Folder $folder: Could not select: ",
$imap->LastError, "\n" ;
errors_incr( $mysync, $error ) ;
return ;
}
if ( $imap->IsUnconnected( ) )
{
return ;
}
my $hash_ref = { } ;
my @msgs = select_msgs( $imap, undef, $search_cmd, $abletosearch, $folder ) ;
my $nb_msgs = scalar @msgs ;
my $biggest_in_folder = 0 ;
@{ $hash_ref }{ @msgs } = ( undef ) if @msgs ;
my $stot = 0 ;
if ( $imap->IsUnconnected( ) )
{
return ;
}
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\n" ;
errors_incr( $mysync, $error ) ;
return ;
}
}
else
{
my $fetch_hash_uids = $fetch_hash_set || "1:*" ;
if ( ! $imap->fetch_hash( $fetch_hash_uids, 'RFC822.SIZE', $hash_ref ) ) {
my $error = "$side failure with fetch_hash: $EVAL_ERROR\n" ;
errors_incr( $mysync, $error ) ;
return ;
}
}
for ( keys %{ $hash_ref } ) {
my $size = $hash_ref->{ $_ }->{ 'RFC822.SIZE' } ;
if ( defined $size )
{
$stot += $size ;
$biggest_in_folder = max( $biggest_in_folder, $size ) ;
}
}
}
return( $stot, $nb_msgs, $biggest_in_folder ) ;
}
# The old subroutine that performed just one side at a time.
# Still here for a while, until confident with sub foldersize_diff_compute()
sub foldersizes
{
my ( $mysync, $side, $imap, $search_cmd, $abletosearch, @folders ) = @_ ;
my $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 ;
my $biggest_in_folder = 0 ;
$ct_folders++ ;
myprintf( "$side folder %7s %-35s", "$ct_folders/$nb_folders", jux_utf8( $folder ) ) ;
if ( 'Host2' eq $side and not exists $mysync->{h2_folders_all_UPPER}{ uc $folder } ) {
myprint( " does not exist yet\n") ;
next ;
}
if ( 'Host1' eq $side and not exists $h1_folders_all{ $folder } ) {
myprint( " does not exist\n" ) ;
next ;
}
last if $imap->IsUnconnected( ) ;
( $stot, $nb_msgs, $biggest_in_folder ) = foldersize( $mysync, $side, $imap, $search_cmd, $abletosearch, $folder ) ;
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_bin( $total_size ) ) ;
myprintf( "%s Biggest message: %11s bytes (%s)\n", $side, $biggest_in_all, bytes_display_string_bin( $biggest_in_all ) ) ;
myprintf( "%s Time spent on sizing: %11.1f seconds\n", $side, timenext( $mysync ) ) ;
return( $total_nb, $total_size ) ;
}
sub foldersize_diff_present
{
my $mysync = shift @ARG ;
my $folder1 = shift @ARG ;
my $folder2 = shift @ARG ;
my $counter_str = shift @ARG ;
my $force = shift @ARG ;
my $values1_str ;
my $values2_str ;
if ( ! defined $mysync->{ folder1 }->{ $folder1 }->{ size } || $force )
{
foldersize_diff_compute( $mysync, $folder1, $folder2, $force ) ;
}
# again, but this time it means no availaible data.
if ( defined $mysync->{ folder1 }->{ $folder1 }->{ size } )
{
$values1_str = sprintf( "Size: %9s Messages: %5s Biggest: %9s\n",
$mysync->{ folder1 }->{ $folder1 }->{ size },
$mysync->{ folder1 }->{ $folder1 }->{ nb_msgs },
$mysync->{ folder1 }->{ $folder1 }->{ biggest },
) ;
}
else
{
$values1_str = " does not exist\n" ;
}
if ( defined $mysync->{ folder2 }->{ $folder2 }->{ size } )
{
$values2_str = sprintf( "Size: %9s Messages: %5s Biggest: %9s\n",
$mysync->{ folder2 }->{ $folder2 }->{ size },
$mysync->{ folder2 }->{ $folder2 }->{ nb_msgs },
$mysync->{ folder2 }->{ $folder2 }->{ biggest },
) ;
}
else
{
$values2_str = " does not exist yet\n" ;
}
myprintf( "Host1 folder %7s %-35s %s",
"$counter_str",
jux_utf8( $folder1 ),
$values1_str
) ;
myprintf( "Host2 folder %7s %-35s %s",
"$counter_str",
jux_utf8( $folder2 ),
$values2_str
) ;
myprintf( "Host2-Host1 %7s %-35s %9s %5s %9s\n\n",
"",
"",
$mysync->{ folder1 }->{ $folder1 }->{ size_diff },
$mysync->{ folder1 }->{ $folder1 }->{ nb_msgs_diff },
$mysync->{ folder1 }->{ $folder1 }->{ biggest_diff },
) ;
return ;
}
sub foldersize_diff_compute
{
my $mysync = shift @ARG ;
my $folder1 = shift @ARG ;
my $folder2 = shift @ARG ;
my $force = shift @ARG ;
my ( $size_1, $nb_msgs_1, $biggest_1 ) ;
# memoization
if (
exists $h1_folders_all{ $folder1 }
&&
(
! defined $mysync->{ folder1 }->{ $folder1 }->{ size }
|| $force
)
)
{
#myprint( "foldersize folder1 $h1_folders_all{ $folder1 }\n" ) ;
( $size_1, $nb_msgs_1, $biggest_1 ) =
foldersize( $mysync,
'Host1',
$mysync->{ imap1 },
$mysync->{ search1 },
$mysync->{ abletosearch1 },
$folder1
) ;
$mysync->{ folder1 }->{ $folder1 }->{ size } = $size_1 ;
$mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } = $nb_msgs_1 ;
$mysync->{ folder1 }->{ $folder1 }->{ biggest } = $biggest_1 ;
}
else
{
$size_1 = $mysync->{ folder1 }->{ $folder1 }->{ size } ;
$nb_msgs_1 = $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } ;
$biggest_1 = $mysync->{ folder1 }->{ $folder1 }->{ biggest } ;
}
my ( $size_2, $nb_msgs_2, $biggest_2 ) ;
if (
exists $mysync->{ h2_folders_all_UPPER }{ uc $folder2 }
&&
(
! defined $mysync->{ folder2 }->{ $folder2 }->{ size }
|| $force
)
)
{
#myprint( "foldersize folder2\n" ) ;
( $size_2, $nb_msgs_2, $biggest_2 ) =
foldersize( $mysync,
'Host2',
$mysync->{ imap2 },
$mysync->{ search2 },
$mysync->{ abletosearch2 },
$folder2
) ;
$mysync->{ folder2 }->{ $folder2 }->{ size } = $size_2 ;
$mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } = $nb_msgs_2 ;
$mysync->{ folder2 }->{ $folder2 }->{ biggest } = $biggest_2 ;
}
else
{
$size_2 = $mysync->{ folder2 }->{ $folder2 }->{ size } ;
$nb_msgs_2 = $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } ;
$biggest_2 = $mysync->{ folder2 }->{ $folder2 }->{ biggest } ;
}
my $size_diff = diff( $size_2, $size_1 ) ;
my $nb_msgs_diff = diff( $nb_msgs_2, $nb_msgs_1 ) ;
my $biggest_diff = diff( $biggest_2, $biggest_1 ) ;
$mysync->{ folder1 }->{ $folder1 }->{ size_diff } = $size_diff ;
$mysync->{ folder1 }->{ $folder1 }->{ nb_msgs_diff } = $nb_msgs_diff ;
$mysync->{ folder1 }->{ $folder1 }->{ biggest_diff } = $biggest_diff ;
# It's redundant but easier to access later
$mysync->{ folder2 }->{ $folder2 }->{ size_diff } = $size_diff ;
$mysync->{ folder2 }->{ $folder2 }->{ nb_msgs_diff } = $nb_msgs_diff ;
$mysync->{ folder2 }->{ $folder2 }->{ biggest_diff } = $biggest_diff ;
return ;
}
sub diff
{
my $x = shift @ARG ;
my $y = shift @ARG ;
$x ||= 0 ;
$y ||= 0 ;
return $x - $y ;
}
sub tests_add
{
note( 'Entering tests_add()' ) ;
is( 0, add( ), 'tests_add: no args => 0' ) ;
is( 0, add( undef ), 'tests_add: undef => 0' ) ;
is( 0, add( 0 ), 'tests_add: 0 => 0' ) ;
is( 0, add( 0, 0 ), 'tests_add: 0 0 => 0' ) ;
is( 0, add( 0, 0, 0 ), 'tests_add: 0 0 0 => 0' ) ;
is( 1, add( 1 ), 'tests_add: 1 => 1' ) ;
is( 2, add( 1, 1 ), 'tests_add: 1 1 => 2' ) ;
is( 3, add( 1, 1, 1 ), 'tests_add: 1 1 1 => 3' ) ;
is( 2, add( 1, undef, 1 ), 'tests_add: 1 undef 1 => 2' ) ;
is( 0, add( -1, 1 ), 'tests_add: -1 1 => 0' ) ;
is( 2.2, add( 1.1, 1.1 ), 'tests_add: 1.1 1.1 => 2.2' ) ;
is( 100, add( (1) x 100 ), 'tests_add: 1 1 ... 1 100 times => 100 list' ) ;
my @hundred_ones = (1) x 100 ;
is( 100, add( @hundred_ones ), 'tests_add: 1 1 ... 1 100 times => 100 array' ) ;
note( 'Leaving tests_add()' ) ;
return ;
}
sub add
{
my $sum = 0 ;
foreach my $number ( @ARG )
{
$sum += $number || 0 ;
}
return $sum ;
}
sub tests_checknoabletosearch
{
note( 'Entering checknoabletosearch()' ) ;
is( undef, checknoabletosearch( ), 'checknoabletosearch: no args => undef' ) ;
note( 'Leaving checknoabletosearch()' ) ;
return ;
}
sub checknoabletosearch
{
# call example: checknoabletosearch( $sync, $sync->{ imap1 }, 'INBOX', 'Host1' ) ;
# output:
# * undef if something is not ok to decide
# * 1 if SEARCH ALL failed
my( $mysync, $imap, $folder, $HostX ) = @ARG ;
if ( ! all_defined( $mysync, $imap, $folder, $HostX ) )
{
return ;
}
myprint( "$HostX: checking if SEARCH ALL works on $folder\n" ) ;
if ( ! select_folder( $mysync, $imap, $folder, $HostX ) )
{
myprint( "$HostX: can not SELECT folder [$folder]\n" ) ;
return ;
}
my $count_from_select = count_from_select( $imap->History ) ;
myprint( "$HostX: folder [$folder] has $count_from_select messages mentioned by SELECT\n" ) ;
my $msgs_all = $imap->messages( ) ;
if ( ! $msgs_all )
{
myprint( "$HostX: can not SEARCH ALL folder [$folder]\n" ) ;
myprint( "$HostX: ", $imap->LastError(), "\n" ) ;
return 1 ;
}
my $count_from_search_all = scalar( @{ $msgs_all } ) ;
myprint( "$HostX: folder [$folder] has $count_from_search_all messages found by SEARCH ALL\n" ) ;
if ( $count_from_select == $count_from_search_all )
{
myprint( "$HostX: folder [$folder] has the same messages count ($count_from_select) by SELECT and SEARCH ALL\n" ) ;
}
else
{
myprint( "$HostX: Warning, folder [$folder] has not the same count by SELECT ($count_from_select) and SEARCH ALL ($count_from_search_all)\n" ) ;
return 1 ;
}
return ;
}
sub foldersizes_diff_list
{
my $mysync = shift @ARG ;
my $force = shift @ARG ;
my @folders = @{ $mysync->{h1_folders_wanted} } ;
my $nb_folders = scalar @folders ;
my $ct_folders = 0 ; # folder counter.
foreach my $folder1 ( @folders )
{
$ct_folders++ ;
my $counter_str = "$ct_folders/$nb_folders" ;
my $folder2 = imap2_folder_name( $mysync, $folder1 ) ;
foldersize_diff_present( $mysync, $folder1, $folder2, $counter_str, $force ) ;
}
return ;
}
sub foldersizes_total
{
my $mysync = shift @ARG ;
my @folders_1 = @{ $mysync->{h1_folders_wanted} } ;
my @folders_2 = @h2_folders_from_1_wanted ;
my $nb_folders_1 = scalar( @folders_1 ) ;
my $nb_folders_2 = scalar( @folders_2 ) ;
my ( $total_size_1, $total_nb_1, $biggest_in_all_1 ) = ( 0, 0, 0 ) ;
my ( $total_size_2, $total_nb_2, $biggest_in_all_2 ) = ( 0, 0, 0 ) ;
foreach my $folder1 ( @folders_1 )
{
$total_size_1 = add( $total_size_1, $mysync->{ folder1 }->{ $folder1 }->{ size } ) ;
$total_nb_1 = add( $total_nb_1, $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } ) ;
$biggest_in_all_1 = max( $biggest_in_all_1 , $mysync->{ folder1 }->{ $folder1 }->{ biggest } ) ;
}
foreach my $folder2 ( @folders_2 )
{
$total_size_2 = add( $total_size_2, $mysync->{ folder2 }->{ $folder2 }->{ size } ) ;
$total_nb_2 = add( $total_nb_2, $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } ) ;
$biggest_in_all_2 = max( $biggest_in_all_2 , $mysync->{ folder2 }->{ $folder2 }->{ biggest } ) ;
}
myprintf( "Host1 Nb folders: %11s folders\n", $nb_folders_1 ) ;
myprintf( "Host2 Nb folders: %11s folders\n", $nb_folders_2 ) ;
myprint( "\n" ) ;
myprintf( "Host1 Nb messages: %11s messages\n", $total_nb_1 ) ;
myprintf( "Host2 Nb messages: %11s messages\n", $total_nb_2 ) ;
myprint( "\n" ) ;
myprintf( "Host1 Total size: %11s bytes (%s)\n", $total_size_1, bytes_display_string_bin( $total_size_1 ) ) ;
myprintf( "Host2 Total size: %11s bytes (%s)\n", $total_size_2, bytes_display_string_bin( $total_size_2 ) ) ;
myprint( "\n" ) ;
myprintf( "Host1 Biggest message: %11s bytes (%s)\n", $biggest_in_all_1, bytes_display_string_bin( $biggest_in_all_1 ) ) ;
myprintf( "Host2 Biggest message: %11s bytes (%s)\n", $biggest_in_all_2, bytes_display_string_bin( $biggest_in_all_2 ) ) ;
myprint( "\n" ) ;
myprintf( "Time spent on sizing: %11.1f seconds\n", timenext( $mysync ) ) ;
my @total_1_2 = ( $total_nb_1, $total_size_1, $total_nb_2, $total_size_2 ) ;
return @total_1_2 ;
}
sub foldersizesatend_old
{
my $mysync = shift @ARG ;
timenext( $mysync ) ;
return if ( $mysync->{imap1}->IsUnconnected( ) ) ;
return if ( $mysync->{imap2}->IsUnconnected( ) ) ;
# Get all folders on host2 again since new were created
@h2_folders_all = sort $mysync->{imap2}->folders();
for ( @h2_folders_all ) {
$h2_folders_all{ $_ } = 1 ;
$mysync->{h2_folders_all_UPPER}{ uc $_ } = 1 ;
} ;
( $h1_nb_msg_end, $h1_bytes_end ) = foldersizes( $mysync, 'Host1', $mysync->{imap1}, $mysync->{ search1 }, $mysync->{abletosearch1}, @{ $mysync->{h1_folders_wanted} } ) ;
( $h2_nb_msg_end, $h2_bytes_end ) = foldersizes( $mysync, 'Host2', $mysync->{imap2}, $mysync->{ search2 }, $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ;
if ( not all_defined( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) ) {
my $error = "Failure getting foldersizes, final differences will not be calculated\n" ;
errors_incr( $mysync, $error ) ;
}
return ;
}
sub foldersizesatend
{
my $mysync = shift @ARG ;
timenext( $mysync ) ;
return if ( $mysync->{imap1}->IsUnconnected( ) ) ;
return if ( $mysync->{imap2}->IsUnconnected( ) ) ;
# Get all folders on host2 again since new were created
@h2_folders_all = sort $mysync->{imap2}->folders();
for ( @h2_folders_all ) {
$h2_folders_all{ $_ } = 1 ;
$mysync->{h2_folders_all_UPPER}{ uc $_ } = 1 ;
} ;
foldersizes_diff_list( $mysync, $FORCE ) ;
( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end )
= foldersizes_total( $mysync ) ;
if ( not all_defined( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) ) {
my $error = "Failure getting foldersizes, final differences will not be calculated\n" ;
errors_incr( $mysync, $error ) ;
}
return ;
}
sub foldersizes_at_the_beggining
{
my $mysync = shift @ARG ;
myprint( << 'END_SIZE' ) ;
Folders sizes before the synchronization. It can take some time. Be patient.
You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend"
but then you will also lose the ETA (Estimation Time of Arrival) given after each message copy.
END_SIZE
foldersizes_diff_list( $mysync ) ;
( $mysync->{ h1_nb_msg_start }, $mysync->{ h1_bytes_start },
$mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } )
= foldersizes_total( $mysync ) ;
if ( not all_defined(
$mysync->{ h1_nb_msg_start },
$mysync->{ h1_bytes_start },
$mysync->{ h2_nb_msg_start },
$mysync->{ h2_bytes_start } ) )
{
my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ;
errors_incr( $mysync, $error ) ;
$mysync->{ foldersizes } = 0 ;
$mysync->{ foldersizesatend } = 0 ;
return ;
}
my $h2_bytes_limit = $mysync->{ acc2 }->{quota_limit_bytes} || 0 ;
if ( $h2_bytes_limit and ( $h2_bytes_limit < $mysync->{ h1_bytes_start } ) )
{
my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $mysync->{ h1_bytes_start } / $h2_bytes_limit ) ;
my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $mysync->{ h1_bytes_start } bytes / $h2_bytes_limit bytes )\n" ;
errors_incr( $mysync, $error ) ;
}
return ;
}
# Globals:
# @h2_folders_from_1_wanted
sub foldersizes_at_the_beggining_old
{
my $mysync = shift @ARG ;
myprint( << 'END_SIZE' ) ;
Folders sizes before the synchronization.
You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend"
but then you will also lose the ETA (Estimation Time of Arrival) given after each message copy.
END_SIZE
( $mysync->{ h1_nb_msg_start }, $mysync->{ h1_bytes_start } ) =
foldersizes( $mysync, 'Host1', $mysync->{imap1}, $mysync->{ search1 },
$mysync->{abletosearch1}, @{ $mysync->{h1_folders_wanted} } ) ;
( $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } ) =
foldersizes( $mysync, 'Host2', $mysync->{imap2}, $mysync->{ search2 },
$mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ;
if ( not all_defined( $mysync->{ h1_nb_msg_start },
$mysync->{ h1_bytes_start }, $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } ) )
{
my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ;
errors_incr( $mysync, $error ) ;
$mysync->{ foldersizes } = 0 ;
$mysync->{ foldersizesatend } = 0 ;
return ;
}
my $h2_bytes_limit = $mysync->{ acc2 }->{quota_limit_bytes} || 0 ;
if ( $h2_bytes_limit and ( $h2_bytes_limit < $mysync->{ h1_bytes_start } ) )
{
my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $mysync->{ h1_bytes_start } / $h2_bytes_limit ) ;
my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $mysync->{ h1_bytes_start } bytes / $h2_bytes_limit bytes )\n" ;
errors_incr( $mysync, $error ) ;
}
return ;
}
sub tests_total_bytes_max_reached
{
note( 'Entering tests_total_bytes_max_reached()' ) ;
is( undef, total_bytes_max_reached( ), 'total_bytes_max_reached: no args => undef' ) ;
my $mysync = {} ;
is( undef, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: no exitwhenover => undef' ) ;
$mysync->{ exitwhenover } = 300 ;
is( undef, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: exitwhenover 300 but no total_bytes_transferred => undef' ) ;
$mysync->{ total_bytes_transferred } = 200 ;
is( undef, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: exitwhenover 300 but total_bytes_transferred 200 => undef' ) ;
$mysync->{ total_bytes_transferred } = 400 ;
is( 1, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: exitwhenover 300 but total_bytes_transferred 400 => 1' ) ;
note( 'Leaving tests_total_bytes_max_reached()' ) ;
return ;
}
sub total_bytes_max_reached
{
my $mysync = shift @ARG ;
if ( ! defined $mysync ) { return ; }
if ( ! $mysync->{ exitwhenover } )
{
return ;
}
if ( ! $mysync->{ total_bytes_transferred } )
{
return ;
}
if ( $mysync->{ total_bytes_transferred } >= $mysync->{ exitwhenover } )
{
my $error = "Maximum bytes transferred reached, $mysync->{total_bytes_transferred} >= $mysync->{ exitwhenover }, ending sync\n" ;
errors_incr( $mysync, $error ) ;
return( 1 ) ;
}
return ;
}
sub tests_mock_capability
{
note( 'Entering tests_mock_capability()' ) ;
my $myimap ;
ok( $myimap = mock_capability( ),
'mock_capability: (1) no args => a Test::MockObject'
) ;
ok( $myimap->isa( 'Test::MockObject' ),
'mock_capability: (2) no args => a Test::MockObject'
) ;
is( undef, $myimap->capability( ),
'mock_capability: (3) no args => capability undef'
) ;
ok( mock_capability( $myimap ),
'mock_capability: (1) one arg => MockObject'
) ;
is( undef, $myimap->capability( ),
'mock_capability: (2) one arg OO style => capability undef'
) ;
ok( mock_capability( $myimap, $NUMBER_123456 ),
'mock_capability: (1) two args 123456 => capability 123456'
) ;
is( $NUMBER_123456, $myimap->capability( ),
'mock_capability: (2) two args 123456 => capability 123456'
) ;
ok( mock_capability( $myimap, 'ABCD' ),
'mock_capability: (1) two args ABCD => capability ABCD'
) ;
is( 'ABCD', $myimap->capability( ),
'mock_capability: (2) two args ABCD => capability ABCD'
) ;
ok( mock_capability( $myimap, [ 'ABCD' ] ),
'mock_capability: (1) two args [ ABCD ] => capability [ ABCD ]'
) ;
is_deeply( [ 'ABCD' ], $myimap->capability( ),
'mock_capability: (2) two args [ ABCD ] => capability [ ABCD ]'
) ;
ok( mock_capability( $myimap, [ 'ABC', 'DEF' ] ),
'mock_capability: (1) two args [ ABC, DEF ] => capability [ ABC, DEF ]'
) ;
is_deeply( [ 'ABC', 'DEF' ], $myimap->capability( ),
'mock_capability: (2) two args [ ABC, DEF ] => capability capability [ ABC, DEF ]'
) ;
ok( mock_capability( $myimap, 'ABC', 'DEF' ),
'mock_capability: (1) two args ABC, DEF => capability [ ABC, DEF ]'
) ;
is_deeply( [ 'ABC', 'DEF' ], [ $myimap->capability( ) ],
'mock_capability: (2) two args ABC, DEF => capability capability [ ABC, DEF ]'
) ;
ok( mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ),
'mock_capability: (1) two args IMAP4rev1, APPENDLIMIT=123456 => capability [ IMAP4rev1, APPENDLIMIT=123456 ]'
) ;
is_deeply( [ 'IMAP4rev1', 'APPENDLIMIT=123456' ], [ $myimap->capability( ) ],
'mock_capability: (2) two args IMAP4rev1, APPENDLIMIT=123456 => capability capability [ IMAP4rev1, APPENDLIMIT=123456 ]'
) ;
note( 'Leaving tests_mock_capability()' ) ;
return ;
}
sub sig_install_toggle_sleep
{
my $mysync = shift @ARG ;
if ( 'MSWin32' ne $OSNAME ) {
#myprint( "sig_install( $mysync, \&toggle_sleep, 'USR1' )\n" ) ;
sig_install( $mysync, 'toggle_sleep', 'USR1' ) ;
}
#myprint( "Leaving sig_install_toggle_sleep\n" ) ;
return ;
}
sub mock_capability
{
my $myimap = shift @ARG ;
my @has_capability_value = @ARG ;
my ( $has_capability_value ) = @has_capability_value ;
if ( ! $myimap )
{
require_ok( "Test::MockObject" ) ;
$myimap = Test::MockObject->new( ) ;
}
$myimap->mock(
'capability',
sub { return wantarray ?
@has_capability_value
: $has_capability_value ;
}
) ;
return $myimap ;
}
sub tests_capability_of
{
note( 'Entering tests_capability_of()' ) ;
is( undef, capability_of( ),
'capability_of: no args => undef' ) ;
my $myimap ;
is( undef, capability_of( $myimap ),
'capability_of: undef => undef' ) ;
$myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ;
is( undef, capability_of( $myimap, 'CACA' ),
'capability_of: two args unknown capability => undef' ) ;
is( $NUMBER_123456, capability_of( $myimap, 'APPENDLIMIT' ),
'capability_of: two args APPENDLIMIT 123456 => 123456 yeah!' ) ;
note( 'Leaving tests_capability_of()' ) ;
return ;
}
sub capability_of
{
my $imap = shift || return ;
my $capability_keyword = shift || return ;
my @capability = $imap->capability ;
if ( ! @capability ) { return ; }
my $capability_value = search_in_array( $capability_keyword, @capability ) ;
return $capability_value ;
}
sub tests_search_in_array
{
note( 'Entering tests_search_in_array()' ) ;
is( undef, search_in_array( 'KA' ),
'search_in_array: no array => undef ' ) ;
is( 'VA', search_in_array( 'KA', ( 'KA=VA' ) ),
'search_in_array: KA KA=VA => VA ' ) ;
is( 'VA', search_in_array( 'KA', ( 'KA=VA', 'KB=VB' ) ),
'search_in_array: KA KA=VA KB=VB => VA ' ) ;
is( 'VB', search_in_array( 'KB', ( 'KA=VA', 'KB=VB' ) ),
'search_in_array: KA=VA KB=VB => VB ' ) ;
note( 'Leaving tests_search_in_array()' ) ;
return ;
}
sub search_in_array
{
my ( $key, @array ) = @ARG ;
foreach my $item ( @array )
{
if ( $item =~ /([^=]+)=(.*)/ )
{
if ( $1 eq $key )
{
return $2 ;
}
}
}
return ;
}
sub tests_appendlimit_from_capability
{
note( 'Entering tests_appendlimit_from_capability()' ) ;
is( undef, appendlimit_from_capability( ),
'appendlimit_from_capability: no args => undef'
) ;
my $myimap ;
is( undef, appendlimit_from_capability( $myimap ),
'appendlimit_from_capability: undef arg => undef'
) ;
$myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ;
# Normal behavior
is( $NUMBER_123456, appendlimit_from_capability( $myimap ),
'appendlimit_from_capability: APPENDLIMIT=123456 => 123456'
) ;
# Not a number
$myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=ABC' ) ;
is( undef, appendlimit_from_capability( $myimap ),
'appendlimit_from_capability: not a number => undef'
) ;
note( 'Leaving tests_appendlimit_from_capability()' ) ;
return ;
}
sub appendlimit_from_capability
{
my $myimap = shift @ARG ;
if ( ! $myimap )
{
myprint( "Warn: no imap with call to appendlimit_from_capability\n" ) ;
return ;
}
#myprint( Data::Dumper->Dump( [ \$myimap ] ) ) ;
my $appendlimit = capability_of( $myimap, 'APPENDLIMIT' ) ;
#myprint( "has_capability APPENDLIMIT $appendlimit\n" ) ;
if ( is_integer( $appendlimit ) )
{
return $appendlimit ;
}
return ;
}
sub tests_appendlimit
{
note( 'Entering tests_appendlimit()' ) ;
is( undef, appendlimit( ),
'appendlimit: no args => undef'
) ;
my $mysync = { } ;
is( undef, appendlimit( $mysync ),
'appendlimit: no imap2 => undef'
) ;
my $myimap ;
$myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ;
$mysync->{ imap2 } = $myimap ;
is( 123456, appendlimit( $mysync ),
'appendlimit: imap2 with APPENDLIMIT=123456 => 123456'
) ;
note( 'Leaving tests_appendlimit()' ) ;
return ;
}
sub appendlimit
{
my $mysync = shift || return ;
my $myimap = $mysync->{ imap2 } ;
my $appendlimit = appendlimit_from_capability( $myimap ) ;
if ( defined $appendlimit )
{
myprint( "Host2: found APPENDLIMIT=$appendlimit in CAPABILITY (use --appendlimit xxxx to override this automatic setting)\n" ) ;
return $appendlimit ;
}
return ;
}
sub tests_maxsize_setting
{
note( 'Entering tests_maxsize_setting()' ) ;
is( undef, maxsize_setting( ),
'maxsize_setting: no args => undef'
) ;
my $mysync ;
is( undef, maxsize_setting( $mysync ),
'maxsize_setting: undef arg => undef'
) ;
$mysync = { } ;
$mysync->{ maxsize } = $NUMBER_123456 ;
# --maxsize alone
is( $NUMBER_123456, maxsize_setting( $mysync ),
'maxsize_setting: --maxsize 123456 alone => 123456'
) ;
$mysync = { } ;
my $myimap ;
$myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=654321' ) ;
$mysync->{ imap2 } = $myimap ;
# APPENDLIMIT alone
is( $NUMBER_654321, maxsize_setting( $mysync ),
'maxsize_setting: APPENDLIMIT 654321 alone => 654321'
) ;
is( $NUMBER_654321, $mysync->{ maxsize },
'maxsize_setting: APPENDLIMIT 654321 alone => maxsize 654321'
) ;
# APPENDLIMIT with --appendlimit => --appendlimit wins
$mysync->{ appendlimit } = $NUMBER_123456 ;
is( $NUMBER_123456, maxsize_setting( $mysync ),
'maxsize_setting: APPENDLIMIT 654321 + --appendlimit 123456 => 123456'
) ;
is( $NUMBER_123456, $mysync->{ maxsize },
'maxsize_setting: APPENDLIMIT 654321 + --appendlimit 123456 => maxsize 123456'
) ;
# Fresh
$mysync = { } ;
$mysync->{ imap2 } = $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=654321' ) ;
# Case: "APPENDLIMIT >= --maxsize" => maxsize.
$mysync->{ maxsize } = $NUMBER_123456 ;
is( $NUMBER_123456, maxsize_setting( $mysync ),
'maxsize_setting: APPENDLIMIT 654321 --maxsize 123456 => 123456'
) ;
# Case: "APPENDLIMIT < --maxsize" => APPENDLIMIT.
# Fresh
$mysync = { } ;
$mysync->{ imap2 } = $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ;
$mysync->{ maxsize } = $NUMBER_654321 ;
is( $NUMBER_123456, maxsize_setting( $mysync ),
'maxsize_setting: APPENDLIMIT 123456 --maxsize 654321 => 123456 '
) ;
# Now --truncmess stuff
note( 'Leaving tests_maxsize_setting()' ) ;
return ;
}
# Three variables to take account of
# appendlimit (given by --appendlimit or CAPABILITY...)
# maxsize
# truncmess
sub maxsize_setting
{
my $mysync = shift || return ;
if ( defined $mysync->{ appendlimit } )
{
myprint( "Host2: Getting appendlimit from --appendlimit $mysync->{ appendlimit }\n" ) ;
}
else
{
$mysync->{ appendlimit } = appendlimit( $mysync ) ;
}
if ( all_defined( $mysync->{ appendlimit }, $mysync->{ maxsize } ) )
{
my $min_maxsize_appendlimit = min( $mysync->{ maxsize }, $mysync->{ appendlimit } ) ;
myprint( "Host2: Setting maxsize to $min_maxsize_appendlimit (min of --maxsize $mysync->{ maxsize } and appendlimit $mysync->{ appendlimit }\n" ) ;
$mysync->{ maxsize } = $min_maxsize_appendlimit ;
return $mysync->{ maxsize } ;
}
elsif ( defined $mysync->{ appendlimit } )
{
myprint( "Host2: Setting maxsize to appendlimit $mysync->{ appendlimit }\n" ) ;
$mysync->{ maxsize } = $mysync->{ appendlimit } ;
return $mysync->{ maxsize } ;
}elsif ( defined $mysync->{ maxsize } )
{
return $mysync->{ maxsize } ;
}else
{
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
{
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' ) ;
note( 'Leaving tests_all_defined()' ) ;
return ;
}
sub tests_hashsynclocal
{
note( 'Entering tests_hashsynclocal()' ) ;
my $mysync = {
host1 => q{},
user1 => q{},
password1 => q{},
host2 => q{},
user2 => q{},
password2 => q{},
} ;
is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no hashfile name' ) ;
$mysync->{ hashfile } = q{} ;
is( undef, hashsynclocal( $mysync ), 'hashsynclocal: empty hashfile name' ) ;
$mysync->{ hashfile } = './noexist/rrr' ;
is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no exists hashfile dir' ) ;
SKIP: {
if ( 'MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) { skip( 'Tests only for non-root 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' ;
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' ) ;
note( 'Leaving tests_hashsynclocal()' ) ;
return ;
}
sub hashsynclocal
{
my $mysync = shift @ARG ;
my $hashkey = shift @ARG ; # 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 ) ;
}
sub tests_hashsync
{
note( 'Entering tests_hashsync()' ) ;
is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( ), 'hashsync: no args' ) ;
is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( {}, q{} ), 'hashsync: empty args' ) ;
my $mysync ;
$mysync->{ host1 } = 'zzz' ;
is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ;
is( '6a7b451ac99eab1531ad8e6cd544b32420c552ac', hashsync( $mysync, q{A} ), 'hashsync: host1 zzz => ' ) ;
$mysync->{ host2 } = 'zzz' ;
is( '15959573e4a86763253a7aedb1a2b0c60d133dc2', hashsync( $mysync, q{} ), 'hashsync: + host2 zzz => ' ) ;
is( 'b8d4ab541b209c75928528020ca28ee43488bd8f', hashsync( $mysync, 'A' ), 'hashsync: + hashkey A => ' ) ;
$mysync = undef ;
is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( $mysync, q{} ), 'hashsync: undef $mysync' ) ;
$mysync->{ password1 } = 'abcd' ;
is( 'afa29ab8534495251ac8346a985717c54bc49c26', hashsync( $mysync, q{} ), 'hashsync: password1: abcd' ) ;
# A user reported a massive failure on /X (Thomas V. 21/04/2020 Ã 21:41 Subject: Error)
# "Wide character in subroutine entry at /usr/local/lib/perl5/site_perl/Digest/HMAC.pm"
# I can reproduce it now
# The eval is there to avoid a complete crash
# this one is fatal so it is commented
# is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', 1 / 0 , 'hashsync: 1 / 0 fatal' ) ;
my $eval ;
# this one is not fatal
is( undef, $eval = eval { 1 / 0 } , 'hashsync: 1/0 not fatal' ) ;
# this one neither
$mysync->{ password1 } = 'Ö' ;
is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', $eval = eval { hashsync( $mysync, q{} ) } , 'hashsync: password1: Ö with eval' ) ;
$mysync->{ password1 } = 'Ö' ;
is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hashsync( $mysync, q{} ), 'hashsync: password1: Ö without eval' ) ;
$mysync->{ password1 } = qq{\x{00D6}} ;
is( 'bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a', $eval = eval { hashsync( $mysync, q{} ) }, 'hashsync: password1: \x{00D6}' ) ; #
print qq{1 00D6:Ö\n} ;
print encode_utf8( qq{2 00D6:Ö\n} ) ;
print qq{3 00D6:\x{00D6}\n} ;
print encode_utf8( qq{4 00D6:\x{00D6}\n} ) ;
print qq{5 6536:收\n} ;
print encode_utf8( qq{6 6536:收\n} ) ;
# the next one prints "Wide character in print at ./imapsync line xxxx"
print qq{7 6536:\x{6536}\n} ;
print encode_utf8( qq{8 6536:\x{6536}\n} ) ;
$mysync->{ password1 } = qq{收} ;
is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hashsync( $mysync, q{} ), 'hashsync: password1: 收' ) ;
$mysync->{ password1 } = qq{\x{6536}} ;
is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', $eval = eval{ hashsync( $mysync, q{} ) }, 'hashsync: password1: \x{6536} with eval' ) ;
# No side effect.
$mysync->{ password1 } = 'abcd' ;
is( 'afa29ab8534495251ac8346a985717c54bc49c26', hashsync( $mysync, q{} ), 'hashsync: password1: abcd again' ) ;
note( 'Leaving tests_hashsync()' ) ;
return ;
}
sub hashsync
{
my $mysync = shift @ARG ;
my $hashkey = shift @ARG ;
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 ) ;
my $hashsync = hmac_sha1_hex_robust( $mystring, $hashkey ) ;
#myprint( "$hashsync\n" ) ;
return( $hashsync ) ;
}
sub tests_hmac_sha1_hex
{
note( 'Entering tests_hmac_sha1_hex()' ) ;
is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( ), 'hmac_sha1_hex: no args => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ;
is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( '' ), 'hmac_sha1_hex: empty string => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ;
is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( '', '' ), 'hmac_sha1_hex: empty strings => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ;
is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( '', '', 'caca' ), 'hmac_sha1_hex: empty strings + caca => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ;
# Good
is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex( 'Ö' ), 'hmac_sha1_hex: Ö => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ;
is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex( encode_utf8(qq{\x{00D6}}) ), 'hmac_sha1_hex: encode_utf8 \x{00D6} => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ;
# Bad
is( 'fe8dc3b9ba3e8850bb4a7b070b2279e911003af2', hmac_sha1_hex( encode_utf8( 'Ö' ) ), 'hmac_sha1_hex: encode_utf8 Ö => fe8dc3b9ba3e8850bb4a7b070b2279e911003af2' ) ;
is( 'bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a', hmac_sha1_hex( qq{\x{00D6}} ), 'hmac_sha1_hex: qq{\x{00D6}} => bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a' ) ;
# Good
is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( 'A' ), 'hmac_sha1_hex: A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ;
is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( encode_utf8(qq{\x{0041}}) ), 'hmac_sha1_hex: encode_utf8 \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ;
is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( encode_utf8( 'A' ) ), 'hmac_sha1_hex: encode_utf8 A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ;
is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( qq{\x{0041}} ), 'hmac_sha1_hex: \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ;
# Good
is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( 'A', 'B' ), 'hmac_sha1_hex: A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ;
is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( encode_utf8(qq{\x{0041}}), 'B' ), 'hmac_sha1_hex: encode_utf8 \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ;
is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( encode_utf8( 'A' ), 'B' ), 'hmac_sha1_hex: encode_utf8 A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ;
is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( qq{\x{0041}}, 'B' ), 'hmac_sha1_hex: \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ;
# http://unicode.scarfboy.com/?s=U%2B6536
# Good
is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex( '收' ), 'hmac_sha1_hex: 收 => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ;
is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex( encode_utf8(qq{\x{6536}}) ), 'hmac_sha1_hex: encode_utf8 \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ;
# Bad
is( 'e82217119628ad03e659cc89671d05ea4cee7238', hmac_sha1_hex( encode_utf8( '收' ) ), 'hmac_sha1_hex: encode_utf8 收 => e82217119628ad03e659cc89671d05ea4cee7238' ) ;
# Very very bad, perl dies...
#is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex( qq{\x{6536}} ), 'hmac_sha1_hex: \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ;
# Ok but well, bad indeed
is( undef, my $eval = eval{ hmac_sha1_hex( qq{\x{6536}} ) }, 'hmac_sha1_hex: \x{6536} => undef' ) ;
note( 'Leaving tests_hmac_sha1_hex()' ) ;
return ;
}
sub tests_hmac_sha1_hex_robust
{
note( 'Entering tests_hmac_sha1_hex_robust()' ) ;
is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( ), 'hmac_sha1_hex_robust: no args => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ;
is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( '' ), 'hmac_sha1_hex_robust: empty string => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ;
is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( '', '' ), 'hmac_sha1_hex_robust: empty strings => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ;
is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( '', '', 'caca' ), 'hmac_sha1_hex_robust: empty strings + caca => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ;
# Good
is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex_robust( 'Ö' ), 'hmac_sha1_hex_robust: Ö => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ;
is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex_robust( encode_utf8(qq{\x{00D6}}) ), 'hmac_sha1_hex_robust: encode_utf8 \x{00D6} => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ;
# Bad
is( 'fe8dc3b9ba3e8850bb4a7b070b2279e911003af2', hmac_sha1_hex_robust( encode_utf8( 'Ö' ) ), 'hmac_sha1_hex_robust: encode_utf8 Ö => fe8dc3b9ba3e8850bb4a7b070b2279e911003af2' ) ;
is( 'bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a', hmac_sha1_hex_robust( qq{\x{00D6}} ), 'hmac_sha1_hex_robust: qq{\x{00D6}} => bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a' ) ;
# Good
is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( 'A' ), 'hmac_sha1_hex_robust: A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ;
is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( encode_utf8(qq{\x{0041}}) ), 'hmac_sha1_hex_robust: encode_utf8 \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ;
is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( encode_utf8( 'A' ) ), 'hmac_sha1_hex_robust: encode_utf8 A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ;
is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( qq{\x{0041}} ), 'hmac_sha1_hex_robust: \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ;
# Good
is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( 'A', 'B' ), 'hmac_sha1_hex_robust: A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ;
is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( encode_utf8(qq{\x{0041}}), 'B' ), 'hmac_sha1_hex_robust: encode_utf8 \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ;
is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( encode_utf8( 'A' ), 'B' ), 'hmac_sha1_hex_robust: encode_utf8 A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ;
is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( qq{\x{0041}}, 'B' ), 'hmac_sha1_hex_robust: \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ;
# http://unicode.scarfboy.com/?s=U%2B6536
# Good
is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex_robust( '收' ), 'hmac_sha1_hex_robust: 收 => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ;
is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex_robust( encode_utf8(qq{\x{6536}}) ), 'hmac_sha1_hex_robust: encode_utf8 \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ;
# Bad
is( 'e82217119628ad03e659cc89671d05ea4cee7238', hmac_sha1_hex_robust( encode_utf8( '收' ) ), 'hmac_sha1_hex_robust: encode_utf8 收 => e82217119628ad03e659cc89671d05ea4cee7238' ) ;
# Good
is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex_robust( qq{\x{6536}} ), 'hmac_sha1_hex_robust: \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ;
# Good again
is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', my $eval = eval{ hmac_sha1_hex_robust( qq{\x{6536}} ) }, 'hmac_sha1_hex_robust: \x{6536} => undef' ) ;
note( 'Leaving tests_hmac_sha1_hex_robust()' ) ;
return ;
}
sub hmac_sha1_hex_robust
{
my $string = shift @ARG ;
my $val ;
if ( defined( $val = eval{ hmac_sha1_hex( $string, @ARG ) } ) )
{
return $val ;
}
elsif( defined( $val = eval{ hmac_sha1_hex( encode_utf8( $string ), @ARG ) } ) )
{
return $val ;
}
else
{
return ;
}
}
sub tests_createhashfileifneeded
{
note( 'Entering tests_createhashfileifneeded()' ) ;
is( undef, createhashfileifneeded( ), 'createhashfileifneeded: no parameters => undef' ) ;
note( 'Leaving tests_createhashfileifneeded()' ) ;
return ;
}
sub createhashfileifneeded
{
my $hashfile = shift @ARG ;
my $hashkey = shift || rand32( ) ;
# 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 ;
}
sub tests_rand32
{
note( 'Entering tests_rand32()' ) ;
my $string = rand32( ) ;
myprint( "$string\n" ) ;
is( 32, length( $string ), 'rand32: 32 characters long' ) ;
is( 32, length( rand32( ) ), 'rand32: 32 characters long, another one' ) ;
note( 'Leaving tests_rand32()' ) ;
return ;
}
sub rand32
{
my @chars = ( "a".."z" ) ;
my $string;
$string .= $chars[rand @chars] for 1..32 ;
return $string ;
}
sub imap_id_stuff
{
my $mysync = shift @ARG ;
if ( not $mysync->{id} ) { return ; } ;
$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 ;
}
sub imap_id
{
my ( $mysync, $imap, $Side ) = @_ ;
if ( not $mysync->{id} ) { return q{} ; } ;
$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( "$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 imapsync_id
{
my $mysync = shift @ARG ;
my $overhashref = shift @ARG ;
# 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' => 'https://imapsync.lamiral.info/',
# Example of date-time: 19-Sep-2015 08:56:07
date => date_from_rcs( q{$Date: 2022/09/14 18:08:24 $ } ),
} ;
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: 2022/09/14 18:08:24 $ } ),
} ;
$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_imapsync_id
{
note( 'Entering tests_imapsync_id()' ) ;
my $mysync ;
ok( '("name" "imapsync" "version" "111" "os" "beurk" "vendor" "Gilles LAMIRAL" "support-url" "https://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 format_for_imap_arg
{
my $ref = shift @ARG ;
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 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 quota
{
my ( $mysync, $imap, $side ) = @_ ;
my %side = (
h1 => 'Host1',
h2 => 'Host2',
) ;
my $Side = $side{ $side } ;
my $debug_before = $imap->Debug( ) ;
$imap->Debug( 1 ) ;
if ( not $imap->has_capability( 'QUOTA' ) )
{
myprint( "$Side: No QUOTA capability found, skipping it.\n" ) ;
$imap->Debug( $debug_before ) ;
return ;
} ;
myprint( "\n$Side: QUOTA capability found, presented in raw IMAP on next lines\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( $mysync, $getquotaroot ) ;
my $quota_current_bytes = quota_extract_storage_current_in_bytes( $mysync, $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{
$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 $mysync = {} ;
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.'
] ;
is( $NUMBER_104_857_600 * $KIBI, quota_extract_storage_limit_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_limit_in_bytes (STORAGE 1 104857600) => 104857600 * 1024') ;
$imap_output = [
'* QUOTAROOT "INBOX" "Storage quota" "Messages quota"',
'QUOTA "user-defined quota (konsoleH)" (STORAGE 988 48829 MESSAGE 20 20)',
'5 OK Getquotaroot completed.'
] ;
is( 48829 * 1024, quota_extract_storage_limit_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_limit_in_bytes (STORAGE 988 48829 MESSAGE 20 20) => 48829 * 1024') ;
note( 'Leaving tests_quota_extract_storage_limit_in_bytes()' ) ;
return ;
}
sub quota_extract_storage_limit_in_bytes
{
my $mysync = shift @ARG ;
my $imap_output = shift @ARG ;
my $limit_kb ;
$limit_kb = ( map { /STORAGE\s+\d+\s+(\d+)/x ? $1 : () } @{ $imap_output } )[0] ;
$limit_kb ||= 0 ;
$mysync->{ debug } and myprint( "storage_limit_kb = $limit_kb\n" ) ;
return( $KIBI * $limit_kb ) ;
}
sub tests_quota_extract_storage_current_in_bytes
{
note( 'Entering tests_quota_extract_storage_current_in_bytes()' ) ;
my $mysync = {} ;
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.'
] ;
is( 1*$KIBI, quota_extract_storage_current_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_current_in_bytes: 1 => 1024 ') ;
$imap_output = [
'* QUOTAROOT "INBOX" "Storage quota" "Messages quota"',
'QUOTA "user-defined quota (konsoleH)" (STORAGE 988 48829 MESSAGE 20 20)',
'5 OK Getquotaroot completed.'
] ;
is( 988 * 1024, quota_extract_storage_current_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_current_in_bytes (STORAGE 988 48829 MESSAGE 20 20) => 988 * 1024') ;
note( 'Leaving tests_quota_extract_storage_current_in_bytes()' ) ;
return ;
}
sub quota_extract_storage_current_in_bytes
{
my $mysync = shift @ARG ;
my $imap_output = shift @ARG ;
my $current_kb ;
$current_kb = ( map { /STORAGE\s+(\d+)\s+\d+/x ? $1 : () } @{ $imap_output } )[0] ;
$current_kb ||= 0 ;
$mysync->{ debug } and myprint( "storage_current_kb = $current_kb\n" ) ;
return( $KIBI * $current_kb ) ;
}
sub make_f1f2_array_to_a_hash
{
my $mysync = shift @ARG ;
%{ $mysync->{ f1f2h } } = split_around_equal( @{ $mysync->{ f1f2 } } ) ;
return ;
}
sub automap
{
my ( $mysync ) = @_ ;
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 ;
}
$mysync->{h1_special} = special_from_folders_hash( $mysync, $mysync->{imap1}, 'Host1' ) ;
$mysync->{h2_special} = special_from_folders_hash( $mysync, $mysync->{imap2}, 'Host2' ) ;
build_possible_special( $mysync ) ;
build_guess_special( $mysync ) ;
build_automap( $mysync ) ;
return ;
}
sub build_guess_special
{
my ( $mysync ) = shift @ARG ;
foreach my $h1_fold ( sort keys %{ $mysync->{h1_folders_all} } ) {
my $special = guess_special( $h1_fold, $mysync->{possible_special}, $mysync->{h1_prefix} ) ;
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 @ARG ;
$mysync->{ 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 will not add what there is at:
# http://stackoverflow.com/questions/2185391/localized-gmail-imap-folders/2185548#2185548
# because it works well without
sub build_possible_special
{
my $mysync = shift @ARG ;
my $possible_special = { } ;
# All|Archive|Drafts|Flagged|Junk|Sent|Trash
$possible_special->{'\All'} = [ 'All', 'All Messages', '&BBIEQQQ1-' ] ;
$possible_special->{'\Archive'} = [ 'Archive', 'Archives', '&BBAEQARFBDgEMg-' ] ;
$possible_special->{'\Drafts'} = [ 'Drafts', 'DRAFTS', '&BCcENQRABD0EPgQyBDgEOgQ4-', 'Szkice', 'Wersje robocze' ] ;
$possible_special->{'\Flagged'} = [ 'Flagged', 'Starred', '&BB8EPgQ8BDUERwQ1BD0EPQRLBDU-' ] ;
$possible_special->{'\Junk'} = [ 'Junk', 'junk', 'Spam', 'SPAM', '&BCEEPwQwBDw-',
'Potwierdzony spam', 'Wiadomo&AVs-ci-&AVs-mieci',
'Junk E-Mail', 'Junk Email'] ;
$possible_special->{'\Sent'} = [ 'Sent', 'Sent Messages', 'Sent Items',
'Gesendete Elemente', 'Gesendete Objekte',
'&AMk-l&AOk-ments envoy&AOk-s', 'E&AwE-le&AwE-ments envoye&AwE-s', 'Envoy&AOk-', 'Objets envoy&AOk-s',
'Elementos enviados', 'Posta inviata',
'&kAFP4W4IMH8wojCkMMYw4A-',
'&BB4EQgQ,BEAEMAQyBDsENQQ9BD0ESwQ1-',
'Elementy wys&AUI-ane'] ;
$possible_special->{'\Trash'} = [ 'Trash', 'TRASH',
'&BCMENAQwBDsENQQ9BD0ESwQ1-', '&BBoEPgRABDcEOAQ9BDA-',
'Kosz',
'Deleted Items', 'Deleted Messages' ] ;
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 ;
$mysync->{ debug } and myprint( Data::Dumper->Dump( [ $possible_special ], [ 'possible_special' ] ) ) ;
return( $possible_special ) ;
}
sub tests_special_from_folders_hash
{
note( 'Entering tests_special_from_folders_hash()' ) ;
my $mysync = {} ;
require_ok( "Test::MockObject" ) ;
my $imapT = Test::MockObject->new( ) ;
is( undef, special_from_folders_hash( ), 'special_from_folders_hash: no args' ) ;
is( undef, special_from_folders_hash( $mysync ), 'special_from_folders_hash: undef args' ) ;
is_deeply( {}, special_from_folders_hash( $mysync, $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( $mysync, $imapT ), 'special_from_folders_hash: $imap \Sent' ) ;
note( 'Leaving tests_special_from_folders_hash()' ) ;
return( ) ;
}
sub special_from_folders_hash
{
my ( $mysync, $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( $mysync, $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_errors_log
{
note( 'Entering tests_errors_log()' ) ;
is( undef, errors_log( ), 'errors_log: no args => undef' ) ;
my $mysync = {} ;
is( undef, errors_log( $mysync ), 'errors_log: empty => undef' ) ;
is_deeply( [ 'aieaie' ], [ errors_log( $mysync, 'aieaie' ) ], 'errors_log: aieaie => aieaie' ) ;
# cumulative
is_deeply( [ 'aieaie' ], [ errors_log( $mysync ) ], 'errors_log: nothing more => aieaie' ) ;
is_deeply( [ 'aieaie', 'ouille' ], [ errors_log( $mysync, 'ouille' ) ], 'errors_log: ouille => aieaie ouille' ) ;
is_deeply( [ 'aieaie', 'ouille' ], [ errors_log( $mysync ) ], 'errors_log: nothing more => aieaie ouille' ) ;
note( 'Leaving tests_errors_log()' ) ;
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_comment_of_error_type
{
note( 'Entering tests_comment_of_error_type()' ) ;
is( undef, comment_of_error_type( ), 'comment_of_error_type: no args => undef' ) ;
my $mysync = { } ;
is( undef, comment_of_error_type( $mysync ), 'comment_of_error_type: undef => undef' ) ;
is( "", comment_of_error_type( $mysync, '' ), 'comment_of_error_type: "" => ""' ) ;
is( "", comment_of_error_type( $mysync, 'blabla' ), 'comment_of_error_type: blabla => ""' ) ;
is( "", comment_of_error_type( $mysync, 'ERR_UNCLASSIFIED' ), 'comment_of_error_type: ERR_UNCLASSIFIED => ""' ) ;
like( comment_of_error_type( $mysync, 'ERR_OVERQUOTA' ), qr{100% full}, 'comment_of_error_type: ERR_OVERQUOTA => matches 100% full' ) ;
note( 'Leaving tests_comment_of_error_type()' ) ;
return ;
}
sub comment_of_error_type
{
my $mysync = shift @ARG ;
my $error_type = shift @ARG ;
if ( ! defined $mysync ) { return ; }
if ( ! defined $error_type ) { return ; }
my $comment ;
if ( exists( $COMMENT_OF_ERR_TYPE{ $error_type } ) )
{
$comment = $COMMENT_OF_ERR_TYPE{ $error_type }->( $mysync ) ;
}
else
{
$comment = "" ;
}
return $comment ;
}
sub tests_error_type
{
note( 'Entering tests_error_type()' ) ;
is( 'ERR_NOTHING_REPORTED', error_type( ), 'error_type: no args => ERR_NOTHING_REPORTED' ) ;
is( 'ERR_NOTHING_REPORTED', error_type( '' ), 'error_type: empty string => ERR_NOTHING_REPORTED' ) ;
is( 'ERR_UNCLASSIFIED', error_type( 'ERR_UNCLASSIFIED' ), 'error_type: ERR_UNCLASSIFIED => ERR_UNCLASSIFIED' ) ;
is( 'ERR_UNCLASSIFIED', error_type( 'aie' ), 'error_type: aie => ERR_UNCLASSIFIED' ) ;
is( 'ERR_UNCLASSIFIED', error_type( 'ouille' ), 'error_type: ouille => ERR_UNCLASSIFIED' ) ;
is( 'ERR_Host1_FETCH', error_type( 'Message xxx could not be fetched: blabla' ),
'error_type: could not be fetched => ERR_Host1_FETCH'
) ;
is( 'ERR_APPEND_SIZE',
error_type( 'could not append message xxx: BAD maximum message size exceeded' ),
'error_type: could not append message xxx: BAD maximum message size exceeded => ERR_APPEND_SIZE'
) ;
is( 'ERR_OVERQUOTA',
error_type( 'Quota limit will be exceeded' ),
'error_type: Quota limit will be exceeded => ERR_OVERQUOTA'
) ;
is( 'ERR_APPEND', error_type( 'could not append' ), 'error_type: could not append => ERR_APPEND' ) ;
is( 'ERR_CREATE',
error_type( 'Could not create folder' ),
'error_type: Could not create folder => ERR_CREATE'
) ;
is( 'ERR_SELECT',
error_type( 'Could not select: blabla' ),
'error_type: Could not select: blabla => ERR_SELECT'
) ;
#
#Maximum bytes transferred reached, 423 >= 100, ending sync
is( 'ERR_TRANSFER_EXCEEDED',
error_type( 'Maximum bytes transferred reached, blabla' ),
'error_type: Maximum bytes transferred reached, blabla => ERR_TRANSFER_EXCEEDED'
) ;
#
is( 'ERR_CONNECTION_FAILURE_HOST1',
error_type( 'Host1 failure: can not open imap connection on host1 [badhostkaka] with user [tata]: Unable to connect to badhostkaka: Invalid argument' ),
'error_type: can not open imap connection on host1 => ERR_CONNECTION_FAILURE_HOST1'
) ;
is( 'ERR_CONNECTION_FAILURE_HOST2',
error_type( 'Host2 failure: can not open imap connection on host2 [badhostkiki] with user [titi]: Unable to connect to badhostkiki: Invalid argument' ),
'error_type: can not open imap connection on host2 => ERR_CONNECTION_FAILURE_HOST2'
) ;
is( 'ERR_APPEND_VIRUS',
error_type( 'could not append ( Subject:[For Your Consideration], Date:["29-Nov-2016 03:21:10 -0800"], Size:[5505], Flags:[\Seen] ) to folder INBOX: 275 NO Message refused because it contains a virus' ),
'error_type: could not append ... virus => ERR_APPEND_VIRUS'
) ;
is( 'ERR_FLAGS',
error_type( 'Host2: flags msg INBOX/957910 could not add flags [PasGlop \PasGlopRe]: 33 NO Error in IMAP command received by server.' ),
'error_type: could not add flags => ERR_FLAGS'
) ;
note( 'Leaving tests_error_type()' ) ;
return ;
}
# Could be implemented with https://metacpan.org/pod/Tie::RegexpHash
# with just a hash of error regexes as keys and types as values.
sub error_type
{
my $error = shift @ARG ;
if ( ! defined $error ) { return 'ERR_NOTHING_REPORTED' ; }
if ( ! $error ) { return 'ERR_NOTHING_REPORTED' ; }
#
if ( $error =~ m{Host1 failure: Error login on} ) { return 'ERR_AUTHENTICATION_FAILURE_USER1' } ;
if ( $error =~ m{Host2 failure: Error login on} ) { return 'ERR_AUTHENTICATION_FAILURE_USER2' } ;
if ( $error =~ m{Host. failure: Can not go to tls encryption on host.} ) { return 'ERR_EXIT_TLS_FAILURE' } ;
#
if ( $error =~ m{could not be fetched:} ) { return 'ERR_Host1_FETCH' } ;
# could not append .*BAD maximum message size exceeded
# could not append.*Maximum size of appendable message has been exceeded
if ( $error =~ m{could not append .*BAD maximum message size exceeded} )
{ return 'ERR_APPEND_SIZE' ; } ;
if ( $error =~ m{could not append.*Maximum size of appendable message has been exceeded} )
{ return 'ERR_APPEND_SIZE' ; } ;
# Could not create folder *[OVERQUOTA] Not enough disk quota
# could not append .*[OVERQUOTA] Not enough disk quota
# could not append .*[OVERQUOTA] Mailbox is full / Blocks limit exceeded / Inode limit exceeded
if ( $error =~ m{OVERQUOTA} ) { return 'ERR_OVERQUOTA' ; } ;
if ( $error =~ m{Quota limit will be exceeded} ) { return 'ERR_OVERQUOTA' ; } ;
if ( $error =~ m{full: it is time to find a bigger place} ) { return 'ERR_OVERQUOTA' ; } ;
# could not append ... to folder INBOX: 276 NO Message refused because it contains a virus
if ( $error =~ m{could not append.*virus} )
{ return 'ERR_APPEND_VIRUS' ; } ;
# could not append .*Write failed 'Broken pipe'
# could not append .*timeout waiting .* for data from server
# could not append .*BAD Invalid Arguments: Unable to parse message
# could not append .*BAD Command Argument Error. 11
# could not append .*NO header limit reached
if ( $error =~ m{could not append} ) { return 'ERR_APPEND' ; } ;
# could not add flags
if ( $error =~ m{could not add flags} ) { return 'ERR_FLAGS' ; } ;
# Could not create folder .*Invalid mailbox name
if ( $error =~ m{Could not create folder} ) { return 'ERR_CREATE' ; } ;
# Could not select:.*NO [NOPERM] Permission denied
# Could not select:.*NO Mailbox doesn't exist
# Could not select:.*NO [SERVERBUG] Internal error occurred.
# Could not select:.*[CANNOT] Mailbox isn't a valid mbox file
if ( $error =~ m{Could not select:} ) { return 'ERR_SELECT' ; } ;
#Maximum bytes transferred reached, 423 >= 100, ending sync
if ( $error =~ m{Maximum bytes transferred reached} ) { return 'ERR_TRANSFER_EXCEEDED' ; } ;
if ( $error =~ m{can not open imap connection on host1} ) { return 'ERR_CONNECTION_FAILURE_HOST1' ; } ;
if ( $error =~ m{can not open imap connection on host2} ) { return 'ERR_CONNECTION_FAILURE_HOST2' ; } ;
# Default is ERR_UNCLASSIFIED
return 'ERR_UNCLASSIFIED' ;
}
sub tests_errorclassify
{
note( 'Entering tests_errorclassify()' ) ;
is( undef, errorclassify( ), 'errorclassify: no args => undef' ) ;
is_deeply( { 'ERR_UNCLASSIFIED' => 1 }, errorclassify( 'aie' ), 'errorclassify: aie => { ERR_UNCLASSIFIED => 1 }' ) ;
is_deeply( { 'ERR_UNCLASSIFIED' => 2 }, errorclassify( 'aie', 'ouille' ), 'errorclassify: aie ouille => { ERR_UNCLASSIFIED => 2 }' ) ;
is_deeply( { 'ERR_UNCLASSIFIED' => 2, 'ERR_NOTHING_REPORTED' => 1 }, errorclassify( 'aie', 'ouille', '' ), 'errorclassify: aie ouille "" => { ERR_UNCLASSIFIED => 2 }' ) ;
is_deeply( { 'ERR_UNCLASSIFIED' => 3 }, errorclassify( 'aie', 'ouille', 'aie' ), 'errorclassify: aie ouille aie => { ERR_UNCLASSIFIED => 3 }' ) ;
is_deeply( { 'ERR_UNCLASSIFIED' => 1, 'ERR_OVERQUOTA' => 2 }, errorclassify( 'aie', 'OVERQUOTA pipi', 'OVERQUOTA caca' ), 'errorclassify: aie OVERQUOTA OVERQUOTA' ) ;
is_deeply( { 'ERR_NOTHING_REPORTED' => 1 }, errorclassify( '' ), 'errorclassify: "" => { ERR_NOTHING_REPORTED => 1 }' ) ;
is_deeply( { 'ERR_NOTHING_REPORTED' => 2 }, errorclassify( '', '' ), 'errorclassify: "", "" => { ERR_NOTHING_REPORTED => 1 }' ) ;
note( 'Leaving tests_errorclassify()' ) ;
return ;
}
sub errorclassify
{
my @errors = @ARG ;
if ( ! @errors ) { return ; } ;
my $error_type_count = { } ;
foreach my $error ( @errors )
{
my $error_type = error_type( $error ) ;
$error_type_count->{ $error_type }++ ;
}
return $error_type_count ;
}
sub tests_most_common_error
{
note( 'Entering tests_most_common_error()' ) ;
is( 'ERR_NOTHING_REPORTED', most_common_error( ), 'most_common_error: no args => ERR_NOTHING_REPORTED' ) ;
is( 'ERR_NOTHING_REPORTED', most_common_error( {} ), 'most_common_error: empty hash ref => ERR_NOTHING_REPORTED' ) ;
is( 'ERR_NOTHING_REPORTED', most_common_error( 'blabla' ), 'most_common_error: not a hash ref => ERR_NOTHING_REPORTED' ) ;
is( 'ERR_FOO', most_common_error( { ERR_FOO => 1 } ), 'most_common_error: { ERR_FOO => 1 } => ERR_FOO' ) ;
is( 'ERR_BAR', most_common_error( { ERR_FOO => 1, ERR_BAR => 2 } ), 'most_common_error: { ERR_FOO => 1, ERR_BAR => 2 } => ERR_BAR' ) ;
is( 'ERR_FOO', most_common_error( { ERR_FOO => 2, ERR_BAR => 1 } ), 'most_common_error: { ERR_FOO => 2, ERR_BAR => 1 } => ERR_FOO' ) ;
# exaequo => first lexical wins. ERR_BAR <= ERR_FOO
is( 'ERR_BAR', most_common_error( { ERR_FOO => 2, ERR_BAR => 2 } ), 'most_common_error: { ERR_FOO => 2, ERR_BAR => 2 } => ERR_BAR' ) ;
is( 'A', most_common_error( { A => 5, B => 5, C => 5 } ), 'most_common_error: { A => 5, B => 5, C => 5 } => A' ) ;
is( 'B', most_common_error( { A => 5, B => 6, C => 6 } ), 'most_common_error: { A => 5, B => 6, C => 6 } => B' ) ;
is( 'C', most_common_error( { A => 5, B => 5, C => 7 } ), 'most_common_error: { A => 5, B => 5, C => 7 } => C' ) ;
is( 'C', most_common_error( { A => 5, B => 6, C => 7 } ), 'most_common_error: { A => 5, B => 5, C => 7 } => C' ) ;
note( 'Leaving tests_most_common_error()' ) ;
return ;
}
sub most_common_error
{
my $errors_counted_ref = shift @ARG ;
if ( ! defined $errors_counted_ref ) { return 'ERR_NOTHING_REPORTED' ; }
if ( 'HASH' ne ref $errors_counted_ref ) { return 'ERR_NOTHING_REPORTED' ; }
# empty hash
if ( !%{ $errors_counted_ref } ) { return 'ERR_NOTHING_REPORTED' ; }
# non empty hash
# in case of equality the winner error is the first in alphabetic order
my $most_common_error = ( sort
{
$errors_counted_ref->{$b} <=> $errors_counted_ref->{$a}
|| $a cmp $b
} keys %{$errors_counted_ref} )[0] ;
return $most_common_error ;
}
sub tests_errorsanalyse
{
note( 'Entering tests_errorsanalyse()' ) ;
is( 'ERR_NOTHING_REPORTED', errorsanalyse( ), 'errorsanalyse: no args => ERR_NOTHING_REPORTED' ) ;
is( 'ERR_NOTHING_REPORTED', errorsanalyse( ( ) ), 'errorsanalyse: empty list => ERR_NOTHING_REPORTED' ) ;
is( 'ERR_UNCLASSIFIED', errorsanalyse( 'aie' ), 'errorsanalyse: aie => ERR_UNCLASSIFIED' ) ;
# in case of equality, empty wins
is( 'ERR_NOTHING_REPORTED', errorsanalyse( 'aie', '' ), 'errorsanalyse: aie => ERR_UNCLASSIFIED' ) ;
is( 'ERR_NOTHING_REPORTED', errorsanalyse( '', 'aie' ), 'errorsanalyse: aie => ERR_UNCLASSIFIED' ) ;
is( 'ERR_UNCLASSIFIED', errorsanalyse( 'aie', 'ouille' ), 'errorsanalyse: aie, ouille => ERR_UNCLASSIFIED' ) ;
is( 'ERR_UNCLASSIFIED', errorsanalyse( 'aie', 'ouille', '' ), 'errorsanalyse: aie, ouille, "" => ERR_UNCLASSIFIED' ) ;
is( 'ERR_UNCLASSIFIED', errorsanalyse( '', 'aie', 'ouille' ), 'errorsanalyse: aie, ouille, "" => ERR_UNCLASSIFIED' ) ;
is( 'ERR_NOTHING_REPORTED', errorsanalyse( '' ), 'errorsanalyse: "" => ERR_NOTHING_REPORTED' ) ;
is( 'ERR_NOTHING_REPORTED', errorsanalyse( ( '' ) ), 'errorsanalyse: ( "" ) => ERR_NOTHING_REPORTED' ) ;
is( 'ERR_NOTHING_REPORTED', errorsanalyse( ( '', '' ) ), 'errorsanalyse: ( "", "" ) => ERR_NOTHING_REPORTED' ) ;
note( 'Leaving tests_errorsanalyse()' ) ;
return ;
}
sub errorsanalyse
{
my @errors = @ARG ;
my $errors_types_counted = errorclassify( @errors ) ;
my $most_common_error = most_common_error( $errors_types_counted ) ;
return $most_common_error ;
}
sub tests_errorsdump
{
note( 'Entering tests_errorsdump()' ) ;
is( undef, errorsdump( ), 'errorsdump: no args => undef' ) ;
is( undef, errorsdump( ( ) ), 'errorsdump: empty list => undef' ) ;
is( "Err 1/1: ", errorsdump( '' ), 'errorsdump: one empty string => "Err 1/1: "' ) ;
is( "Err 1/1: aieaieaie", errorsdump( 'aieaieaie' ), 'errorsdump: aieaieaie => "Err 1/1: aieaieaie"' ) ;
is( "Err 1/2: Aie Err 2/2: Ouille", errorsdump( 'Aie ', 'Ouille' ), 'errorsdump: Aie Ouille => "Err 1/2: Aie Err 2/2: Ouille"' ) ;
note( 'Leaving tests_errorsdump()' ) ;
return ;
}
sub errorsdump
{
if ( ! @ARG ) { return ; }
my @errors_log = @ARG ;
my $nb_errors = @errors_log ;
my $error_num = 0 ;
my $errors_list = q{} ;
if ( @errors_log ) {
foreach my $error ( @errors_log )
{
$error_num++ ;
$errors_list .= "Err $error_num/$nb_errors: $error" ;
}
}
return( $errors_list ) ;
}
sub errors_listing
{
my $mysync = shift @ARG ;
$mysync->{ most_common_error } = errorsanalyse( errors_log( $mysync ) ) ;
my $errors_listing = '' ;
if ( $mysync->{ errorsdump } )
{
$errors_listing = join( '',
"++++ Listing $mysync->{nb_errors} errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n",
errorsdump( errors_log( $mysync ) ),
) ;
}
$errors_listing .= join( '',
"The most frequent error is $mysync->{ most_common_error }. ",
comment_of_error_type( $mysync, $mysync->{ most_common_error } ),
"\n",
) ;
return $errors_listing ;
}
sub errors_incr
{
my ( $mysync, @error ) = @ARG ;
$mysync->{ nb_errors }++ ;
if ( @error ) {
errors_log( $mysync, @error ) ;
myprint( @error ) ;
}
$mysync->{ errorsmax } ||= $ERRORS_MAX ;
if ( $mysync->{ nb_errors } >= $mysync->{ errorsmax } )
{
myprint( errorsmax_msg( $mysync ) ) ;
myprint( errors_listing( $mysync ) ) ;
if ( $mysync->{ errorsdump } )
{
# again since errorsdump( ) can be very verbose and masquerade previous warning
myprint( errorsmax_msg( $mysync ) ) ;
}
my $exit_value = exit_value( $mysync, $mysync->{ most_common_error } ) ;
exit_clean( $mysync, $exit_value ) ;
}
return ;
}
sub errorsmax_msg
{
my $mysync = shift @ARG ;
my $msg = "Maximum number of errors $mysync->{errorsmax} reached "
. "( you can change $mysync->{errorsmax} to any value, for example 100 with --errorsmax 100 ). "
. "Exiting.\n" ;
return $msg ;
}
sub tests_live_result
{
note( 'Entering tests_live_result()' ) ;
my $nb_errors = shift @ARG ;
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 size_filtered_flag
{
my $mysync = shift @ARG ;
my $h1_size = shift @ARG ;
if ( defined $mysync->{ maxsize } and $h1_size >= $mysync->{ maxsize } ) {
return( 1 ) ;
}
if ( defined $minsize and $h1_size <= $minsize ) {
return( 1 ) ;
}
return( 0 ) ;
}
sub sync_flags_fir
{
my ( $mysync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $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( $mysync, $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( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags ) ;
return ;
}
sub sync_flags_after_copy
{
# Activated with option --syncflagsaftercopy
my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg ) = @_ ;
if ( my @h2_flags = $mysync->{imap2}->flags( $h2_msg ) ) {
my $h2_flags = "@h2_flags" ;
( $mysync->{ debug } or $mysync->{ debugflags } ) and myprint( "Host2: msg $h2_fold/$h2_msg flags before sync flags after copy ( $h2_flags )\n" ) ;
sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags ) ;
}else{
myprint( "Host2: msg $h2_fold/$h2_msg could not get its flags for sync flags after copy\n" ) ;
}
return ;
}
sub sync_flags
{
my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags ) = @_ ;
( $mysync->{ debug } or $mysync->{ debugflags } ) and
myprint( "Host1: flags init msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ;
$h1_flags = flags_for_host2( $mysync, $h1_flags, $mysync->{ permanentflags2 } ) ;
$h2_flags = flagscase( $h2_flags ) ;
( $mysync->{ debug } or $mysync->{ debugflags } ) and
myprint( "Host1: flags filt msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ;
# 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 ( $mysync->{ debug } or $mysync->{ debugflags } )
and myprint( "Host2: flags msg $h2_fold/$h2_msg replacing h2 flags( $h2_flags ) with h1 flags( $h1_flags )\n" ) ;
# This sets flags exactly. So flags can be removed with this.
# When you remove a \Seen flag on host1 you want it
# to be removed on host2. Just add flags is not what
# we need most of the time, so no + like in "+FLAGS.SILENT".
if ( not $mysync->{ dry } and $diff and not $mysync->{ imap2 }->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) {
my $error_msg = join q{}, "Host2: flags msg $h2_fold/$h2_msg could not add flags [@h1_flags]: ",
$mysync->{ imap2 }->LastError || q{}, "\n" ;
errors_incr( $mysync, $error_msg ) ;
}
return ;
}
sub _filter
{
my $mysync = shift @ARG ;
my $str = shift or return q{} ;
my $sz = $SIZE_MAX_STR ;
my $len = length $str ;
if ( not $mysync->{ 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( $mysync, $imap, $error_message ) = @_;
if ( $imap->IsUnconnected( ) ) {
$mysync->{nb_errors}++ ;
my $lcomm = $imap->LastIMAPCommand || q{} ;
my $einfo = imap_last_error( $imap ) ;
# if string is long try reduce to a more reasonable size
$lcomm = _filter( $mysync, $lcomm ) ;
$einfo = _filter( $mysync, $einfo ) ;
myprint( "Failure: last command: $lcomm\n") if ( $mysync->{ debug } && $lcomm) ;
myprint( "Failure: lost connection $error_message: ", $einfo, "\n") ;
return( 1 ) ;
}
else{
return( 0 ) ;
}
}
sub imap_last_error
{
my $imap = shift @ARG ;
my $einfo = $imap->LastError || @{$imap->History}[$LAST] || q{} ;
chomp( $einfo ) ;
return( $einfo ) ;
}
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( undef, max( undef ), 'undef => undef' ) ;
is( undef, max( undef, undef ), 'undef, undef => 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( $NUMBER_100, max( 'bb', $NUMBER_100, 'haha' ), 'max bb 100 haha => 100') ;
is( $MINUS_ONE, max( q{}, $MINUS_ONE, 'haha' ), 'max "" -1 haha => -1') ;
is( $MINUS_ONE, max( q{}, $MINUS_ONE, $MINUS_TWO ), 'max "" -1 -2 => -1') ;
is( $MINUS_ONE, max( 'haha', $MINUS_ONE, $MINUS_TWO ), 'max haha -1 -2 => -1') ;
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') ;
is( 'bb', max( 'bb', 'aa', 'bb' ), 'max bb aa bb => bb') ;
note( 'Leaving tests_max()' ) ;
return ;
}
sub max
{
my @list = @_ ;
return( undef ) if ( 0 == scalar @list ) ;
my( @numbers, @notnumbers ) ;
foreach my $item ( @list )
{
if ( is_number( $item ) )
{
push @numbers, $item ;
}
elsif ( defined $item )
{
push @notnumbers, $item ;
}
}
my @sorted ;
if ( @numbers )
{
@sorted = sort { $a <=> $b } @numbers ;
}
elsif ( @notnumbers )
{
@sorted = sort { $a cmp $b } @notnumbers ;
}
else
{
return ;
}
return( pop @sorted ) ;
}
sub tests_is_number
{
note( 'Entering tests_is_number()' ) ;
is( undef, is_number( ), 'is_number: no args => undef ' ) ;
is( undef, is_number( undef ), 'is_number: undef => undef ' ) ;
ok( is_number( 1 ), 'is_number: 1 => 1' ) ;
ok( is_number( 1.1 ), 'is_number: 1.1 => 1' ) ;
ok( is_number( 0 ), 'is_number: 0 => 1' ) ;
ok( is_number( -1 ), 'is_number: -1 => 1' ) ;
ok( ! is_number( 1.1.1 ), 'is_number: 1.1.1 => no' ) ;
ok( ! is_number( q{} ), 'is_number: q{} => no' ) ;
ok( ! is_number( 'haha' ), 'is_number: haha => no' ) ;
ok( ! is_number( '0haha' ), 'is_number: 0haha => no' ) ;
ok( ! is_number( '2haha' ), 'is_number: 2haha => no' ) ;
ok( ! is_number( 'haha2' ), 'is_number: haha2 => no' ) ;
note( 'Leaving tests_is_number()' ) ;
return ;
}
sub is_number
{
my $item = shift @ARG ;
if ( ! defined $item ) { return ; }
if ( $item =~ /\A$RE{num}{real}\Z/ ) {
return 1 ;
}
return ;
}
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( 1, min( $NUMBER_100, 'haha', 1 ), 'min 100 haha 1 => 1') ;
is( $MINUS_ONE, min( $MINUS_ONE, 1 ), 'min -1 1 => -1') ;
is( 1, min( undef, 1 ), 'min undef 1 => 1' ) ;
is( 0, min( undef, 0 ), 'min undef 0 => 0' ) ;
is( 1, min( undef, 1 ), 'min undef 1 => 1' ) ;
is( 0, min( undef, 2, 0, 1 ), 'min undef, 2, 0, 1 => 0' ) ;
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 min
{
my @list = @_ ;
return( undef ) if ( 0 == scalar @list ) ;
my( @numbers, @notnumbers ) ;
foreach my $item ( @list ) {
if ( is_number( $item ) ) {
push @numbers, $item ;
}else{
push @notnumbers, $item ;
}
}
my @sorted ;
if ( @numbers ) {
@sorted = sort { $a <=> $b } @numbers ;
}elsif( @notnumbers ) {
@sorted = sort { $a cmp $b } @notnumbers ;
}else{
return ;
}
return( shift @sorted ) ;
}
sub check_lib_version
{
my $mysync = shift @ARG ;
$mysync->{ debug } and myprint( "IMAPClient $Mail::IMAPClient::VERSION\n" ) ;
if ( '2.2.9' eq $Mail::IMAPClient::VERSION ) {
myprint( "imapsync no longer supports Mail::IMAPClient 2.2.9, upgrade it\n" ) ;
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 },
'CGI' => sub { $CGI::VERSION },
'Compress::Zlib' => sub { $Compress::Zlib::VERSION },
'Crypt::OpenSSL::RSA' => sub { $Crypt::OpenSSL::RSA::VERSION },
'Data::Uniqid' => sub { $Data::Uniqid::VERSION },
'Digest::HMAC_MD5' => sub { $Digest::HMAC_MD5::VERSION },
'Digest::HMAC_SHA1' => sub { $Digest::HMAC_SHA1::VERSION },
'Digest::MD5' => sub { $Digest::MD5::VERSION },
'Encode' => sub { $Encode::VERSION },
'Encode::IMAPUTF7' => sub { $Encode::IMAPUTF7::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' => sub { $IO::Socket::VERSION },
'IO::Socket::INET' => sub { $IO::Socket::INET::VERSION },
'IO::Socket::INET6' => sub { $IO::Socket::INET6::VERSION },
'IO::Socket::IP' => sub { $IO::Socket::IP::VERSION },
'IO::Socket::SSL' => sub { $IO::Socket::SSL::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 },
'MIME::Base64' => sub { $MIME::Base64::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 ) ;
}
sub tests_command_line_nopassword
{
note( 'Entering tests_command_line_nopassword()' ) ;
ok( q{} eq command_line_nopassword(), 'command_line_nopassword void' );
my $mysync = {} ;
ok( '--blabla' eq command_line_nopassword( $mysync, '--blabla' ), 'command_line_nopassword --blabla' );
#myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ;
ok( '--password1 MASKED' eq command_line_nopassword( $mysync, qw{ --password1 secret1}), 'command_line_nopassword --password1' );
ok( '--blabla --password1 MASKED --blibli'
eq command_line_nopassword( $mysync, qw{ --blabla --password1 secret1 --blibli } ), 'command_line_nopassword --password1 --blibli' );
$mysync->{showpasswords} = 1 ;
ok( q{} eq command_line_nopassword(), 'command_line_nopassword void' );
ok( '--blabla' eq command_line_nopassword( $mysync, '--blabla'), 'command_line_nopassword --blabla' );
#myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ;
ok( '--password1 secret1' eq command_line_nopassword( $mysync, qw{ --password1 secret1} ), 'command_line_nopassword --password1' );
ok( '--blabla --password1 secret1 --blibli'
eq command_line_nopassword( $mysync, qw{ --blabla --password1 secret1 --blibli } ), 'command_line_nopassword --password1 --blibli' );
note( 'Leaving tests_command_line_nopassword()' ) ;
return ;
}
# Construct a command line copy with passwords replaced by MASKED.
sub command_line_nopassword
{
my $mysync = shift @ARG ;
my @argv = @ARG ;
my @argv_nopassword ;
if ( $mysync->{ cmdcgi } ) {
@argv_nopassword = mask_password_value( @{ $mysync->{ cmdcgi } } ) ;
return( "@argv_nopassword" ) ;
}
if ( $mysync->{showpasswords} )
{
return( "@argv" ) ;
}
@argv_nopassword = mask_password_value( @argv ) ;
return("@argv_nopassword") ;
}
sub mask_password_value
{
my @argv = @ARG ;
my @argv_nopassword ;
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_get_stdin_masked
{
note( 'Entering tests_get_stdin_masked()' ) ;
is( q{}, get_stdin_masked( ), 'get_stdin_masked: no args' ) ;
is( q{}, get_stdin_masked( 'Please ENTER: ' ), 'get_stdin_masked: ENTER' ) ;
note( 'Leaving tests_get_stdin_masked()' ) ;
return ;
}
#######################################################
# The issue is that prompt() does not prompt the prompt
# when the program is used like
# { sleep 2 ; echo blablabla ; } | ./imapsync ...--host1 lo --user1 tata --host2 lo --user2 titi
# use IO::Prompter ;
sub get_stdin_masked
{
my $prompt = shift || 'Say something: ' ;
local @ARGV = () ;
my $input = prompt(
-prompt => $prompt,
-echo => '*',
) ;
#myprint( "You said: $input\n" ) ;
return $input ;
}
sub ask_for_password_new
{
my $prompt = shift @ARG ;
my $password = get_stdin_masked( $prompt ) ;
return $password ;
}
#########################################################
sub ask_for_password
{
my $prompt = shift @ARG ;
myprint( $prompt ) ;
Term::ReadKey::ReadMode( 2 ) ;
## no critic (InputOutput::ProhibitExplicitStdin)
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 @ARG ;
$mysync->{ password1 }
|| $mysync->{ passfile1 }
|| 'PREAUTH' eq $mysync->{ acc1 }->{ authmech }
|| 'EXTERNAL' eq $mysync->{ acc1 }->{ authmech }
|| $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
my $user = $mysync->{ acc1 }->{ authuser } || $mysync->{ user1 } ;
my $host = $mysync->{ host1 } ;
my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ;
$mysync->{password1} = ask_for_password( $prompt ) ;
} ;
if ( defined $mysync->{ passfile1 } ) {
if ( ! -e -r $mysync->{ passfile1 } ) {
myprint( "Failure: file from parameter --passfile1 $mysync->{ passfile1 } does not exist or is not readable\n" ) ;
$mysync->{nb_errors}++ ;
exit_clean( $mysync, $EX_NOINPUT ) ;
}
# passfile1 readable
$mysync->{password1} = firstline ( $mysync->{ passfile1 } ) ;
return ;
}
if ( $ENV{IMAPSYNC_PASSWORD1} ) {
$mysync->{password1} = $ENV{IMAPSYNC_PASSWORD1} ;
return ;
}
return ;
}
sub get_password2
{
my $mysync = shift @ARG ;
$mysync->{password2}
|| $mysync->{ passfile2 }
|| 'PREAUTH' eq $mysync->{ acc2 }->{ authmech }
|| 'EXTERNAL' eq $mysync->{ acc2 }->{ authmech }
|| $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
my $user = $mysync->{ acc2 }->{ authuser } || $mysync->{ user2 } ;
my $host = $mysync->{ host2 } ;
my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ;
$mysync->{password2} = ask_for_password( $prompt ) ;
} ;
if ( defined $mysync->{ passfile2 } ) {
if ( ! -e -r $mysync->{ passfile2 } ) {
myprint( "Failure: file from parameter --passfile2 $mysync->{ passfile2 } does not exist or is not readable\n" ) ;
$mysync->{nb_errors}++ ;
exit_clean( $mysync, $EX_NOINPUT ) ;
}
# passfile2 readable
$mysync->{password2} = firstline ( $mysync->{ passfile2 } ) ;
return ;
}
if ( $ENV{IMAPSYNC_PASSWORD2} ) {
$mysync->{password2} = $ENV{IMAPSYNC_PASSWORD2} ;
return ;
}
return ;
}
sub remove_tmp_files
{
my $mysync = shift or return ;
$mysync->{pidfile} or return ;
if ( -e $mysync->{pidfile} ) {
myprint( "Removing pidfile $mysync->{pidfile}\n" ) ;
unlink $mysync->{pidfile} ;
}
if ( -e $mysync->{abortfile} ) {
myprint( "Removing pidfile $mysync->{abortfile}\n" ) ;
unlink $mysync->{abortfile} ;
}
return ;
}
sub cleanup_before_exit
{
my $mysync = shift @ARG ;
remove_tmp_files( $mysync ) ;
if ( $mysync->{ imap1 } and $mysync->{ imap1 }->IsConnected() )
{
myprint( "Disconnecting from host1 $mysync->{ host1 } user1 $mysync->{ user1 }\n" ) ;
$mysync->{ imap1 }->logout( ) ;
}
if ( $mysync->{ imap2 } and $mysync->{ imap2 }->IsConnected() )
{
myprint( "Disconnecting from host2 $mysync->{ host2 } user2 $mysync->{ user2 }\n" ) ;
$mysync->{ imap2 }->logout( ) ;
}
if ( $mysync->{ log } ) {
myprint( "Log file is $mysync->{logfile} ( to change it, use --logfile filepath ; or use --nolog to turn off logging )\n" ) ;
}
else
{
myprint( "No log file because of option --nolog\n" ) ;
}
if ( $mysync->{ log } ) {
#print( "Closing $mysync->{ logfile }\n" ) ;
teefinish( $mysync->{ tee } ) ;
}
$IO::Socket::SSL::DEBUG = 1 ;
return ;
}
sub tests_exit_value
{
note( 'Entering tests_exit_value()' ) ;
is( $EXIT_CATCH_ALL, exit_value( ), 'exit_value: no args => EXIT_CATCH_ALL' ) ;
my $mysync = { } ;
is( $EXIT_CATCH_ALL, exit_value( $mysync ), 'exit_value: undef => EXIT_CATCH_ALL' ) ;
is( $EXIT_CATCH_ALL, exit_value( $mysync, 'Blabla_unknown' ), 'exit_value: Blabla => EXIT_CATCH_ALL' ) ;
is( $EXIT_CATCH_ALL, exit_value( $mysync, '' ), 'exit_value: empty => EXIT_CATCH_ALL' ) ;
is( $EXIT_OVERQUOTA, exit_value( $mysync, 'ERR_OVERQUOTA' ), 'exit_value: ERR_OVERQUOTA => EXIT_OVERQUOTA' ) ;
is( $EXIT_TRANSFER_EXCEEDED, exit_value( $mysync, 'ERR_TRANSFER_EXCEEDED' ), 'exit_value: ERR_TRANSFER_EXCEEDED => EXIT_TRANSFER_EXCEEDED' ) ;
note( 'Leaving tests_exit_value()' ) ;
return ;
}
sub exit_value
{
my $mysync = shift @ARG ;
my $most_common_error = shift @ARG ;
if ( ! defined $most_common_error ) { return $EXIT_CATCH_ALL ; }
my $exit_value = $EXIT_VALUE_OF_ERR_TYPE{ $most_common_error } || $EXIT_CATCH_ALL ;
return $exit_value ;
}
sub exit_most_errors
{
my $mysync = shift @ARG ;
myprint( errors_listing( $mysync ) ) ;
my $exit_value = exit_value( $mysync, $mysync->{ most_common_error } ) ;
exit_clean( $mysync, $exit_value ) ;
return ;
}
sub exit_clean
{
my $mysync = shift @ARG ;
my $status = shift @ARG ;
my @messages = @ARG ;
if ( @messages )
{
myprint( @messages ) ;
}
myprint( "Exiting with return value $status ($EXIT_TXT{$status}) $mysync->{nb_errors}/$mysync->{errorsmax} nb_errors/max_errors PID $PROCESS_ID\n" ) ;
cleanup_before_exit( $mysync ) ;
exit $status ;
}
sub missing_option
{
my $mysync = shift @ARG ;
my $option = shift @ARG ;
$mysync->{nb_errors}++ ;
exit_clean( $mysync, $EX_USAGE, "$option option is mandatory, for help run $PROGRAM_NAME --help\n" ) ;
return ;
}
sub catch_ignore
{
my $mysync = shift @ARG ;
my $signame = shift @ARG ;
my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ;
myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ),
"). Received $sigcounter $signame signals so far. Thanks!\n" ) ;
do_and_print_stats( $mysync ) ;
return ;
}
sub catch_exit
{
my $mysync = shift @ARG ;
my $signame = shift || q{} ;
if ( $signame ) {
myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ),
"). Asked to terminate\n" ) ;
if ( $mysync->{can_do_stats} ) {
do_and_print_stats( $mysync ) ;
myprint( "Ended by a signal $signame (my PID is $PROCESS_ID my PPID is ",
mygetppid( ), "). I am asked to terminate immediately.\n" ) ;
}
myprint( "You should resynchronize those accounts by running a sync again,\n",
"since some messages and entire folders might still be missing on host2.\n"
) ;
## no critic (RequireLocalizedPunctuationVars)
# Well, restore default action does not work well
$SIG{ $signame } = 'DEFAULT'; # restore default action
#$SIG{ 'TERM' } = 'DEFAULT'; # restore default action
# kill myself with $signame
# https://www.cons.org/cracauer/sigint.html
myprint( "Killing myself with signal $signame\n" ) ;
#cleanup_before_exit( $mysync ) ;
kill( $signame, $PROCESS_ID ) ;
#kill( 'TERM', $PROCESS_ID ) ;
#sleep 1 ;
#while ( 1 ) { } ;
$mysync->{nb_errors}++ ;
exit_clean( $mysync, $EXIT_BY_SIGNAL,
"Still there after killing myself with signal $signame...\n"
) ;
}
else
{
$mysync->{nb_errors}++ ;
exit_clean( $mysync, $EXIT_BY_SIGNAL, "Exiting in catch_exit with no signal...\n" ) ;
}
return ;
}
sub catch_print
{
my $mysync = shift @ARG ;
my $signame = shift @ARG ;
my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ;
myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ),
"). Received $sigcounter $signame signals so far. Thanks!\n" ) ;
return ;
}
sub here_twice
{
my $mysync = shift @ARG ;
my $now = time ;
my $previous = $mysync->{lastcatch} || 0 ;
$mysync->{lastcatch} = $now ;
if ( $INTERVAL_TO_EXIT >= $now - $previous ) {
return $TRUE ;
}else{
return $FALSE ;
}
}
sub catch_reconnect
{
my $mysync = shift @ARG ;
my $signame = shift @ARG ;
if ( here_twice( $mysync ) ) {
myprint( "Got two signals $signame within $INTERVAL_TO_EXIT seconds. Exiting...\n" ) ;
catch_exit( $mysync, $signame ) ;
}else{
myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ), ")\n",
"Hit 2 ctr-c within 2 seconds to exit the program\n",
"Hit only 1 ctr-c to reconnect to both imap servers\n",
) ;
myprint( "For now only one signal $signame within $INTERVAL_TO_EXIT seconds.\n" ) ;
if ( ! defined $mysync->{imap1} ) { return ; }
if ( ! defined $mysync->{imap2} ) { return ; }
myprint( "Info: reconnecting to host1 imap server $mysync->{host1}\n" ) ;
$mysync->{imap1}->State( Mail::IMAPClient::Unconnected ) ;
$mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT} += 1 ;
if ( $mysync->{imap1}->reconnect( ) )
{
myprint( "Info: reconnected to host1 imap server $mysync->{host1}\n" ) ;
}
else
{
$mysync->{nb_errors}++ ;
exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ;
}
myprint( "Info: reconnecting to host2 imap server\n" ) ;
$mysync->{imap2}->State( Mail::IMAPClient::Unconnected ) ;
$mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT} += 1 ;
if ( $mysync->{imap2}->reconnect( ) )
{
myprint( "Info: reconnected to host2 imap server $mysync->{host2}\n" ) ;
}
else
{
$mysync->{nb_errors}++ ;
exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ;
}
myprint( "Info: reconnected to both imap servers\n" ) ;
}
return ;
}
sub install_signals
{
my $mysync = shift @ARG ;
if ( under_docker_context( $mysync ) )
{
# output( $mysync, "Under docker context so leaving signals as they are\n" ) ;
output( $mysync, "Under docker context so installing only signals to exit\n" ) ;
@{ $mysync->{ sigexit } } = ( defined( $mysync->{ sigexit } ) ) ? @{ $mysync->{ sigexit } } : ( 'INT', 'QUIT', 'TERM' ) ;
sig_install( $mysync, 'catch_exit', @{ $mysync->{ sigexit } } ) ;
}
else
{
# Unix signals
@{ $mysync->{ sigexit } } = ( defined( $mysync->{ sigexit } ) ) ? @{ $mysync->{ sigexit } } : ( 'QUIT', 'TERM' ) ;
@{ $mysync->{ sigreconnect } } = ( defined( $mysync->{ sigreconnect } ) ) ? @{ $mysync->{ sigreconnect } } : ( 'INT' ) ;
@{ $mysync->{ sigprint } } = ( defined( $mysync->{ sigprint } ) ) ? @{ $mysync->{ sigprint } } : ( 'HUP' ) ;
@{ $mysync->{ sigignore } } = ( defined( $mysync->{ sigignore } ) ) ? @{ $mysync->{ sigignore } } : ( ) ;
#local %SIG = %SIG ;
sig_install( $mysync, 'catch_exit', @{ $mysync->{ sigexit } } ) ;
sig_install( $mysync, 'catch_reconnect', @{ $mysync->{ sigreconnect } } ) ;
sig_install( $mysync, 'catch_print', @{ $mysync->{ sigprint } } ) ;
# --sigignore can override sigexit, sigreconnect and sigprint (for the same signals only)
sig_install( $mysync, 'catch_ignore', @{ $mysync->{ sigignore } } ) ;
# remove/add sleeping mechanism when receiving USR1 signal (except on Win32)
sig_install_toggle_sleep( $mysync ) ;
}
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 @ARG ;
#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 @ARG ;
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 justconnect
{
my $mysync = shift @ARG ;
my $justconnect1 = justconnect1( $sync ) ;
my $justconnect2 = justconnect2( $sync ) ;
return "$justconnect1 $justconnect2";
}
sub justconnect1
{
my $mysync = shift @ARG ;
if ( $mysync->{host1} )
{
myprint( "Host1: Will just connect to $mysync->{host1} without login\n" ) ;
$mysync->{imap1} = connect_imap(
$mysync->{host1}, $mysync->{port1},
$mysync->{ssl1}, $mysync->{tls1},
$mysync->{ acc1 } ) ;
imap_id( $mysync, $mysync->{imap1}, $mysync->{ acc1 }->{ Side } ) ;
$mysync->{imap1}->logout( ) ;
return $mysync->{host1} ;
}
return q{} ;
}
sub justconnect2
{
my $mysync = shift @ARG ;
if ( $mysync->{host2} )
{
myprint( "Host2: Will just connect to $mysync->{host2} without login\n" ) ;
$mysync->{imap2} = connect_imap(
$mysync->{host2}, $mysync->{port2},
$mysync->{ssl2}, $mysync->{tls2},
$mysync->{ acc2 } ) ;
imap_id( $mysync, $mysync->{imap2}, $mysync->{ acc2 }->{ Side } ) ;
$mysync->{imap2}->logout( ) ;
return $mysync->{host2} ;
}
return q{} ;
}
sub skip_macosx
{
#return ;
# hostname is sometimes "macosx.polarhome.com" sometimes "macosx"
return( ( ( 'macosx.polarhome.com' eq hostname( ) ) || ( 'macosx' eq hostname( ) ) )
&& ( 'darwin' eq $OSNAME ) ) ;
}
sub skip_macosx_binary
{
#return ;
return( skip_macosx( ) && ( $PROGRAM_NAME =~ m{imapsync_bin_Darwin} ) ) ;
}
sub tests_mailimapclient_connect
{
note( 'Entering tests_mailimapclient_connect()' ) ;
my $imap ;
# ipv4
ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4: new' ) ;
is( 'Mail::IMAPClient', ref( $imap ), 'mailimapclient_connect ipv4: ref is Mail::IMAPClient' ) ;
# Mail::IMAPClient 3.40 die on this... So we skip it, thanks to "mature" IO::Socket::IP
# Mail::IMAPClient 3.42 is ok so this test is back.
is( undef, $imap->connect( ), 'mailimapclient_connect ipv4: connect with no server => failure' ) ;
is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4: setting Server(test.lamiral.info)' ) ;
is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4: setting Debug( 1 )' ) ;
is( 143, $imap->Port( 143 ), 'mailimapclient_connect ipv4: setting Port( 143 )' ) ;
is( 10, $imap->Timeout( 10 ), 'mailimapclient_connect ipv4: setting Timeout( 10 )' ) ;
like( ref( $imap->connect( ) ), qr/IO::Socket::INET|IO::Socket::IP/, 'mailimapclient_connect ipv4: connect to test.lamiral.info' ) ;
like( $imap->logout( ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv4: logout' ) ;
is( undef, undef $imap, 'mailimapclient_connect ipv4: free variable' ) ;
# ipv4 + ssl
ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4 + ssl: new' ) ;
is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4 + ssl: setting Server(test.lamiral.info)' ) ;
is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4 + ssl: setting Debug( 1 )' ) ;
ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'mailimapclient_connect ipv4 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ;
is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv4 + ssl: setting Port( 993 )' ) ;
like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv4 + ssl: connect to test.lamiral.info' ) ;
like( $imap->logout( ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv4 + ssl: logout in ssl does not cause failure' ) ;
is( undef, undef $imap, 'mailimapclient_connect ipv4 + ssl: free variable' ) ;
# ipv6 + ssl
ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv6 + ssl: new' ) ;
is( 'petiteipv6.lamiral.info', $imap->Server( 'petiteipv6.lamiral.info' ), 'mailimapclient_connect ipv6 + ssl: setting Server petiteipv6.lamiral.info' ) ;
is( 10, $imap->Timeout( 10 ), 'mailimapclient_connect ipv6: setting Timeout( 10 )' ) ;
ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'mailimapclient_connect ipv6 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ;
is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv6 + ssl: setting Port( 993 )' ) ;
SKIP: {
if (
'CUILLERE' eq hostname()
or
skip_macosx()
or
-e '/.dockerenv'
or
'pcHPDV7-HP' eq hostname()
)
{
skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 4 ) ;
}
is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4 + ssl: setting Debug( 1 )' ) ;
# It sounds stupid but it avoids failures on the next test about $imap->connect
is( '2a01:e34:ecde:70d0:223:54ff:fec2:36d7', resolv( 'petiteipv6.lamiral.info' ), 'resolv: petiteipv6.lamiral.info => 2a01:e34:ecde:70d0:223:54ff:fec2:36d7' ) ;
like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv6 + ssl: connect to petiteipv6.lamiral.info' ) ;
# This one is ok on petite, not on ks2, do not know why, so commented.
like( ref( $imap->logout( ) ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv6 + ssl: logout in ssl is ok on petiteipv6.lamiral.info' ) ;
}
is( undef, undef $imap, 'mailimapclient_connect ipv6 + ssl: free variable' ) ;
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_bug ipv6: new' ) ;
is( 'ks6ipv6.lamiral.info', $imap->Server( 'ks6ipv6.lamiral.info' ), 'mailimapclient_connect_bug ipv6: setting Server(ks6ipv6.lamiral.info)' ) ;
is( 143, $imap->Port( 143 ), 'mailimapclient_connect_bug ipv6: setting Port( 993 )' ) ;
SKIP: {
if (
'CUILLERE' eq hostname()
or
skip_macosx()
or
-e '/.dockerenv'
or
'pcHPDV7-HP' eq hostname()
)
{
skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 1 ) ;
}
like( ref( $imap->connect( ) ), qr/IO::Socket::INET/, 'mailimapclient_connect_bug ipv6: connect to ks6ipv6.lamiral.info' )
or diag( 'mailimapclient_connect_bug ipv6: ', $imap->LastError( ), $!, ) ;
}
#is( $imap->logout( ), undef, 'mailimapclient_connect_bug ipv6: logout in ssl causes failure' ) ;
is( undef, undef $imap, 'mailimapclient_connect_bug ipv6: free variable' ) ;
note( 'Leaving tests_mailimapclient_connect_bug()' ) ;
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()
or
skip_macosx()
or
-e '/.dockerenv'
or
'pcHPDV7-HP' eq hostname()
)
{
skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 2 ) ;
}
$socket = IO::Socket::INET6->new(
PeerAddr => 'ks6ipv6.lamiral.info',
PeerPort => 143,
) ;
ok( $imap = connect_socket( $socket ), 'connect_socket: ks6ipv6.lamiral.info port 143 IO::Socket::INET6' ) ;
#$imap->Debug( 1 ) ;
# myprint( $imap->capability( ) ) ;
if ( $imap ) {
$imap->logout( ) ;
}
$IO::Socket::SSL::DEBUG = 4 ;
$socket = IO::Socket::SSL->new(
PeerHost => 'ks6ipv6.lamiral.info',
PeerPort => 993,
SSL_verify_mode => SSL_VERIFY_NONE,
SSL_cipher_list => 'DEFAULT:!DH',
) ;
# myprint( $socket ) ;
ok( $imap = connect_socket( $socket ), 'connect_socket: ks6ipv6.lamiral.info port 993 IO::Socket::SSL' ) ;
#$imap->Debug( 1 ) ;
# myprint( $imap->capability( ) ) ;
# $socket->close( ) ;
if ( $imap ) {
$socket->close( ) ;
}
#$socket->close(SSL_no_shutdown => 1) ;
#$imap->logout( ) ;
#myprint( "\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' ) ;
note( "hostname is: ", hostname() ) ;
SKIP: {
if (
'CUILLERE' eq hostname()
or
skip_macosx()
or
-e '/.dockerenv'
or
'pcHPDV7-HP' eq hostname()
)
{
skip( 'Tests avoided on CUILLERE or pcHPDV7-HP or Mac or docker: cannot do ipv6', 0 ) ;
}
# fed up with this one
#like( probe_imapssl( 'ks6ipv6.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: ks6ipv6.lamiral.info matches "* OK"' ) ;
} ;
# It sounds stupid but it avoids failures on the next test about $imap->connect
ok( resolv( 'imap.gmail.com' ), 'resolv: imap.gmail.com => something' ) ;
like( probe_imapssl( 'imap.gmail.com' ), qr/^\* OK/, 'probe_imapssl: imap.gmail.com matches "* OK"' ) ;
like( probe_imapssl( 'test1.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: test1.lamiral.info matches "* OK"' ) ;
note( 'Leaving tests_probe_imapssl()' ) ;
return ;
}
sub probe_imapssl
{
my $host = shift @ARG ;
if ( ! $host ) { return ; }
$sync->{ debug } and $IO::Socket::SSL::DEBUG = 4 ;
my $socket = IO::Socket::SSL->new(
PeerHost => $host,
PeerPort => $IMAP_SSL_PORT,
SSL_verifycn_scheme => 'imap',
SSL_verify_mode => $SSL_VERIFY_POLICY,
SSL_cipher_list => 'DEFAULT:!DH',
) ;
if ( ! $socket ) { return ; }
$sync->{ debug } and print "socket: $socket\n" ;
my $banner ;
$socket->sysread( $banner, 65_536 ) ;
$sync->{ debug } and print "banner: $banner" ;
$socket->close( ) ;
return $banner ;
}
sub connect_imap
{
my( $host, $port, $ssl, $tls, $acc ) = @_ ;
my $imap = Mail::IMAPClient->new( ) ;
if ( $ssl ) { set_ssl( $imap, $acc ) }
$imap->Server( $host ) ;
$imap->Port( $port ) ;
$imap->Debug( $acc->{ debugimap } ) ;
$imap->Timeout( $acc->{ timeout } ) ;
#$imap->Keepalive( $acc->{ keepalive } ) ;
my $side = lc $acc->{ Side } ;
myprint( "$acc->{ Side }: connecting on $side [$host] port [$port]\n" ) ;
if ( ! $imap->connect( ) )
{
$sync->{nb_errors}++ ;
exit_clean( $sync, $EXIT_CONNECTION_FAILURE,
"$acc->{ Side }: Can not open imap connection on [$host]: ",
$imap->LastError,
" $OS_ERROR\n"
) ;
}
myprint( "$acc->{ Side } IP address: ", $imap->Socket->peerhost(), " Local IP address: ", $imap->Socket->sockhost(), "\n" ) ;
my $banner = $imap->Results()->[0] ;
myprint( "$acc->{ Side } banner: $banner" ) ;
myprint( "$acc->{ Side } capability: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ;
if ( $tls ) {
set_tls( $imap, $acc ) ;
if ( ! $imap->starttls( ) )
{
$sync->{nb_errors}++ ;
exit_clean( $sync, $EXIT_TLS_FAILURE,
"$acc->{ Side }: Can not go to tls encryption on $side [$host]:",
$imap->LastError, "\n"
) ;
}
myprint( "$acc->{ Side }: Socket successfully converted to SSL\n" ) ;
}
return( $imap ) ;
}
sub tests_compress_ssl
{
note( 'Entering tests_compress_ssl()' ) ;
SKIP: {
if ( skip_macosx( ) )
{
skip( 'Tests avoided on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 12 ) ;
}
else
{
my $myimap ;
my $acc = {} ;
$acc->{ Side } = 'HostK' ;
$acc->{ authmech } = 'LOGIN' ;
$acc->{ debugimap } = 1 ;
$acc->{ compress } = 1 ;
$acc->{ N } = 'K' ;
ok(
$myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1',
1, undef,
1, 100, $acc, {},
), 'acc_compress_imap: test1.lamiral.info test1 ssl' ) ;
ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ;
is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info ok" ) ;
is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd nok" ) ;
ok(
$myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1',
0, undef,
1, 100, $acc, {},
), 'acc_compress_imap: test1.lamiral.info test1 tls' ) ;
ok( $myimap && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 tls IsAuthenticated' ) ;
is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls ok" ) ;
is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls 2nd nok" ) ;
# Third, no compression
$acc->{ compress } = 0 ;
ok(
$myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1',
1, undef,
1, 100, $acc, {},
), 'acc_compress_imap: test1.lamiral.info test1 ssl' ) ;
ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ;
is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info off ok" ) ;
is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd off ok" ) ;
}
}
note( 'Leaving tests_compress_ssl()' ) ;
return ;
}
sub tests_compress
{
note( 'Entering tests_compress()' ) ;
my $myimap ;
my $acc = {} ;
$acc->{ Side } = 'HostK' ;
$acc->{ authmech } = 'LOGIN' ;
$acc->{ debugimap } = 1 ;
$acc->{ compress } = 1 ;
$acc->{ N } = 'K' ;
ok(
$myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1',
0, 0,
1, 100, $acc, {},
), 'acc_compress_imap: test1.lamiral.info test1' ) ;
ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 IsAuthenticated' ) ;
is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info ok" ) ;
is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd nok" ) ;
ok(
$myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1',
0, 0,
1, 100, $acc, {},
), 'acc_compress_imap: test1.lamiral.info test1 tls' ) ;
ok( $myimap && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 tls IsAuthenticated' ) ;
is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls ok" ) ;
is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls 2nd nok" ) ;
# Third, no compression
$acc->{ compress } = 0 ;
ok(
$myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1',
0, 0,
1, 100, $acc, {},
), 'acc_compress_imap: test1.lamiral.info test1 ssl' ) ;
ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ;
is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info off ok" ) ;
is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd off ok" ) ;
note( 'Leaving tests_compress()' ) ;
return ;
}
sub acc_compress_imap
{
my $acc = shift @ARG ;
if ( ! defined( $acc ) ) { return ; }
my $ret ;
my $imap = $acc->{ imap } ;
if ( ! defined $imap ) { return ; }
if ( $imap && $acc->{ compress } )
{
myprint( "$acc->{ Side }: Trying to turn imap compression on. Use --nocompress" . $acc->{ N } . " to avoid compression on " . lc( $acc->{ Side } ) . "\n" ) ;
if ( $ret = $imap->compress() )
{
myprint( "$acc->{ Side }: Compression is on now\n" ) ;
}
else
{
myprint( "$acc->{ Side }: Failed to turn compression on\n" ) ;
}
}
else
{
myprint( "$acc->{ Side }: Compression is off. Use --compress" . $acc->{ N } . " to allow compression on " . lc( $acc->{ Side } ) . "\n" ) ;
}
# $ret is $acc->{ imap } on success, undef on failure or when there is nothing to do.
return $ret ;
}
sub tests_login_imap
{
note( 'Entering tests_login_imap()' ) ;
is( undef, login_imap( ), 'login_imap: no args => undef' ) ;
SKIP: {
if ( skip_macosx( ) )
{
skip( 'Tests avoided only on binary on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 15 ) ;
}
else{
my $myimap ;
my $acc = {} ;
$acc->{ Side } = 'HostK' ;
$acc->{ authmech } = 'LOGIN' ;
#$IO::Socket::SSL::DEBUG = 4 ;
# Each month (trimester?):
# echo | openssl s_client -crlf -connect test1.lamiral.info:993
# ...
# certificate has expired
# Fix: ssh [email protected] 'apt update && apt upgrade && /etc/init.d/dovecot restart'
#
# or this one:
# echo | openssl s_client -crlf -connect test1.lamiral.info:993
# ...
# Verify return code: 9 (certificate is not yet valid)
# Fix: /etc/init.d/openntpd restart
# 2021_09_04 done
ok(
$myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1',
1, undef,
1, 100, $acc, {},
), 'login_imap: test1.lamiral.info test1 ssl' ) ;
ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ;
is( $myimap, $acc->{ imap }, "login_imap: acc->{ imap } ok test1 ssl") ;
ok(
$myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1',
0, undef,
1, 100, $acc, {},
), 'login_imap: test1.lamiral.info test1 tls' ) ;
ok( $myimap && $myimap->IsAuthenticated( ), 'login_imap: test1.lamiral.info test1 tls IsAuthenticated' ) ;
is( $myimap, $acc->{ imap }, "login_imap: acc->{ imap } ok test1 tls") ;
#$IO::Socket::SSL::DEBUG = 4 ;
$acc->{sslargs} = { SSL_version => 'SSLv2' } ;
# SSLv2 not supported
is(
undef, $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1',
0, undef,
1, 100, $acc, {},
), 'login_imap: test1.lamiral.info test1 tls SSLv2 not supported' ) ;
#SSL_verify_mode => 1
#SSL_version => 'TLSv1_1'
is( undef, $acc->{ imap }, "login_imap: acc->{ imap } test1 tls error => undef") ;
# I have left ? exit_clean to be replaced by errors_incr( $mysync, 'error message' )
# 1 in login_imap()
my $mysync = {} ;
$acc = {} ;
$acc->{ Side } = 'Host2' ;
$acc->{ authmech } = 'LOGIN' ;
is(
undef, login_imap( 'noresol.lamiral.info', 143, 'test1', 'secret1',
0, undef,
1, 100, $acc, $mysync,
), 'login_imap: noresol.lamiral.info undef' ) ;
is( 'ERR_CONNECTION_FAILURE_HOST2', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host2 noresol.lamiral.info => ERR_CONNECTION_FAILURE_HOST2' ) ;
is( undef, $acc->{ imap }, "login_imap: acc->{ imap } noresol error => undef") ;
# authentication failure for user2
$mysync = {} ;
is(
undef, login_imap( 'test1.lamiral.info', 143, 'test1', 'Ce crétin',
0, undef,
1, 100, $acc, $mysync,
), 'login_imap: user2 bad passord => undef' ) ;
is( 'ERR_AUTHENTICATION_FAILURE_USER2', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host2 bad password => ERR_AUTHENTICATION_FAILURE_USER2' ) ;
# authentication failure for user1
$mysync = {} ;
$acc = {} ;
$acc->{ Side } = 'Host1' ;
$acc->{ authmech } = 'LOGIN' ;
is(
undef, login_imap( 'test1.lamiral.info', 143, 'test1', 'Ce crétin',
0, undef,
1, 100, $acc, $mysync,
), 'login_imap: user1 bad passord => undef' ) ;
is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host1 bad password => ERR_AUTHENTICATION_FAILURE_USER1' ) ;
}
}
note( 'Leaving tests_login_imap()' ) ;
return ;
}
sub oauthgenerateaccess
{
if ( "petite" eq hostname() )
{
myprint( "oauthgenerateaccess\n" ) ;
my @output = backtick( 'cd oauth2 && pwd && ./generate_gmail_token [email protected]' ) ;
myprint( @output ) ;
}
return ;
}
sub tests_login_imap_oauth
{
note( 'Entering tests_login_imap_oauth()' ) ;
oauthgenerateaccess() ;
SKIP: {
if ( skip_macosx_binary( ) )
{
skip( 'Tests avoided only on binary on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 6 ) ;
}
else
{
my $mysync ;
my $acc ;
# oauthdirect authentication failure for user2
$mysync = {} ;
$acc = {} ;
$acc->{ oauthdirect } = 'caca2' ;
$acc->{ debugimap } = 1 ;
$mysync->{ showpasswords } = 1 ;
$acc->{ Side } = 'Host2' ;
$acc->{ authmech } = 'QQQ' ;
is(
undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin',
1, undef,
1, 100, $acc, $mysync,
), 'login_imap: user2 bad oauthdirect => undef' ) ;
is( 'ERR_AUTHENTICATION_FAILURE_USER2', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host2 bad oauthdirect => ERR_AUTHENTICATION_FAILURE_USER2' ) ;
# oauthdirect authentication failure for user1
$mysync = {} ;
$acc = {} ;
$acc->{ Side } = 'Host1' ;
$acc->{ oauthdirect } = 'caca1' ;
$acc->{ debugimap } = 1 ;
$mysync->{ showpasswords } = 1 ;
$acc->{ authmech } = 'QQQ' ;
is(
undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin',
1, undef,
1, 100, $acc, $mysync,
), 'login_imap: user1 bad oauthdirect => undef' ) ;
is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host1 bad oauthdirect => ERR_AUTHENTICATION_FAILURE_USER1' ) ;
# oauthdirect authentication failure for user1
$mysync = {} ;
$acc = {} ;
$acc->{ Side } = 'Host1' ;
$acc->{ oauthdirect } = '' ;
$acc->{ debugimap } = 1 ;
$mysync->{ showpasswords } = 1 ;
$acc->{ authmech } = 'QQQ' ;
is(
undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin',
1, undef,
1, 100, $acc, $mysync,
), 'login_imap: user1 bad oauthdirect => undef' ) ;
is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host1 no oauthdirect value => ERR_AUTHENTICATION_FAILURE_USER1' ) ;
}
}
# oauthdirect authentication success for user1
SKIP: {
if ( ! -r 'oauth2/[email protected]' )
{
skip( 'oauthdirect: no oauthdirect file', 6 ) ;
}
my $myimap ;
my $mysync = {} ;
my $acc = {} ;
$acc->{ Side } = 'Host1' ;
$acc->{ oauthdirect } = 'oauth2/[email protected]' ;
$acc->{ debugimap } = 1 ;
$mysync->{ showpasswords } = 1 ;
$acc->{ authmech } = 'QQQ' ;
isa_ok(
$myimap = login_imap( 'imap.gmail.com', 993, 'user_useless', 'password_useless',
1, undef,
1, 100, $acc, $mysync,
), 'Mail::IMAPClient', 'login_imap: user1 good oauthdirect => Mail::IMAPClient' ) ;
ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthdirect IsAuthenticated' ) ;
ok( defined( $myimap ) && $myimap->logout( ), 'login_imap: gmail oauth2 oauthdirect logout' ) ;
ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthdirect not IsAuthenticated after logout' ) ;
ok( defined( $myimap ) && $myimap->reconnect( ), 'login_imap: gmail oauth2 oauthdirect reconnect ok' ) ;
ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthdirect IsAuthenticated after reconnect' ) ;
}
# oauthaccesstoken authentication success for user1
SKIP: {
if ( ! -r 'oauth2/[email protected]' )
{
skip( 'oauthaccesstoken: no access_token file', 6 ) ;
}
my $myimap ;
my $mysync = {} ;
my $acc = {} ;
$acc->{ Side } = 'Host1' ;
$acc->{ oauthaccesstoken } = 'oauth2/[email protected]' ;
$acc->{ debugimap } = 1 ;
$mysync->{ showpasswords } = 1 ;
$acc->{ authmech } = 'QQQ' ;
isa_ok(
$myimap = login_imap( 'imap.gmail.com', 993, '[email protected]', 'password_useless',
1, undef,
1, 100, $acc, $mysync,
), 'Mail::IMAPClient', 'login_imap: user1 good oauthaccesstoken => Mail::IMAPClient' ) ;
ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthaccesstoken IsAuthenticated' ) ;
ok( defined( $myimap ) && $myimap->logout( ), 'login_imap: gmail oauth2 oauthaccesstoken logout' ) ;
ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthaccesstoken not IsAuthenticated after logout' ) ;
ok( defined( $myimap ) && $myimap->reconnect( ), 'login_imap: gmail oauth2 oauthaccesstoken reconnect ok' ) ;
ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthaccesstoken IsAuthenticated after reconnect' ) ;
}
note( 'Leaving tests_login_imap_oauth()' ) ;
return ;
}
sub login_imap
{
my @allargs = @_ ;
my(
$host, $port, $user, $password,
$ssl, $tls,
$uid, $split, $acc, $mysync ) = @allargs ;
$acc->{ imap } = undef ;
if ( ! all_defined( $host, $port, $user, $acc->{ Side } ) )
{
return ;
}
my $side = lc $acc->{ Side } ;
myprint( "$acc->{ Side }: connecting and login on $side [$host] port [$port] with user [$user]\n" ) ;
my $imap = init_imap( @allargs ) ;
if ( ! $imap->connect() )
{
my $error = "$acc->{ Side } failure: can not open imap connection on $side [$host] with user [$user]: "
. $imap->LastError . " $OS_ERROR\n" ;
errors_incr( $mysync, $error ) ;
return ;
}
# Add also $imap->Socket->sockhost() to help configuring firewalls, allowed rule.
myprint( "$acc->{ Side } IP address: ", $imap->Socket->peerhost(), " Local IP address: ", $imap->Socket->sockhost(), "\n" ) ;
my $banner = $imap->Results()->[0] ;
myprint( "$acc->{ Side } banner: $banner" ) ;
myprint( "$acc->{ Side } capability before authentication: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ;
if ( (! $ssl) and (! defined $tls ) and $imap->has_capability( 'STARTTLS' ) ) {
myprint( "$acc->{ Side }: going to ssl because STARTTLS is in CAPABILITY. Use --notls1 or --notls2 to avoid that behavior\n" ) ;
$tls = 1 ;
}
#myprint( Data::Dumper->Dump( [ @allargs ] ) ) ;
if ( $tls ) {
set_tls( $imap, $acc ) ;
if ( ! $imap->starttls( ) )
{
my $error = "$acc->{ Side } failure: Can not go to tls encryption on $side [$host]: "
. $imap->LastError . "\n" ;
errors_incr( $mysync, $error ) ;
return ;
}
myprint( "$acc->{ Side }: Socket successfully converted to SSL\n" ) ;
}
if ( $acc->{ authmech } eq 'PREAUTH' ) {
if ( $imap->IsAuthenticated( ) ) {
$imap->Socket ;
myprintf("%s: Assuming PREAUTH for %s\n", $acc->{ Side }, $imap->Server ) ;
}else{
$mysync->{nb_errors}++ ;
exit_clean(
$mysync, $EXIT_AUTHENTICATION_FAILURE,
"$acc->{ Side } failure: error login on $side [$host] with user [$user] auth [PREAUTH]\n"
) ;
}
}
if ( authenticate_imap( $imap, @allargs ) )
{
myprint( "$acc->{ Side }: success login on [$host] with user [$user] auth [$acc->{ authmech }] or [LOGIN]\n" ) ;
$acc->{ imap } = $imap ;
return( $imap ) ;
}
else
{
# The errors are already printed
myprint( "$acc->{ Side }: failed login on [$host] with user [$user] auth [$acc->{ authmech }]\n" ) ;
return ;
}
}
sub init_imap
{
my(
$host, $port, $user, $password,
$ssl, $tls,
$uid, $split, $acc, $mysync ) = @_ ;
my ( $imap ) ;
$imap = Mail::IMAPClient->new() ;
# Well, it does not change anything, does it?
# It does when suppressing the hack with *STDERR
$imap->Debug_fh( $mysync->{ tee } || *STDOUT ) ;
if ( $ssl ) { set_ssl( $imap, $acc ) }
if ( $tls ) { } # can not do set_tls() here because connect() will directly do a STARTTLS
$imap->Clear( 1 ) ;
$imap->Server( $host ) ;
$imap->Port( $port ) ;
$imap->Fast_io( $acc->{ fastio } ) ;
$imap->Buffer( $buffersize || $DEFAULT_BUFFER_SIZE ) ;
$imap->Uid( $uid ) ;
$imap->Peek( 1 ) ;
$imap->Debug( $acc->{ debugimap } ) ;
if ( $mysync->{ showpasswords } ) {
$imap->Showcredentials( 1 ) ;
}
if ( defined( $acc->{ timeout } ) )
{
$imap->Timeout( $acc->{ timeout } ) ;
}
if ( defined $acc->{ keepalive } )
{
$imap->Keepalive( $acc->{ keepalive } ) ;
}
if ( defined $acc->{ reconnectretry } )
{
$imap->Reconnectretry( $acc->{ reconnectretry } ) ;
}
$imap->{IMAPSYNC_RECONNECT_COUNT} = 0 ;
$imap->Ignoresizeerrors( $allowsizemismatch ) ;
$split and $imap->Maxcommandlength( $SPLIT_FACTOR * $split ) ;
return( $imap ) ;
}
sub authenticate_imap
{
my( $imap,
$host, $port, $user, $password,
$ssl, $tls,
$uid, $split, $acc, $mysync ) = @_ ;
check_capability( $imap, $acc->{ authmech }, $acc->{ Side } ) ;
$imap->User( $user ) ;
if ( defined $acc->{ domain } )
{
$imap->Domain( $acc->{ domain } ) ;
$mysync->{ debug } and myprint( "Domain: $acc->{ domain }\n" ) ;
}
$imap->Authuser( $acc->{ authuser } ) ;
$imap->Password( $password ) ;
if ( 'X-MASTERAUTH' eq $acc->{ authmech } )
{
xmasterauth( $imap ) ;
return 1 ;
}
if ( defined $acc->{ oauthdirect } )
{
$acc->{ authmech } = 'XOAUTH2 direct' ;
return( oauthdirect( $mysync, $acc, $imap, $host, $user ) ) ;
}
if ( defined $acc->{ oauthaccesstoken } )
{
$acc->{ authmech } = 'XOAUTH2 accesstoken' ;
return( oauthaccesstoken( $mysync, $acc, $imap, $host, $user ) ) ;
}
if ( $acc->{ proxyauth } ) {
$imap->Authmechanism(q{}) ;
$imap->User( $acc->{ authuser } ) ;
} else {
$imap->Authmechanism( $acc->{ authmech } ) unless ( $acc->{ authmech } eq 'LOGIN' or $acc->{ authmech } eq 'PREAUTH' ) ;
}
$imap->Authcallback(\&xoauth2) if ( 'XOAUTH2' eq $acc->{ authmech } ) ;
$imap->Authcallback(\&plainauth) if ( ( 'PLAIN' eq $acc->{ authmech } ) or ( 'EXTERNAL' eq $acc->{ authmech } ) ) ;
unless ( $acc->{ authmech } eq 'PREAUTH' or $imap->login( ) ) {
my $info = "$acc->{ Side } failure: Error login on [$host] with user [$user] auth" ;
my $einfo = imap_last_error( $imap ) ;
my $error = "$info [$acc->{ authmech }]: $einfo\n" ;
if ( ( $acc->{ authmech } eq 'LOGIN' ) or $imap->IsUnconnected( ) or $acc->{ authuser } ) {
$acc->{ authuser } ||= "" ;
myprint( "$acc->{ Side } info: authmech [$acc->{ authmech }] user [$user] authuser [$acc->{ authuser }] IsUnconnected [", $imap->IsUnconnected( ), "]\n" ) ;
errors_incr( $mysync, $error ) ;
return ;
}else{
errors_incr( $mysync, $error ) ;
}
# It is not secure to try plain text LOGIN when another authmech failed
# but I do it anyway. This behavior is optional as option --notrylogin will skip it.
if ( $mysync->{ trylogin } )
{
myprint( "$acc->{ Side } info: trying LOGIN Auth mechanism on [$host] with user [$user]. Use option --notrylogin to avoid this second chance to login via LOGIN auth\n" ) ;
$imap->Authmechanism(q{}) ;
if ( ! $imap->login( ) )
{
failure_login( $mysync, $acc, 'LOGIN', $imap, $host, $user ) ;
return ;
}
else
{
myprint( "$acc->{ Side }: success login on [$host] with user [$user] auth [LOGIN] after [$acc->{ authmech }] failure\n" ) ;
}
}
else
{
myprint( "$acc->{ Side } info: not trying LOGIN Auth mechanism on [$host] with user [$user]. Use option --trylogin to have this second chance to login via LOGIN auth\n" ) ;
return ;
}
}
if ( $acc->{ proxyauth } ) {
if ( ! $imap->proxyauth( $user ) ) {
failure_proxyauth( $mysync, $acc, $acc->{ authmech }, $imap, $host, $user ) ;
return ;
}
}
return 1;
}
sub failure_login
{
my( $mysync, $acc, $authmech, $imap, $host, $user ) = @ARG ;
my $info = "$acc->{ Side } failure: Error login on [$host] with user [$user] auth" ;
my $einfo = imap_last_error( $imap ) ;
my $error = "$info [$authmech]: $einfo\n" ;
errors_incr( $mysync, $error ) ;
return ;
}
# failure_login and failure_proxyauth function are similar but
# variable $error so no factoring
sub failure_proxyauth
{
my( $mysync, $acc, $authmech, $imap, $host, $user ) = @ARG ;
my $info = "$acc->{ Side } failure: Error login on [$host] with user [$user] auth" ;
my $einfo = imap_last_error( $imap ) ;
my $error = "$info [$authmech] using proxy-login as [$acc->{ authuser }]: $einfo\n" ;
errors_incr( $mysync, $error ) ;
return ;
}
sub oauthdirect
{
my( $mysync, $acc, $imap, $host, $user ) = @_ ;
my $oauthdirect_str ;
if ( -f -r $acc->{ oauthdirect } )
{
$oauthdirect_str = firstline( $acc->{ oauthdirect } ) ;
}
else
{
$oauthdirect_str = $acc->{ oauthdirect } || 'Please define oauthdirect value' ;
}
$imap->Authmechanism( 'XOAUTH2' ) ;
$imap->Authcallback( sub { return $oauthdirect_str } ) ;
#if ( $imap->authenticate('XOAUTH2', sub { return $oauthdirect_str } ) )
if ( $imap->login( ) )
{
return 1 ;
}
else
{
failure_login( $mysync, $acc, $acc->{ authmech }, $imap, $host, $user ) ;
return ;
}
return ;
}
sub oauthaccesstoken
{
my( $mysync, $acc, $imap, $host, $user ) = @_ ;
my $oauthaccesstoken_str ;
if ( -f -r $acc->{ oauthaccesstoken } )
{
$oauthaccesstoken_str = firstline( $acc->{ oauthaccesstoken } ) ;
}
else
{
$oauthaccesstoken_str = $acc->{ oauthaccesstoken } || 'Please define oauthaccesstoken value' ;
}
my $oauth_string = "user=" . $user . "\x01auth=Bearer ". $oauthaccesstoken_str . "\x01\x01" ;
#myprint "oauth_string: $oauth_string\n" ;
my $oauth_string_base64 = encode_base64( $oauth_string , '' ) ;
#myprint "oauth_string_base64: $oauth_string_base64\n" ;
my $oauthdirect_str = $oauth_string_base64 ;
$imap->Authmechanism( 'XOAUTH2' ) ;
$imap->Authcallback( sub { return $oauthdirect_str } ) ;
#if ( $imap->authenticate('XOAUTH2', sub { return $oauthdirect_str } ) )
if ( $imap->login( ) )
{
return 1 ;
}
else
{
failure_login( $mysync, $acc, $acc->{ authmech }, $imap, $host, $user ) ;
return ;
}
return ;
}
sub check_capability
{
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) ;
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 ;
}
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, $acc ) = @_ ;
# SSL_version can be
# SSLv3 SSLv2 SSLv23 SSLv23:!SSLv2 (last one is the default in IO-Socket-SSL-1.953)
#
my $sslargs_hash = $acc->{sslargs} ;
my $sslargs_default = {
SSL_verify_mode => $SSL_VERIFY_POLICY,
SSL_verifycn_scheme => 'imap',
SSL_cipher_list => 'DEFAULT:!DH',
} ;
# initiate with default values
my %sslargs_mix = %{ $sslargs_default } ;
# now override with passed values
@sslargs_mix{ keys %{ $sslargs_hash } } = values %{ $sslargs_hash } ;
# remove keys with undef values
foreach my $key ( keys %sslargs_mix ) {
delete $sslargs_mix{ $key } if ( not defined $sslargs_mix{ $key } ) ;
}
# back to an ARRAY
my @sslargs_mix = %sslargs_mix ;
#myprint( Data::Dumper->Dump( [ $sslargs_hash, $sslargs_default, \%sslargs_mix, \@sslargs_mix ] ) ) ;
$imap->Ssl( \@sslargs_mix ) ;
return ;
}
sub set_tls
{
my ( $imap, $acc ) = @_ ;
my $sslargs_hash = $acc->{sslargs} ;
my $sslargs_default = {
SSL_verify_mode => $SSL_VERIFY_POLICY,
SSL_cipher_list => 'DEFAULT:!DH',
} ;
#myprint( Data::Dumper->Dump( [ $acc, $sslargs_hash, $sslargs_default ] ) ) ;
# initiate with default values
my %sslargs_mix = %{ $sslargs_default } ;
# now override with passed values
@sslargs_mix{ keys %{ $sslargs_hash } } = values %{ $sslargs_hash } ;
# remove keys with undef values
foreach my $key ( keys %sslargs_mix ) {
delete $sslargs_mix{ $key } if ( not defined $sslargs_mix{ $key } ) ;
}
# back to an ARRAY
my @sslargs_mix = %sslargs_mix ;
$imap->Starttls( \@sslargs_mix ) ;
return ;
}
sub plainauth
{
my $code = shift;
my $imap = shift;
my $string = mysprintf("%s\x00%s\x00%s", $imap->User,
defined $imap->Authuser ? $imap->Authuser : "", $imap->Password);
return encode_base64("$string", q{});
}
# Copy from https://github.com/imapsync/imapsync/pull/25/files
# Changes "use" pragmas to "require".
# The openssl system call shall be replaced by pure Perl and
# https://metacpan.org/pod/Crypt::OpenSSL::PKCS12
# Now the Joaquin Lopez code:
#
# Used this as an example: https://gist.github.com/gsainio/6322375
#
# And this as a reference: https://developers.google.com/accounts/docs/OAuth2ServiceAccount
# (note there is an http/rest tab, where the real info is hidden away... went on a witch hunt
# until I noticed that...)
#
# This is targeted at gmail to maintain compatibility after google's oauth1 service is deactivated
# on May 5th, 2015: https://developers.google.com/gmail/oauth_protocol
# If there are other oauth2 implementations out there, this would need to be modified to be
# compatible
#
# This is a good guide on setting up the google api/apps side of the equation:
# http://www.limilabs.com/blog/oauth2-gmail-imap-service-account
#
# 2016/05/27: Updated to support oauth/key data in the .json files Google now defaults to
# when creating gmail service accounts. They're easier to work with since they neither
# requiring decrypting nor specifying the oauth2 client id separately.
#
# 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 Encode::Byte ;
require IO::Socket::SSL ;
my $code = shift;
my $imap = shift;
my ($iss,$key);
if( $imap->Password =~ /^(.*\.json)$/x )
{
my $json = JSON->new( ) ;
my $filename = $1;
$sync->{ debug } and myprint( "XOAUTH2 json file: $filename\n" ) ;
my $FILE ;
if ( ! open( $FILE, '<', $filename ) )
{
$sync->{nb_errors}++ ;
exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE,
"error [$filename]: $OS_ERROR\n"
) ;
}
my $jsonfile = $json->decode( join q{}, <$FILE> ) ;
close $FILE ;
$iss = $jsonfile->{client_id};
$key = $jsonfile->{private_key};
$sync->{ debug } and myprint( "Service account: $iss\n");
$sync->{ debug } and myprint( "Private key:\n$key\n");
}
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 \_\-\.\/]+);?(.*)?/x ;
# Assume key password is google default if not provided
$keypass = 'notasecret' if not $keypass;
$sync->{ debug } and myprint( "Service account: $iss\nKey file: $keyfile\nKey password: $keypass\n");
# Get private key from p12 file (would be better in perl...)
$key = `openssl pkcs12 -in "$keyfile" -nodes -nocerts -passin pass:$keypass -nomacver`;
$sync->{ debug } and myprint( "Private key:\n$key\n");
}
# Create jwt of oauth2 request
my $time = time ;
my $jwt = JSON::WebToken->encode( {
'iss' => $iss, # service account
'scope' => 'https://mail.google.com/',
'aud' => 'https://www.googleapis.com/oauth2/v3/token',
'exp' => $time + $DEFAULT_EXPIRATION_TIME_OAUTH2_PK12,
'iat' => $time,
'prn' => $imap->User # user to auth as
},
$key, 'RS256', {'typ' => 'JWT'} ); # Crypt::OpenSSL::RSA needed here.
# Post oauth2 request
my $ua = LWP::UserAgent->new( ) ;
$ua->env_proxy( ) ;
my $response = $ua->post('https://www.googleapis.com/oauth2/v3/token',
{ grant_type => HTML::Entities::encode_entities('urn:ietf:params:oauth:grant-type:jwt-bearer'),
assertion => $jwt } ) ;
unless( $response->is_success( ) ) {
$sync->{nb_errors}++ ;
exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE,
$response->code, "\n", $response->content, "\n"
) ;
}else{
$sync->{ debug } and myprint( $response->content ) ;
}
# access_token in response is what we need
my $data = JSON::decode_json( $response->content ) ;
# format as oauth2 auth data
my $xoauth2_string = encode_base64( 'user=' . $imap->User . "\1auth=Bearer " . $data->{access_token} . "\1\1", q{} ) ;
$sync->{ debug } and myprint( "XOAUTH2 String: $xoauth2_string\n");
return($xoauth2_string);
}
sub xmasterauth
{
# This is Kerio auth admin
# This code comes from
# https://github.com/imapsync/imapsync/pull/53/files
my $imap = shift @ARG ;
my $user = $imap->User( ) ;
my $password = $imap->Password( ) ;
my $authmech = 'X-MASTERAUTH' ;
my @challenge = $imap->tag_and_run( $authmech, "+" ) ;
if ( not defined $challenge[0] )
{
$sync->{nb_errors}++ ;
exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE,
"Failure authenticate with $authmech: ",
$imap->LastError, "\n"
) ;
return ; # hahaha!
}
$sync->{ debug } and myprint( "X-MASTERAUTH challenge: [@challenge]\n" ) ;
$challenge[1] =~ s/^\+ |^\s+|\s+$//g ;
if ( ! $imap->_imap_command( { addcrlf => 1, addtag => 0, tag => $imap->Count }, md5_hex( $challenge[1] . $password ) ) )
{
$sync->{nb_errors}++ ;
exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE,
"Failure authenticate with $authmech: ",
$imap->LastError, "\n"
) ;
}
if ( ! $imap->tag_and_run( 'X-SETUSER ' . $user ) )
{
$sync->{nb_errors}++ ;
exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE,
"Failure authenticate with $authmech: ",
"X-SETUSER ", $imap->LastError, "\n"
) ;
}
$imap->State( Mail::IMAPClient::Authenticated ) ;
# I comment this state because "Selected" state is usually done by SELECT or EXAMINE imap commands
# $imap->State( Mail::IMAPClient::Selected ) ;
return ;
}
sub keepalive1
{
my $mysync = shift @ARG ;
$mysync->{ acc1 }->{ keepalive } = defined $mysync->{ acc1 }->{ keepalive } ? $mysync->{ acc1 }->{ keepalive } : 1 ;
if ( $mysync->{ acc1 }->{ keepalive } )
{
myprint( "Host1: imap connection keepalive is on on host1. Use --nokeepalive1 to disable it.\n" ) ;
}
else
{
myprint( "Host1: imap connection keepalive is off on host1. Use --keepalive1 to enable it.\n" ) ;
}
return ;
}
sub keepalive2
{
my $mysync = shift @ARG ;
$mysync->{ acc2 }->{ keepalive } = defined $mysync->{ acc2 }->{ keepalive } ? $mysync->{ acc2 }->{ keepalive } : 1 ;
if ( $mysync->{ acc2 }->{ keepalive } )
{
myprint( "Host2: imap connection keepalive is on on host2. Use --nokeepalive2 to disable it.\n" ) ;
}
else
{
myprint( "Host2: imap connection keepalive is off on host2. Use --keepalive2 to enable it.\n" ) ;
}
return ;
}
sub banner_imapsync
{
my $mysync = shift @ARG ;
my @argv = @ARG ;
my $banner_imapsync = join q{},
q{$RCSfile: imapsync,v $ },
q{$Revision: 2.229 $ },
q{$Date: 2022/09/14 18:08:24 $ },
"\n",
"Command line used, run by $EXECUTABLE_NAME:\n",
"$PROGRAM_NAME ", command_line_nopassword( $mysync, @argv ), "\n" ;
return( $banner_imapsync ) ;
}
sub tests_do_valid_directory
{
note( 'Entering tests_do_valid_directory()' ) ;
is( 1, do_valid_directory( '.'), 'do_valid_directory: . good' ) ;
is( 1, do_valid_directory( './W/tmp/tests/valid/sub'), 'do_valid_directory: ./W/tmp/tests/valid/sub good' ) ;
Readonly my $NB_UNIX_tests_do_valid_directory_non_root => 2 ;
diag( "OSNAME=$OSNAME EFFECTIVE_USER_ID=$EFFECTIVE_USER_ID" ) ;
SKIP: {
skip( 'Tests only for non roor user', $NB_UNIX_tests_do_valid_directory_non_root ) if ( '0' eq $EFFECTIVE_USER_ID ) ;
diag( 'The "Error / is not writable" is on purpose' ) ;
ok( 0 == do_valid_directory( '/'), 'do_valid_directory: / bad' ) ;
diag( 'The "Error permission denied" on /noway is on purpose' ) ;
ok( 0 == do_valid_directory( '/noway'), 'do_valid_directory: /noway bad' ) ;
}
note( 'Leaving tests_do_valid_directory()' ) ;
return ;
}
sub do_valid_directory
{
my $dir = shift @ARG ;
# 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 (current directory is " . getcwd( ) . ")\n" ) ;
if ( ! eval { mkpath( $dir ) } ) {
myprint( "$EVAL_ERROR" ) if ( $EVAL_ERROR ) ;
}
return( 1 ) if ( -d $dir and -r _ and -w _ ) ;
return( 0 ) ;
}
sub tests_match_a_pid_number
{
note( 'Entering tests_match_a_pid_number()' ) ;
is( undef, match_a_pid_number( ), 'match_a_pid_number: no args => undef' ) ;
is( undef, match_a_pid_number( q{} ), 'match_a_pid_number: "" => undef' ) ;
is( undef, match_a_pid_number( 'lalala' ), 'match_a_pid_number: lalala => undef' ) ;
is( 1, match_a_pid_number( 1 ), 'match_a_pid_number: 1 => 1' ) ;
is( 1, match_a_pid_number( 123 ), 'match_a_pid_number: 123 => 1' ) ;
is( 1, match_a_pid_number( -123 ), 'match_a_pid_number: -123 => 1' ) ;
is( 1, match_a_pid_number( '123' ), 'match_a_pid_number: "123" => 1' ) ;
is( 1, match_a_pid_number( '-123' ), 'match_a_pid_number: "-123" => 1' ) ;
is( undef, match_a_pid_number( 'a123' ), 'match_a_pid_number: a123 => undef' ) ;
is( undef, match_a_pid_number( '-a123' ), 'match_a_pid_number: -a123 => undef' ) ;
is( 1, match_a_pid_number( 99999 ), 'match_a_pid_number: 99999 => 1' ) ;
is( 1, match_a_pid_number( -99999 ), 'match_a_pid_number: -99999 => 1' ) ;
is( undef, match_a_pid_number( 0 ), 'match_a_pid_number: 0 => undef' ) ;
is( 1, match_a_pid_number( 100000 ), 'match_a_pid_number: 100000 => 1' ) ;
is( 1, match_a_pid_number( 123456 ), 'match_a_pid_number: 123456 => 1' ) ;
is( undef, match_a_pid_number( '-0' ), 'match_a_pid_number: "-0" => undef' ) ;
is( 1, match_a_pid_number( -100000 ), 'match_a_pid_number: -100000 => 1' ) ;
is( 1, match_a_pid_number( -123456 ), 'match_a_pid_number: -123456 => 1' ) ;
is( 1, match_a_pid_number( 2**22 ), 'match_a_pid_number: 2**22 => 1' ) ;
is( undef, match_a_pid_number( 2**22 + 1 ), 'match_a_pid_number: 2**22 + 1 => undef' ) ;
is( undef, match_a_pid_number( 4194304 + 1 ), 'match_a_pid_number: 2**22 + 1 = 4194305 => undef' ) ;
note( 'Leaving tests_match_a_pid_number()' ) ;
return ;
}
sub match_a_pid_number
{
my $pid = shift @ARG ;
if ( ! defined $pid ) { return ; }
#print "$pid\n" ;
if ( ! match( $pid, '^-?\d+$' ) ) { return ; }
#print "$pid\n" ;
# can be negative on Windows
#if ( 0 > $pid ) { return ; }
#if ( 65535 < $pid ) { return ; }
if ( 2**22 < abs( $pid ) ) { return ; }
if ( 0 == abs( $pid ) ) { return ; }
return 1 ;
}
sub tests_remove_pidfile_not_running
{
note( 'Entering tests_remove_pidfile_not_running()' ) ;
ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'remove_pidfile_not_running: mkpath W/tmp/tests/' ) ;
is( undef, remove_pidfile_not_running( ), 'remove_pidfile_not_running: no args => undef' ) ;
is( undef, remove_pidfile_not_running( './W' ), 'remove_pidfile_not_running: a dir => undef' ) ;
is( undef, remove_pidfile_not_running( 'noexists' ), 'remove_pidfile_not_running: noexists => undef' ) ;
is( 1, touch( 'W/tmp/tests/empty.pid' ), 'remove_pidfile_not_running: prepa empty W/tmp/tests/empty.pid' ) ;
is( undef, remove_pidfile_not_running( 'W/tmp/tests/empty.pid' ), 'remove_pidfile_not_running: W/tmp/tests/empty.pid => undef' ) ;
is( 'lalala', string_to_file( 'lalala', 'W/tmp/tests/lalala.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/lalala.pid' ) ;
is( undef, remove_pidfile_not_running( 'W/tmp/tests/lalala.pid' ), 'remove_pidfile_not_running: W/tmp/tests/lalala.pid => undef' ) ;
is( '55555', string_to_file( '55555', 'W/tmp/tests/notrunning.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/notrunning.pid' ) ;
is( 1, remove_pidfile_not_running( 'W/tmp/tests/notrunning.pid' ), 'remove_pidfile_not_running: W/tmp/tests/notrunning.pid => 1' ) ;
is( $PROCESS_ID, string_to_file( $PROCESS_ID, 'W/tmp/tests/running.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/running.pid' ) ;
is( undef, remove_pidfile_not_running( 'W/tmp/tests/running.pid' ), 'remove_pidfile_not_running: W/tmp/tests/running.pid => undef' ) ;
note( 'Leaving tests_remove_pidfile_not_running()' ) ;
return ;
}
sub remove_pidfile_not_running
{
#
my $pid_filename = shift @ARG ;
#myprint( "In remove_pidfile_not_running $pid_filename\n" ) ;
if ( ! $pid_filename ) { myprint( "No variable pid_filename\n" ) ; return } ;
if ( ! -e $pid_filename )
{
myprint( "File $pid_filename does not exist\n" ) ;
return ;
}
#myprint( "Still In remove_pidfile_not_running $pid_filename\n" ) ;
if ( ! -f $pid_filename ) { myprint( "File $pid_filename is not a file\n" ) ; return } ;
my $pid = firstline( $pid_filename ) ;
if ( ! match_a_pid_number( $pid ) ) { myprint( "In remove_pidfile_not_running: pid $pid in $pid_filename is not a pid number\n" ) ; return } ;
# can't kill myself => do nothing
if ( ! kill 'ZERO', $PROCESS_ID ) { myprint( "Can not kill ZERO myself $PROCESS_ID\n" ) ; return } ;
# can't kill ZERO the pid => it is gone or own by another user => remove pidfile
if ( ! kill 'ZERO', $pid ) {
myprint( "Removing old $pid_filename since its PID $pid is not running anymore (oo-killed?)\n" ) ;
if ( unlink $pid_filename ) {
myprint( "Removed old $pid_filename\n" ) ;
return 1 ;
}else{
myprint( "Could not remove old $pid_filename because $!\n" ) ;
return ;
}
}
myprint( "Another imapsync process $pid is running as says pidfile $pid_filename\n" ) ;
return ;
}
sub tests_tail
{
note( 'Entering tests_tail()' ) ;
ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'tail: mkpath W/tmp/tests/' ) ;
ok( ( ! -e 'W/tmp/tests/tail.pid' || unlink 'W/tmp/tests/tail.pid' ), 'tail: unlink W/tmp/tests/tail.pid' ) ;
ok( ( ! -e 'W/tmp/tests/tail.txt' || unlink 'W/tmp/tests/tail.txt' ), 'tail: unlink W/tmp/tests/tail.txt' ) ;
is( undef, tail( ), 'tail: no args => undef' ) ;
my $mysync ;
is( undef, tail( $mysync ), 'tail: no pidfile => undef' ) ;
$mysync->{pidfile} = 'W/tmp/tests/tail.pid' ;
is( undef, tail( $mysync ), 'tail: no pidfilelocking => undef' ) ;
$mysync->{pidfilelocking} = 1 ;
is( undef, tail( $mysync ), 'tail: pidfile no exists => undef' ) ;
my $pidandlog = "33333\nW/tmp/tests/tail.txt\n" ;
is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put pid 33333 and tail.txt in pidfile' ) ;
is( undef, tail( $mysync ), 'tail: logfile to tail no exists => undef' ) ;
my $tailcontent = "L1\nL2\nL3\nL4\nL5\n" ;
is( $tailcontent, string_to_file( $tailcontent, 'W/tmp/tests/tail.txt' ),
'tail: put L1\nL2\nL3\nL4\nL5\n in W/tmp/tests/tail.txt' ) ;
is( undef, tail( $mysync ), 'tail: fake pid in pidfile + tail off => 1' ) ;
$mysync->{ tail } = 1 ;
is( 1, tail( $mysync ), 'tail: fake pid in pidfile + tail on=> 1' ) ;
# put my own pid, won't do tail
$pidandlog = "$PROCESS_ID\nW/tmp/tests/tail.txt\n" ;
is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put my own PID in pidfile' ) ;
is( undef, tail( $mysync ), 'tail: my own pid in pidfile => undef' ) ;
note( 'Leaving tests_tail()' ) ;
return ;
}
sub tail
{
# return undef on failures
# return 1 on success
my $mysync = shift @ARG ;
# no tail when aborting!
if ( $mysync->{ abort } ) { return ; }
my $pidfile = $mysync->{pidfile} ;
my $lock = $mysync->{pidfilelocking} ;
my $tail = $mysync->{tail} ;
if ( ! $pidfile ) { return ; }
if ( ! $lock ) { return ; }
if ( ! $tail ) { return ; }
if ( ! -e $pidfile ) { return ; }
my $pidtotail = firstline( $pidfile ) ;
if ( ! $pidtotail ) { return ; }
# It should not happen but who knows...
if ( $pidtotail eq $PROCESS_ID ) { return ; }
my $filetotail = secondline( $pidfile ) ;
if ( ! $filetotail ) { return ; }
if ( ! -r $filetotail )
{
#myprint( "Error: can not read $filetotail\n" ) ;
return ;
}
myprint( "Doing a tail -f on $filetotail for processus pid $pidtotail until it is finished.\n" ) ;
my $file = File::Tail->new(
name => $filetotail,
nowait => 1,
interval => 1,
tail => 1,
adjustafter => 2
);
my $moretimes = 200 ;
# print one line at least
my $line = $file->read ;
myprint( $line ) ;
while ( isrunning( $pidtotail, \$moretimes ) and defined( $line = $file->read ) )
{
myprint( $line );
sleep( 0.02 ) ;
}
return 1 ;
}
sub isrunning
{
my $pidtocheck = shift @ARG ;
my $moretimes_ref = shift @ARG ;
if ( kill 'ZERO', $pidtocheck )
{
#myprint( "$pidtocheck running\n" ) ;
return 1 ;
}
elsif ( $$moretimes_ref >= 0 )
{
# continue to consider it running
$$moretimes_ref-- ;
return 1 ;
}
else
{
myprint( "Tailed processus $pidtocheck ended\n" ) ;
return ;
}
}
sub tests_write_pidfile
{
note( 'Entering tests_write_pidfile()' ) ;
my $mysync ;
is( 1, write_pidfile( ), 'write_pidfile: no args => 1' ) ;
# no pidfile => ok
$mysync->{pidfile} = q{} ;
is( 1, write_pidfile( $mysync ), 'write_pidfile: no pidfile => undef' ) ;
# The pidfile path is bad => failure
$mysync->{pidfile} = '/no/no/no.pid' ;
is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid, no lock => undef' ) ;
$mysync->{pidfilelocking} = 1 ;
is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid + lock => undef' ) ;
$mysync->{pidfile} = 'W/tmp/tests/test.pid' ;
ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'write_pidfile: mkpath W/tmp/tests/' ) ;
is( 1, touch( $mysync->{pidfile} ), 'write_pidfile: lock prepa' ) ;
$mysync->{pidfilelocking} = 0 ;
is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock => 1' ) ;
is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains $PROCESS_ID" ) ;
is( q{}, secondline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains no second line" ) ;
$mysync->{pidfilelocking} = 1 ;
is( undef, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + lock => undef' ) ;
$mysync->{pidfilelocking} = 0 ;
$mysync->{ logfile } = 'rrrr.txt' ;
is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock + logfile => 1' ) ;
is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: + no lock + logfile W/tmp/tests/test.pid contains $PROCESS_ID" ) ;
is( q{rrrr.txt}, secondline( 'W/tmp/tests/test.pid' ), "write_pidfile: + no lock + logfile W/tmp/tests/test.pid contains rrrr.txt" ) ;
note( 'Leaving tests_write_pidfile()' ) ;
return ;
}
sub write_pidfile
{
# returns undef if something is considered fatal
# returns 1 otherwise
#myprint( "In write_pidfile\n" ) ;
if ( ! @ARG ) { return 1 ; }
my $mysync = shift @ARG ;
# Do not write the pid file if the current process goal is to abort the process designed by the pid file
if ( $mysync->{ abort } ) { return 1 ; }
#
my $pid_filename = $mysync->{ pidfile } ;
my $lock = $mysync->{ pidfilelocking } ;
if ( ! $pid_filename )
{
myprint( "PID file is unset ( to set it, use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ;
return( 1 ) ;
}
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" ) ;
return ;
}
if ( -e $pid_filename ) {
myprint( "$pid_filename already exists, overwriting it ( use --pidfilelocking to avoid concurrent runs )\n" ) ;
}
my $pid_string = "$PROCESS_ID\n" ;
my $pid_message = "Writing my PID $PROCESS_ID in $pid_filename\n" ;
if ( $mysync->{ logfile } )
{
$pid_string .= "$mysync->{ logfile }\n" ;
$pid_message .= "Writing also my logfile name in $pid_filename : $mysync->{ logfile }\n" ;
}
if ( open my $FILE_HANDLE, '>', $pid_filename ) {
myprint( $pid_message ) ;
print $FILE_HANDLE $pid_string ;
close $FILE_HANDLE ;
return( 1 ) ;
}
else
{
myprint( "Could not open $pid_filename for writing. Check permissions or disk space: $OS_ERROR\n" ) ;
return ;
}
}
sub fix_Inbox_INBOX_mapping
{
my( $h1_all, $h2_all ) = @_ ;
my $regex = q{} ;
SWITCH: {
if ( exists $h1_all->{INBOX} and exists $h2_all->{INBOX} ) { $regex = q{} ; last SWITCH ; } ;
if ( exists $h1_all->{Inbox} and exists $h2_all->{Inbox} ) { $regex = q{} ; last SWITCH ; } ;
if ( exists $h1_all->{INBOX} and exists $h2_all->{Inbox} ) { $regex = q{s/^INBOX$/Inbox/x} ; last SWITCH ; } ;
if ( exists $h1_all->{Inbox} and exists $h2_all->{INBOX} ) { $regex = q{s/^Inbox$/INBOX/x} ; last SWITCH ; } ;
} ;
return( $regex ) ;
}
sub tests_fix_Inbox_INBOX_mapping
{
note( 'Entering tests_fix_Inbox_INBOX_mapping()' ) ;
my( $h1_all, $h2_all ) ;
$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{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 = { '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 ) ;
}
sub tests_jux_utf8_list
{
note( 'Entering tests_jux_utf8_list()' ) ;
use utf8 ;
is( q{}, jux_utf8_list( ), 'jux_utf8_list: void' ) ;
is( "[]\n", jux_utf8_list( q{} ), 'jux_utf8_list: empty string' ) ;
is( "[INBOX]\n", jux_utf8_list( 'INBOX' ), 'jux_utf8_list: INBOX' ) ;
is( "[&ANY-] = [Ö]\n", jux_utf8_list( '&ANY-' ), 'jux_utf8_list: [&ANY-] = [Ö]' ) ;
note( 'Leaving tests_jux_utf8_list()' ) ;
return( 0 ) ;
}
# editing utf8 can be tricky without an utf8 editor
sub tests_jux_utf8_old
{
note( 'Entering tests_jux_utf8_old()' ) ;
no utf8 ;
is( '[]', jux_utf8_old( q{} ), 'jux_utf8_old: void => []' ) ;
is( '[INBOX]', jux_utf8_old( 'INBOX'), 'jux_utf8_old: INBOX => [INBOX]' ) ;
is( '[&ZTZO9nux-] = [收件箱]', jux_utf8_old( '&ZTZO9nux-'), 'jux_utf8_old: => [&ZTZO9nux-] = [收件箱]' ) ;
is( '[&ANY-] = [Ö]', jux_utf8_old( '&ANY-'), 'jux_utf8_old: &ANY- => [&ANY-] = [Ö]' ) ;
# +BD8EQAQ1BDQEOwQ+BDM- SHOULD stay as is!
is( '[+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]', jux_utf8_old( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8_old: => [+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' ) ;
is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8_old( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8_old: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ;
note( 'Leaving tests_jux_utf8_old()' ) ;
return ;
}
sub jux_utf8_old
{
# juxtapose utf8 at the right if different
my ( $s_utf7 ) = shift @ARG ;
my ( $s_utf8 ) = imap_utf7_decode_old( $s_utf7 ) ;
if ( $s_utf7 eq $s_utf8 ) {
#myprint( "[$s_utf7]\n" ) ;
return( "[$s_utf7]" ) ;
}else{
#myprint( "[$s_utf7] = [$s_utf8]\n" ) ;
return( "[$s_utf7] = [$s_utf8]" ) ;
}
}
# Copied from http://cpansearch.perl.org/src/FABPOT/Unicode-IMAPUtf7-2.01/lib/Unicode/IMAPUtf7.pm
# and then fixed with
# https://rt.cpan.org/Public/Bug/Display.html?id=11172
sub imap_utf7_decode_old
{
my ( $s ) = shift @ARG ;
# Algorithm
# 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\-/xg ;
$s =~ s/&(?!\-)/\+/xg ;
$s =~ s/&\-/&/xg ;
return( Unicode::String::utf7( $s )->utf8 ) ;
}
sub tests_jux_utf8
{
note( 'Entering tests_jux_utf8()' ) ;
#no utf8 ;
use utf8 ;
#binmode STDOUT, ":encoding(UTF-8)" ;
binmode STDERR, ":encoding(UTF-8)" ;
# This test is because the binary can fail on it, a PAR.pm issue.
# The failure was with the underlying Encode::IMAPUTF7 module line 66 release 1.05
# Was solved by including Encode in imapsync and using "pp -x".
ok( find_encoding( "UTF-16BE"), 'jux_utf8: Encode::find_encoding: UTF-16BE' ) ;
#
is( '[]', jux_utf8( q{} ), 'jux_utf8: void => []' ) ;
is( '[INBOX]', jux_utf8( 'INBOX'), 'jux_utf8: INBOX => [INBOX]' ) ;
is( '[&ANY-] = [Ö]', jux_utf8( '&ANY-'), 'jux_utf8: &ANY- => [&ANY-] = [Ö]' ) ;
# +BD8EQAQ1BDQEOwQ+BDM- must stay as is
is( '[+BD8EQAQ1BDQEOwQ+BDM-]', jux_utf8( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8: => [+BD8EQAQ1BDQEOwQ+BDM-] = [+BD8EQAQ1BDQEOwQ+BDM-]' ) ;
is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ;
is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( q{R&AOk-ponses 1200+1201+1202} ), 'jux_utf8: [R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]' ) ;
my $str = Encode::IMAPUTF7::encode("IMAP-UTF-7", 'Réponses 1200+1201+1202' ) ;
is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( $str ), "jux_utf8: [$str] = [Réponses 1200+1201+1202]" ) ;
is( '[INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éà çù&*]', jux_utf8( 'INBOX.&AOkA4ADnAPk-&-*' ), "jux_utf8: [INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éà çù&*]" ) ;
is( '[&ZTZO9nux-] = [收件箱]', jux_utf8( '&ZTZO9nux-'), 'jux_utf8: => [&ZTZO9nux-] = [收件箱]' ) ;
#
#
is( '[!Old Emails]', jux_utf8( '!Old Emails'), 'jux_utf8: !Old Emails => [!Old Emails]' ) ;
is( '[2006 Budget & Fcst]', jux_utf8( '2006 Budget & Fcst'), 'jux_utf8: 2006 Budget & Fcst => [2006 Budget & Fcst]' ) ;
note( 'Leaving tests_jux_utf8()' ) ;
return ;
}
sub jux_utf8
{
#use utf8 ;
# juxtapose utf8 at the right if different
my ( $s_utf7 ) = shift @ARG ;
my ( $s_utf8 ) = imap_utf7_decode( $s_utf7 ) ;
if ( $s_utf7 eq $s_utf8 ) {
#myprint( "[$s_utf7]\n" ) ;
return( "[$s_utf7]" ) ;
}else{
#myprint( "[$s_utf7] = [$s_utf8]\n" ) ;
return( "[$s_utf7] = [$s_utf8]" ) ;
}
}
sub imap_utf7_decode
{
#use utf8 ;
my ( $s ) = shift @ARG ;
return( Encode::IMAPUTF7::decode("IMAP-UTF-7", $s ) ) ;
}
sub imap_utf7_encode
{
#use utf8 ;
my ( $s ) = shift @ARG ;
return( Encode::IMAPUTF7::encode("IMAP-UTF-7", $s ) ) ;
}
sub imap_utf7_encode_old
{
my ( $s ) = @_ ;
$s = Unicode::String::utf8( $s )->utf7 ;
$s =~ s/\+([^\/&\-]*)\/([^\/\-&]*)\-/\+$1,$2\-/xg ;
$s =~ s/&/&\-/xg ;
$s =~ s/\+([^+\-]+)?\-/&$1\-/xg ;
return( $s ) ;
}
sub select_folder
{
my ( $mysync, $imap, $folder, $hostside ) = @_ ;
if ( ! $imap->select( $folder ) ) {
my $error = join q{},
"$hostside folder $folder: Could not select: ",
$imap->LastError, "\n" ;
errors_incr( $mysync, $error ) ;
return( 0 ) ;
}else{
# ok select succeeded
return( 1 ) ;
}
}
sub examine_folder
{
my ( $mysync, $imap, $folder, $hostside ) = @_ ;
if ( ! $imap->examine( $folder ) ) {
my $error = join q{},
"$hostside folder $folder: Could not examine: ",
$imap->LastError, "\n" ;
errors_incr( $mysync, $error ) ;
return( 0 ) ;
}else{
# ok select succeeded
return( 1 ) ;
}
}
sub count_from_select
{
my @lines = @ARG ;
my $count ;
foreach my $line ( @lines ) {
#myprint( "line = [$line]\n" ) ;
if ( $line =~ m/^\*\s+(\d+)\s+EXISTS/x ) {
$count = $1 ;
return( $count ) ;
}
}
return( undef ) ;
}
sub create_folder_old
{
my $mysync = shift @ARG ;
my( $imap, $h2_fold, $h1_fold ) = @ARG ;
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 ( ! $mysync->{dry} ){
if ( ! $imap->create( $h2_fold ) ) {
my $error = join q{},
"Could not create folder [$h2_fold] from [$h1_fold]: ",
$imap->LastError( ), "\n" ;
errors_incr( $mysync, $error ) ;
# success if folder exists ("already exists" error)
return( 1 ) if $imap->exists( $h2_fold ) ;
# failure since create failed
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 $mysync->{dry_message}\n" ) ;
return( 0 ) ;
}
}
sub create_folder
{
my $mysync = shift @ARG ;
my( $myimap2 , $h2_fold , $h1_fold ) = @ARG ;
my( @parts , $parent ) ;
if ( $myimap2->IsUnconnected( ) ) {
myprint( "Host2: Unconnected state\n" ) ;
return( 0 ) ;
}
if ( $create_folder_old ) {
return( create_folder_old( $mysync, $myimap2 , $h2_fold , $h1_fold ) ) ;
}
# $imap->exists() calls $imap->status() that does an IMAP STATUS folder
myprint( "Creating folder [$h2_fold] on host2\n" ) ;
if ( ( 'INBOX' eq uc $h2_fold )
and ( $myimap2->exists( $h2_fold ) ) ) {
myprint( "Folder [$h2_fold] already exists\n" ) ;
return( 1 ) ;
}
if ( $mixfolders and $myimap2->exists( $h2_fold ) ) {
myprint( "Folder [$h2_fold] already exists (--nomixfolders is not set)\n" ) ;
return( 1 ) ;
}
if ( ( not $mixfolders ) and ( $myimap2->exists( $h2_fold ) ) ) {
myprint( "Folder [$h2_fold] already exists and --nomixfolders is set\n" ) ;
return( 0 ) ;
}
@parts = split /\Q$mysync->{ h2_sep }\E/x, $h2_fold ;
pop @parts ;
$parent = join $mysync->{ h2_sep }, @parts ;
$parent =~ s/^\s+|\s+$//xg ;
if ( ( $parent ne q{} ) and ( ! $myimap2->exists( $parent ) ) ) {
create_folder( $mysync, $myimap2 , $parent , $h1_fold ) ;
}
if ( ! $mysync->{dry} ) {
if ( ! $myimap2->create( $h2_fold ) ) {
my $error = join q{},
"Could not create folder [$h2_fold] from [$h1_fold]: " ,
$myimap2->LastError( ), "\n" ;
errors_incr( $mysync, $error ) ;
# success if folder exists ("already exists" error) or selectable
if ( $myimap2->exists( $h2_fold ) or select_folder( $mysync, $myimap2, $h2_fold, 'Host2' ) )
{
return( 1 ) ;
}
# failure since create failed + not exist + not selectable
return( 0 ) ;
}else{
#create succeeded
myprint( "Created folder [$h2_fold] on host2\n" ) ;
return( 1 ) ;
}
}else{
# dry mode, no folder so many imap will fail, assuming failure
myprint( "Created folder [$h2_fold] on host2 $mysync->{dry_message}\n" ) ;
if ( ! $mysync->{ justfolders } ) {
myprint( "Since --dry mode is on and folder [$h2_fold] on host2 does not exist yet, syncing messages will not be simulated.\n"
. "To simulate message syncing, use --justfolders without --dry to first create the missing folders then rerun the --dry sync.\n" ) ;
# The messages that could be transferred are counted and the number is given at the end.
}
return( 0 ) ;
}
}
sub tests_folder_routines
{
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' );
is_deeply( [ 'folder_foo' ], [ remove_from_requested_folders( 'folder_foo' ) ], 'removed folder_foo => 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' );
is_deeply( [ 'folder_bar' ], [ 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( 'A_99', 'M_55', 'Z_11' ), 'add_to_requested_folders M_55 Z_11' );
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'A_99', 'M_55', 'Z_11' ] ), 'sort_requested_folders: middle' ) ;
@folderfirst = ( 'Z_11' ) ;
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'A_99', 'M_55' ] ), 'sort_requested_folders: first+middle' ) ;
is_deeply( [ 'Z_11', 'A_99', 'M_55' ], [ sort_requested_folders( ) ], 'sort_requested_folders: first+middle is_deeply' ) ;
@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( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_44', 'M_55', 'A_99'] ), 'sort_requested_folders: first+middle+last 2' ) ;
ok( add_to_requested_folders('A_88', 'Z_22',), 'add_to_requested_folders A_88 Z_22' ) ;
@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' ) ;
undef @folderfirst ;
undef @folderlast ;
note( 'Leaving tests_folder_routines()' ) ;
return ;
}
sub sort_requested_folders
{
my @requested_folders_sorted = () ;
$sync->{ debug } and myprint "folderfirst: @folderfirst\n" ;
my @folderfirst_requested = remove_from_requested_folders( @folderfirst ) ;
#myprint "folderfirst_requested: @folderfirst_requested\n" ;
my @folderlast_requested = remove_from_requested_folders( @folderlast ) ;
my @middle = sort keys %requested_folder ;
@requested_folders_sorted = ( @folderfirst_requested, @middle, @folderlast_requested ) ;
$sync->{ debug } and myprint "requested_folders_sorted: @requested_folders_sorted\n" ;
add_to_requested_folders( @requested_folders_sorted ) ;
return( @requested_folders_sorted ) ;
}
sub is_requested_folder
{
my ( $folder ) = @_;
return( defined $requested_folder{ $folder } ) ;
}
sub add_to_requested_folders
{
my @wanted_folders = @_ ;
foreach my $folder ( @wanted_folders ) {
++$requested_folder{ $folder } ;
}
return( keys %requested_folder ) ;
}
sub tests_remove_from_requested_folders
{
note( 'Entering tests_remove_from_requested_folders()' ) ;
is( undef, undef, 'remove_from_requested_folders: undef is undef' ) ;
is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: no args' ) ;
%requested_folder = (
'F1' => 1,
) ;
is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: remove nothing among F1 => nothing' ) ;
is_deeply( [], [ remove_from_requested_folders( 'Fno' ) ], 'remove_from_requested_folders: remove Fno among F1 => nothing' ) ;
is_deeply( [ 'F1' ], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F1 => F1' ) ;
is_deeply( { }, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 => %requested_folder emptied' ) ;
%requested_folder = (
'F1' => 1,
'F2' => 1,
) ;
is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: remove nothing among F1 F2 => nothing' ) ;
is_deeply( [], [ remove_from_requested_folders( 'Fno' ) ], 'remove_from_requested_folders: remove Fno among F1 F2 => nothing' ) ;
is_deeply( [ 'F1' ], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F1 F2 => F1' ) ;
is_deeply( { 'F2' => 1 }, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 F2 => %requested_folder F2' ) ;
is_deeply( [], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F2 => nothing' ) ;
is_deeply( [ 'F2' ], [ remove_from_requested_folders( 'F1', 'F2' ) ], 'remove_from_requested_folders: remove F1 F2 among F2 => F2' ) ;
is_deeply( {}, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 F2 => %requested_folder F2' ) ;
%requested_folder = (
'F1' => 1,
'F2' => 1,
'F3' => 1,
) ;
is_deeply( [ 'F1', 'F2' ], [ remove_from_requested_folders( 'F1', 'F2' ) ], 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => F1 F2' ) ;
is_deeply( { 'F3' => 1 }, { %requested_folder }, 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => %requested_folder F3' ) ;
undef %requested_folder ;
note( 'Leaving tests_remove_from_requested_folders()' ) ;
return ;
}
sub remove_from_requested_folders
{
my @unwanted_folders = @_ ;
my @removed_folders = () ;
foreach my $folder ( @unwanted_folders ) {
if ( exists $requested_folder{ $folder } )
{
delete $requested_folder{ $folder } ;
push @removed_folders, $folder ;
}
}
return( @removed_folders ) ;
}
sub compare_lists
{
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
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;
ELEMENT:
foreach my $indice ( 0 .. $#{ $list_1_ref } ) {
$last_used_indice = $indice ;
# End of list_2
return 1 if ($indice > $#{ $list_2_ref } ) ;
my $element_list_1 = $list_1_ref->[$indice] ;
my $element_list_2 = $list_2_ref->[$indice] ;
my $balance = $element_list_1 cmp $element_list_2 ;
next ELEMENT if ($balance == 0) ;
return $balance ;
}
# each element equal until last indice of list_1
return $MINUS_ONE if ($last_used_indice < $#{ $list_2_ref } ) ;
# same size, each element equal
return 0 ;
}
sub tests_compare_lists
{
note( 'Entering tests_compare_lists()' ) ;
my $empty_list_ref = [];
ok( 0 == compare_lists() , 'compare_lists, no args');
ok( 0 == compare_lists(undef) , 'compare_lists, undef = nothing');
ok( 0 == compare_lists(undef, undef) , 'compare_lists, undef = undef');
ok($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($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,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') ;
note( 'Leaving tests_compare_lists()' ) ;
return ;
}
sub guess_prefix
{
my @foldernames = @_ ;
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
{
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 ) ;
( $sync->{ 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" ) ;
( $sync->{ 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 ) ;
}else{
# 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{
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 = @_ ;
#return( undef ) unless ( @foldernames ) ;
my $sep_guessed ;
my %counter ;
foreach my $folder ( @foldernames ) {
$counter{'/'}++ while ( $folder =~ m{/}xg ) ; # count /
$counter{'.'}++ while ( $folder =~ m{\.}xg ) ; # count .
$counter{'\\\\'}++ while ( $folder =~ m{(\\){2}}xg ) ; # count \\
$counter{'\\'}++ while ( $folder =~ m{[^\\](\\){1}(?=[^\\])}xg ) ; # count \
}
my @race_sorted = sort { $counter{ $b } <=> $counter{ $a } } keys %counter ;
$sync->{ debug } and myprint( "@foldernames\n@race_sorted\n", %counter, "\n" ) ;
$sep_guessed = shift @race_sorted || $LAST_RESSORT_SEPARATOR ; # / when nothing found.
return( $sep_guessed ) ;
}
sub tests_guess_separator
{
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 ) ;
( $sync->{ 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" ) ;
( $sync->{ 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 ) ;
}else{
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 ) ;
}
}
}
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 ) ;
}
}
return ;
}
sub help_to_guess_sep
{
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 ) ;
return( $help_to_guess_sep ) ;
}
sub help_to_guess_prefix
{
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 ) ;
return( $help_to_guess_prefix ) ;
}
sub folders_list_to_help
{
my( $imap ) = shift @ARG ;
my @folders = $imap->folders ;
my $listing = join q{}, map { "[$_]\n" } @folders ;
return( $listing ) ;
}
# Globals are $sync @h1_folders_all @h2_folders_all $prefix1 $prefix2
sub private_folders_separators_and_prefixes
{
# what are the private folders separators and prefixes for each server ?
( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Getting separators\n" ) ;
$sync->{ h1_sep } = get_separator( $sync->{imap1}, $sync->{ sep1 }, '--sep1', 'Host1', \@h1_folders_all ) ;
$sync->{ h2_sep } = get_separator( $sync->{imap2}, $sync->{ sep2 }, '--sep2', 'Host2', \@h2_folders_all ) ;
$sync->{ h1_prefix } = get_prefix( $sync->{imap1}, $prefix1, '--prefix1', 'Host1', \@h1_folders_all ) ;
$sync->{ h2_prefix } = get_prefix( $sync->{imap2}, $prefix2, '--prefix2', 'Host2', \@h2_folders_all ) ;
myprint( "Host1: separator and prefix: [$sync->{ h1_sep }][$sync->{ h1_prefix }]\n" ) ;
myprint( "Host2: separator and prefix: [$sync->{ h2_sep }][$sync->{ h2_prefix }]\n" ) ;
return ;
}
sub subfolder1
{
my $mysync = shift @ARG ;
my $subfolder1 = sanitize_subfolder( $mysync->{ subfolder1 } ) ;
if ( $subfolder1 )
{
# turns off automap
myprint( "Turning off automapping folders because of --subfolder1\n" ) ;
$mysync->{ automap } = undef ;
myprint( "Sanitizing subfolder1: [$mysync->{ subfolder1 }] => [$subfolder1]\n" ) ;
$mysync->{ subfolder1 } = $subfolder1 ;
if ( ! add_subfolder1_to_folderrec( $mysync ) )
{
$mysync->{nb_errors}++ ;
exit_clean( $mysync, $EXIT_SUBFOLDER1_NO_EXISTS, "subfolder1 $subfolder1 does not exist\n" ) ;
}
}
else
{
$mysync->{ subfolder1 } = undef ;
}
return ;
}
sub subfolder2
{
my $mysync = shift @ARG ;
my $subfolder2 = sanitize_subfolder( $mysync->{ subfolder2 } ) ;
if ( $subfolder2 )
{
# turns off automap
myprint( "Turning off automapping folders because of --subfolder2\n" ) ;
$mysync->{ automap } = undef ;
myprint( "Sanitizing subfolder2: [$mysync->{ subfolder2 }] => [$subfolder2]\n" ) ;
$mysync->{ subfolder2 } = $subfolder2 ;
set_regextrans2_for_subfolder2( $mysync ) ;
}
else
{
$mysync->{ subfolder2 } = undef ;
}
return ;
}
sub tests_sanitize_subfolder
{
note( 'Entering tests_sanitize_subfolder()' ) ;
is( undef, sanitize_subfolder( ), 'sanitize_subfolder: no args => undef' ) ;
is( undef, sanitize_subfolder( q{} ), 'sanitize_subfolder: empty => undef' ) ;
is( undef, sanitize_subfolder( ' ' ), 'sanitize_subfolder: blank => undef' ) ;
is( undef, sanitize_subfolder( ' ' ), 'sanitize_subfolder: blanks => undef' ) ;
is( 'abcd', sanitize_subfolder( 'abcd' ), 'sanitize_subfolder: abcd => abcd' ) ;
is( 'ab cd', sanitize_subfolder( ' ab cd ' ), 'sanitize_subfolder: " ab cd " => "ab cd"' ) ;
is( 'abcd', sanitize_subfolder( q{a&~b#\\c[]=d;} ), 'sanitize_subfolder: "a&~b#\\c[]=d;" => "abcd"' ) ;
is( 'aA.b-_ 8c/dD', sanitize_subfolder( 'aA.b-_ 8c/dD' ), 'sanitize_subfolder: aA.b-_ 8c/dD => aA.b-_ 8c/dD' ) ;
note( 'Leaving tests_sanitize_subfolder()' ) ;
return ;
}
sub sanitize_subfolder
{
my $subfolder = shift @ARG ;
if ( ! $subfolder )
{
return ;
}
# Remove edging blanks
$subfolder =~ s,^ +| +$,,g ;
# Keep only abcd...ABCD...0123... and -_./
$subfolder =~ tr,-_a-zA-Z0-9./ ,,cd ;
# A blank subfolder is not a subfolder
if ( ! $subfolder )
{
return ;
}
else
{
return $subfolder ;
}
}
sub tests_sanitize_host
{
note( 'Entering tests_sanitize_host()' ) ;
is( undef, sanitize_host( ), 'sanitize_host: no args => undef' ) ;
is( '', sanitize_host( '' ), 'sanitize_host: empty => empty' ) ;
is( 'imap.example.org', sanitize_host( 'imap.example.org' ), 'sanitize_host: imap.example.org => imap.example.org' ) ;
is( 'imap.example.org', sanitize_host( ' imap.example.org' ), 'sanitize_host: imap.example.org 1 => imap.example.org' ) ;
is( 'imap.example.org', sanitize_host( 'imap.example.org ' ), 'sanitize_host: imap.example.org 2 => imap.example.org' ) ;
is( 'imap.example.org', sanitize_host( 'imap.exam ple.org' ), 'sanitize_host: imap.example.org 3 => imap.example.org' ) ;
is( 'imap.example.org', sanitize_host( ' imap.exam ple.org ' ), 'sanitize_host: imap.example.org 4 => imap.example.org' ) ;
is( 'imap.example.org', sanitize_host( 'imap.exa/mple.org/' ), 'sanitize_host: imap.example.org/ => imap.example.org' ) ;
note( 'Leaving tests_sanitize_host()' ) ;
return ;
}
sub sanitize_host
{
my $host = shift @ARG ;
if ( ! defined $host ) { return ; }
$host =~ tr{ /}{}d ;
return $host ;
}
sub tests_add_subfolder1_to_folderrec
{
note( 'Entering tests_add_subfolder1_to_folderrec()' ) ;
is( undef, add_subfolder1_to_folderrec( ), 'add_subfolder1_to_folderrec: undef => undef' ) ;
is_deeply( [], [ add_subfolder1_to_folderrec( ) ], 'add_subfolder1_to_folderrec: no args => empty array' ) ;
@folderrec = () ;
my $mysync = {} ;
is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: empty => empty array' ) ;
is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: empty => empty folderrec' ) ;
$mysync->{ subfolder1 } = 'SUBI' ;
$h1_folders_all{ 'SUBI' } = 1 ;
$mysync->{ h1_prefix } = 'INBOX/' ;
is_deeply( [ 'SUBI' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBI => SUBI' ) ;
is_deeply( [ 'SUBI' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBI => folderrec SUBI ' ) ;
@folderrec = () ;
$mysync->{ subfolder1 } = 'SUBO' ;
is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO no exists => empty array' ) ;
is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO no exists => empty folderrec' ) ;
$h1_folders_all{ 'INBOX/SUBO' } = 1 ;
is_deeply( [ 'INBOX/SUBO' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO' ) ;
is_deeply( [ 'INBOX/SUBO' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO folderrec' ) ;
note( 'Leaving tests_add_subfolder1_to_folderrec()' ) ;
return ;
}
sub add_subfolder1_to_folderrec
{
my $mysync = shift @ARG ;
if ( ! $mysync || ! $mysync->{ subfolder1 } )
{
return ;
}
my $subfolder1 = $mysync->{ subfolder1 } ;
my $subfolder1_extended = $mysync->{ h1_prefix } . $subfolder1 ;
if ( exists $h1_folders_all{ $subfolder1 } )
{
myprint( qq{Acting like --folderrec "$subfolder1"\n} ) ;
push @folderrec, $subfolder1 ;
}
elsif ( exists $h1_folders_all{ $subfolder1_extended } )
{
myprint( qq{Acting like --folderrec "$subfolder1_extended"\n} ) ;
push @folderrec, $subfolder1_extended ;
}
else
{
myprint( qq{Nor folder "$subfolder1" nor "$subfolder1_extended" exists on host1\n} ) ;
}
return @folderrec ;
}
sub set_regextrans2_for_subfolder2
{
my $mysync = shift @ARG ;
unshift @{ $mysync->{ regextrans2 } },
q(s,^$mysync->{ h2_prefix }(.*),$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }$1,),
q(s,^INBOX$,$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }INBOX,),
q(s,^($mysync->{ h2_prefix }){2},$mysync->{ h2_prefix },);
#myprint( "@{ $mysync->{ regextrans2 } }\n" ) ;
return ;
}
# Looks like no globals here
sub tests_imap2_folder_name
{
note( 'Entering tests_imap2_folder_name()' ) ;
my $mysync = {} ;
$mysync->{ h1_prefix } = q{} ;
$mysync->{ h2_prefix } = q{} ;
$mysync->{ h1_sep } = '/';
$mysync->{ h2_sep } = '.';
$mysync->{ debug } and myprint( <<"EOS"
prefix1: [$mysync->{ h1_prefix }]
prefix2: [$mysync->{ h2_prefix }]
sep1: [$sync->{ h1_sep }]
sep2: [$sync->{ h2_sep }]
EOS
) ;
$mysync->{ fixslash2 } = 0 ;
is( q{INBOX}, imap2_folder_name( $mysync, q{} ), 'imap2_folder_name: empty string' ) ;
is( 'blabla', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla' ) ;
is('spam.spam', imap2_folder_name( $mysync, 'spam/spam' ), 'imap2_folder_name: spam/spam' ) ;
is( 'spam/spam', imap2_folder_name( $mysync, 'spam.spam' ), 'imap2_folder_name: spam.spam') ;
is( 'spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam' ) ;
is( 's pam.spam/sp am', imap2_folder_name( $mysync, 's pam/spam.sp am' ), 'imap2_folder_name: s pam/spam.sp am' ) ;
$mysync->{f1f2h}{ 'auto' } = 'moto' ;
is( 'moto', imap2_folder_name( $mysync, 'auto' ), 'imap2_folder_name: auto' ) ;
$mysync->{f1f2h}{ 'auto/auto' } = 'moto x 2' ;
is( 'moto x 2', imap2_folder_name( $mysync, 'auto/auto' ), 'imap2_folder_name: auto/auto' ) ;
@{ $mysync->{ regextrans2 } } = ( 's,/,X,g' ) ;
is( q{INBOX}, imap2_folder_name( $mysync, q{} ), 'imap2_folder_name: empty string [s,/,X,g]' ) ;
is( 'blabla', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla [s,/,X,g]' ) ;
is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam [s,/,X,g]');
is('spamXspam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam [s,/,X,g]');
is('spam.spamXspam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam [s,/,X,g]');
@{ $mysync->{ regextrans2 } } = ( 's, ,_,g' ) ;
is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla [s, ,_,g]');
is('bla_bla', imap2_folder_name( $mysync, 'bla bla'), 'imap2_folder_name: blabla [s, ,_,g]');
@{ $mysync->{ regextrans2 } } = ( q{s,(.*),\U$1,} ) ;
is( 'BLABLA', imap2_folder_name( $mysync, 'blabla' ), q{imap2_folder_name: blabla [s,\U(.*)\E,$1,]} ) ;
$mysync->{ fixslash2 } = 1 ;
@{ $mysync->{ regextrans2 } } = ( ) ;
is(q{INBOX}, imap2_folder_name( $mysync, q{}), 'imap2_folder_name: empty string');
is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla');
is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam');
is('spam_spam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam -> spam_spam');
is('spam.spam_spam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam_spam');
is('s pam.spam_spa m', imap2_folder_name( $mysync, 's pam/spam.spa m'), 'imap2_folder_name: s pam/spam.spa m -> s pam.spam_spa m');
$mysync->{ h1_sep } = '.';
$mysync->{ h2_sep } = '/';
is( q{INBOX}, imap2_folder_name( $mysync, q{}), 'imap2_folder_name: empty string');
is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla');
is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam');
is('spam/spam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam -> spam/spam');
is('spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam');
$mysync->{ fixslash2 } = 0 ;
$mysync->{ h1_prefix } = q{ };
is( 'spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam' ) ;
is( 'spam.spam/spam', imap2_folder_name( $mysync, ' spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam' ) ;
$mysync->{ h1_sep } = '.' ;
$mysync->{ h2_sep } = '/' ;
$mysync->{ h1_prefix } = 'INBOX.' ;
$mysync->{ h2_prefix } = q{} ;
@{ $mysync->{ regextrans2 } } = ( q{s,(.*),\U$1,} ) ;
is( 'BLABLA', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla' ) ;
is( 'TEST/TEST/TEST/TEST', imap2_folder_name( $mysync, 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ;
@{ $mysync->{ regextrans2 } } = ( q{s,(.*),\L$1,} ) ;
is( 'test/test/test/test', imap2_folder_name( $mysync, 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ;
# INBOX
$mysync = {} ;
$mysync->{ h1_prefix } = q{Pf1.} ;
$mysync->{ h2_prefix } = q{Pf2/} ;
$mysync->{ h1_sep } = '.';
$mysync->{ h2_sep } = '/';
#
#$mysync->{ debug } = 1 ;
is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'F1.F2.F3' ), 'imap2_folder_name: F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
is( 'Pf2/F1/INBOX', imap2_folder_name( $mysync, 'F1.INBOX' ), 'imap2_folder_name: F1.INBOX -> Pf2/F1/INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: INBOX -> INBOX' ) ;
is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.F1.F2.F3' ), 'imap2_folder_name: Pf1.F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
is( 'Pf2/F1/INBOX', imap2_folder_name( $mysync, 'Pf1.F1.INBOX' ), 'imap2_folder_name: Pf1.F1.INBOX -> Pf2/F1/INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.INBOX' ), 'imap2_folder_name: Pf1.INBOX -> INBOX' ) ; # not Pf2/INBOX: Yes I can!
# subfolder2
$mysync = {} ;
$mysync->{ h1_prefix } = q{} ;
$mysync->{ h2_prefix } = q{} ;
$mysync->{ h1_sep } = '/';
$mysync->{ h2_sep } = '.';
set_regextrans2_for_subfolder2( $mysync ) ;
$mysync->{ subfolder2 } = 'S1.S2' ;
is( 'S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.F1.F2.F3' ) ;
is( 'S1.S2.INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.INBOX' ) ;
$mysync = {} ;
$mysync->{ h1_prefix } = q{Pf1/} ;
$mysync->{ h2_prefix } = q{Pf2.} ;
$mysync->{ h1_sep } = '/';
$mysync->{ h2_sep } = '.';
#$mysync->{ debug } = 1 ;
set_regextrans2_for_subfolder2( $mysync ) ;
$mysync->{ subfolder2 } = 'Pf2.S1.S2' ;
is( 'Pf2.S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> Pf2.S1.S2.F1.F2.F3' ) ;
is( 'Pf2.S1.S2.INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: INBOX -> Pf2.S1.S2.INBOX' ) ;
is( 'Pf2.S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'Pf1/F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> Pf2.S1.S2.F1.F2.F3' ) ;
is( 'Pf2.S1.S2.INBOX', imap2_folder_name( $mysync, 'Pf1/INBOX' ), 'imap2_folder_name: INBOX -> Pf2.S1.S2.INBOX' ) ;
# subfolder1
# scenario as the reverse of the previous tests, separators point of vue
$mysync = {} ;
$mysync->{ h1_prefix } = q{Pf1.} ;
$mysync->{ h2_prefix } = q{Pf2/} ;
$mysync->{ h1_sep } = '.';
$mysync->{ h2_sep } = '/';
#$mysync->{ debug } = 1 ;
$mysync->{ subfolder1 } = 'S1.S2' ;
is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'S1.S2.F1.F2.F3' ), 'imap2_folder_name: S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.S1.S2.F1.F2.F3' ), 'imap2_folder_name: Pf1.S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.INBOX' ), 'imap2_folder_name: S1.S2.INBOX -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2' ), 'imap2_folder_name: S1.S2 -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.' ), 'imap2_folder_name: S1.S2. -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.INBOX' ), 'imap2_folder_name: Pf1.S1.S2.INBOX -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2' ), 'imap2_folder_name: Pf1.S1.S2 -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.' ), 'imap2_folder_name: Pf1.S1.S2. -> INBOX' ) ;
$mysync->{ subfolder1 } = 'S1.S2.' ;
is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'S1.S2.F1.F2.F3' ), 'imap2_folder_name: S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.S1.S2.F1.F2.F3' ), 'imap2_folder_name: Pf1.S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.INBOX' ), 'imap2_folder_name: S1.S2.INBOX -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2' ), 'imap2_folder_name: S1.S2 -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.' ), 'imap2_folder_name: S1.S2. -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.INBOX' ), 'imap2_folder_name: Pf1.S1.S2.INBOX -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2' ), 'imap2_folder_name: Pf1.S1.S2 -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.' ), 'imap2_folder_name: Pf1.S1.S2. -> INBOX' ) ;
# subfolder1
# scenario as Gmail
$mysync = {} ;
$mysync->{ h1_prefix } = q{} ;
$mysync->{ h2_prefix } = q{} ;
$mysync->{ h1_sep } = '/';
$mysync->{ h2_sep } = '/';
#$mysync->{ debug } = 1 ;
$mysync->{ subfolder1 } = 'S1/S2' ;
is( 'F1/F2/F3', imap2_folder_name( $mysync, 'S1/S2/F1/F2/F3' ), 'imap2_folder_name: S1/S2/F1/F2/F3 -> F1/F2/F3' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/INBOX' ), 'imap2_folder_name: S1/S2/INBOX -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2' ), 'imap2_folder_name: S1/S2 -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/' ), 'imap2_folder_name: S1/S2/ -> INBOX' ) ;
$mysync->{ subfolder1 } = 'S1/S2/' ;
is( 'F1/F2/F3', imap2_folder_name( $mysync, 'S1/S2/F1/F2/F3' ), 'imap2_folder_name: S1/S2/F1/F2/F3 -> F1/F2/F3' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/INBOX' ), 'imap2_folder_name: S1/S2/INBOX -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2' ), 'imap2_folder_name: S1/S2 -> INBOX' ) ;
is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/' ), 'imap2_folder_name: S1/S2/ -> INBOX' ) ;
note( 'Leaving tests_imap2_folder_name()' ) ;
return ;
}
# Global variables to remove:
# None?
sub imap2_folder_name
{
my $mysync = shift @ARG ;
my ( $h1_fold ) = shift @ARG ;
my ( $h2_fold ) ;
if ( $mysync->{f1f2h}{ $h1_fold } ) {
$h2_fold = $mysync->{f1f2h}{ $h1_fold } ;
( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "f1f2 [$h1_fold] -> [$h2_fold]\n" ) ;
return( $h2_fold ) ;
}
if ( $mysync->{f1f2auto}{ $h1_fold } ) {
$h2_fold = $mysync->{f1f2auto}{ $h1_fold } ;
( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "automap [$h1_fold] -> [$h2_fold]\n" ) ;
return( $h2_fold ) ;
}
if ( $mysync->{ subfolder1 } )
{
my $esc_h1_sep = "\\" . $mysync->{ h1_sep } ;
# case where subfolder1 has the sep1 at the end, then remove it
my $part_to_removed = remove_last_char_if_is( $mysync->{ subfolder1 }, $mysync->{ h1_sep } ) ;
# remove the subfolder1 part and the sep1 if present after
$h1_fold =~ s{$part_to_removed($esc_h1_sep)?}{} ;
#myprint( "h1_fold=$h1_fold\n" ) ;
}
if ( ( q{} eq $h1_fold ) or ( $mysync->{ h1_prefix } eq $h1_fold ) )
{
$h1_fold = 'INBOX' ;
}
$h2_fold = prefix_seperator_invertion( $mysync, $h1_fold ) ;
$h2_fold = regextrans2( $mysync, $h2_fold ) ;
return( $h2_fold ) ;
}
sub tests_remove_last_char_if_is
{
note( 'Entering tests_remove_last_char_if_is()' ) ;
is( undef, remove_last_char_if_is( ), 'remove_last_char_if_is: no args => undef' ) ;
is( q{}, remove_last_char_if_is( q{} ), 'remove_last_char_if_is: empty => empty' ) ;
is( q{}, remove_last_char_if_is( q{}, 'Z' ), 'remove_last_char_if_is: empty Z => empty' ) ;
is( q{}, remove_last_char_if_is( 'Z', 'Z' ), 'remove_last_char_if_is: Z Z => empty' ) ;
is( 'abc', remove_last_char_if_is( 'abcZ', 'Z' ), 'remove_last_char_if_is: abcZ Z => abc' ) ;
is( 'abcY', remove_last_char_if_is( 'abcY', 'Z' ), 'remove_last_char_if_is: abcY Z => abcY' ) ;
note( 'Leaving tests_remove_last_char_if_is()' ) ;
return ;
}
sub remove_last_char_if_is
{
my $string = shift @ARG ;
my $char = shift @ARG ;
if ( ! defined $string )
{
return ;
}
if ( ! defined $char )
{
return $string ;
}
my $last_char = substr $string, -1 ;
if ( $char eq $last_char )
{
chop $string ;
return $string ;
}
else
{
return $string ;
}
}
sub tests_prefix_seperator_invertion
{
note( 'Entering tests_prefix_seperator_invertion()' ) ;
is( undef, prefix_seperator_invertion( ), 'prefix_seperator_invertion: no args => undef' ) ;
is( q{}, prefix_seperator_invertion( undef, q{} ), 'prefix_seperator_invertion: empty string => empty string' ) ;
is( 'lalala', prefix_seperator_invertion( undef, 'lalala' ), 'prefix_seperator_invertion: lalala => lalala' ) ;
is( 'lal/ala', prefix_seperator_invertion( undef, 'lal/ala' ), 'prefix_seperator_invertion: lal/ala => lal/ala' ) ;
is( 'lal.ala', prefix_seperator_invertion( undef, 'lal.ala' ), 'prefix_seperator_invertion: lal.ala => lal.ala' ) ;
is( '////', prefix_seperator_invertion( undef, '////' ), 'prefix_seperator_invertion: //// => ////' ) ;
is( '.....', prefix_seperator_invertion( undef, '.....' ), 'prefix_seperator_invertion: ..... => .....' ) ;
my $mysync = {
h1_prefix => q{},
h2_prefix => q{},
h1_sep => '/',
h2_sep => '/',
} ;
is( q{}, prefix_seperator_invertion( $mysync, q{} ), 'prefix_seperator_invertion: $mysync empty string => empty string' ) ;
is( 'lalala', prefix_seperator_invertion( $mysync, 'lalala' ), 'prefix_seperator_invertion: $mysync lalala => lalala' ) ;
is( 'lal/ala', prefix_seperator_invertion( $mysync, 'lal/ala' ), 'prefix_seperator_invertion: $mysync lal/ala => lal/ala' ) ;
is( 'lal.ala', prefix_seperator_invertion( $mysync, 'lal.ala' ), 'prefix_seperator_invertion: $mysync lal.ala => lal.ala' ) ;
is( '////', prefix_seperator_invertion( $mysync, '////' ), 'prefix_seperator_invertion: $mysync //// => ////' ) ;
is( '.....', prefix_seperator_invertion( $mysync, '.....' ), 'prefix_seperator_invertion: $mysync ..... => .....' ) ;
$mysync = {
h1_prefix => 'PPP',
h2_prefix => 'QQQ',
h1_sep => 's',
h2_sep => 't',
} ;
is( q{QQQ}, prefix_seperator_invertion( $mysync, q{} ), 'prefix_seperator_invertion: PPPQQQst empty string => QQQ' ) ;
is( 'QQQlalala', prefix_seperator_invertion( $mysync, 'lalala' ), 'prefix_seperator_invertion: PPPQQQst lalala => QQQlalala' ) ;
is( 'QQQlal/ala', prefix_seperator_invertion( $mysync, 'lal/ala' ), 'prefix_seperator_invertion: PPPQQQst lal/ala => QQQlal/ala' ) ;
is( 'QQQlal.ala', prefix_seperator_invertion( $mysync, 'lal.ala' ), 'prefix_seperator_invertion: PPPQQQst lal.ala => QQQlal.ala' ) ;
is( 'QQQ////', prefix_seperator_invertion( $mysync, '////' ), 'prefix_seperator_invertion: PPPQQQst //// => QQQ////' ) ;
is( 'QQQ.....', prefix_seperator_invertion( $mysync, '.....' ), 'prefix_seperator_invertion: PPPQQQst ..... => QQQ.....' ) ;
is( 'QQQPlalala', prefix_seperator_invertion( $mysync, 'PPPPlalala' ), 'prefix_seperator_invertion: PPPQQQst PPPPlalala => QQQPlalala' ) ;
is( 'QQQ', prefix_seperator_invertion( $mysync, 'PPP' ), 'prefix_seperator_invertion: PPPQQQst PPP => QQQ' ) ;
is( 'QQQttt', prefix_seperator_invertion( $mysync, 'sss' ), 'prefix_seperator_invertion: PPPQQQst sss => QQQttt' ) ;
is( 'QQQt', prefix_seperator_invertion( $mysync, 's' ), 'prefix_seperator_invertion: PPPQQQst s => QQQt' ) ;
is( 'QQQtAAAtBBB', prefix_seperator_invertion( $mysync, 'PPPsAAAsBBB' ), 'prefix_seperator_invertion: PPPQQQst PPPsAAAsBBB => QQQtAAAtBBB' ) ;
note( 'Leaving tests_prefix_seperator_invertion()' ) ;
return ;
}
# Global variables to remove:
sub prefix_seperator_invertion
{
my $mysync = shift @ARG ;
my $h1_fold = shift @ARG ;
my $h2_fold ;
if ( not defined $h1_fold ) { return ; }
my $my_h1_prefix = $mysync->{ h1_prefix } || q{} ;
my $my_h2_prefix = $mysync->{ h2_prefix } || q{} ;
my $my_h1_sep = $mysync->{ h1_sep } || '/' ;
my $my_h2_sep = $mysync->{ h2_sep } || '/' ;
# first we remove the prefix
$h1_fold =~ s/^\Q$my_h1_prefix\E//x ;
( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "removed host1 prefix: [$h1_fold]\n" ) ;
$h2_fold = separator_invert( $mysync, $h1_fold, $my_h1_sep, $my_h2_sep ) ;
( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "inverted separators: [$h2_fold]\n" ) ;
# Adding the prefix supplied by namespace or the --prefix2 option
# except for INBOX or Inbox
if ( $h2_fold !~ m/^INBOX$/xi )
{
$h2_fold = $my_h2_prefix . $h2_fold ;
}
( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "added host2 prefix: [$h2_fold]\n" ) ;
return( $h2_fold ) ;
}
sub tests_separator_invert
{
note( 'Entering tests_separator_invert()' ) ;
my $mysync = {} ;
$mysync->{ 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( $mysync, q{}, q{}, q{} ), 'separator_invert: 3 empty strings' ) ;
ok( 'lalala' eq separator_invert( $mysync, 'lalala', q{}, q{} ), 'separator_invert: empty separator' ) ;
ok( 'lalala' eq separator_invert( $mysync, 'lalala', '/', '/' ), 'separator_invert: same separator /' ) ;
ok( 'lal/ala' eq separator_invert( $mysync, 'lal/ala', '/', '/' ), 'separator_invert: same separator / 2' ) ;
ok( 'lal.ala' eq separator_invert( $mysync, 'lal/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
ok( 'lal/ala' eq separator_invert( $mysync, 'lal.ala', '.', '/' ), 'separator_invert: separators ./' ) ;
ok( 'la.l/ala' eq separator_invert( $mysync, 'la/l.ala', '.', '/' ), 'separator_invert: separators ./' ) ;
ok( 'l/al.ala' eq separator_invert( $mysync, 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
$mysync->{ fixslash2 } = 1 ;
ok( 'l_al.ala' eq separator_invert( $mysync, 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
note( 'Leaving tests_separator_invert()' ) ;
return ;
}
# Global variables to remove:
#
sub separator_invert
{
my( $mysync, $h1_fold, $h1_separator, $h2_separator ) = @_ ;
return( undef ) if ( not all_defined( $mysync, $h1_fold, $h1_separator, $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 ;
$h2_fold =~ s,/,_,xg if( $mysync->{ fixslash2 } and '/' ne $h2_separator and '/' eq $h1_separator ) ;
return( $h2_fold ) ;
}
sub regextrans2
{
my( $mysync, $h2_fold ) = @_ ;
# Transforming the folder name by the --regextrans2 option(s)
foreach my $regextrans2 ( @{ $mysync->{ regextrans2 } } ) {
my $h2_fold_before = $h2_fold ;
my $ret = eval "\$h2_fold =~ $regextrans2 ; 1 " ;
( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "[$h2_fold_before] -> [$h2_fold] using regextrans2 [$regextrans2]\n" ) ;
if ( not ( defined $ret ) or $EVAL_ERROR ) {
$mysync->{nb_errors}++ ;
exit_clean( $mysync, $EX_USAGE,
"error: eval regextrans2 '$regextrans2': $EVAL_ERROR\n"
) ;
}
}
return( $h2_fold ) ;
}
sub tests_decompose_regex
{
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 @ARG ;
my( $left_part, $right_part ) ;
( $left_part, $right_part ) = $regex =~ m{^s/((?:[^/]|\\/)+)/((?:[^/]|\\/)+)/}x;
return( q{}, q{} ) if not $left_part ;
return( $left_part, $right_part ) ;
}
sub tests_timenext
{
note( 'Entering tests_timenext()' ) ;
is( undef, timenext( ), 'timenext: no args => undef' ) ;
my $mysync ;
is( undef, timenext( $mysync ), 'timenext: undef => undef' ) ;
$mysync = {} ;
ok( time - timenext( $mysync ) <= 1e-02, 'timenext: defined first time => ~ time' ) ;
ok( timenext( $mysync ) <= 1e-02, 'timenext: second time => less than 1e-02' ) ;
ok( timenext( $mysync ) <= 1e-02, 'timenext: third time => less than 1e-02' ) ;
note( 'Leaving tests_timenext()' ) ;
return ;
}
sub timenext
{
my $mysync = shift @ARG ;
if ( ! defined $mysync )
{
return ;
}
my ( $timenow, $timediff ) ;
$mysync->{ timebefore } ||= 0; # epoch...
$timenow = time ;
$timediff = $timenow - $mysync->{ timebefore } ;
$mysync->{ timebefore } = $timenow ;
# myprint( "timenext: $timediff\n" ) ;
return( $timediff ) ;
}
sub tests_timesince
{
note( 'Entering tests_timesince()' ) ;
ok( timesince( time - 1 ) - 1 <= 1e-02, 'timesince: time - 1 => <= 1 + 1e-02' ) ;
ok( timesince( time ) <= 1e-02, 'timesince: time => <= 1e-02' ) ;
ok( timesince( ) - time <= 1e-02, 'timesince: no args => <= time + 1e-02' ) ;
note( 'Leaving tests_timesince()' ) ;
return ;
}
sub timesince
{
my $timeinit = shift || 0 ;
my ( $timenow, $timediff ) ;
$timenow = time ;
$timediff = $timenow - $timeinit ;
# Often used in a division so no 0 but a nano second.
return( max( $timediff, min( 1e-09, $timediff ) ) ) ;
}
sub tests_regexflags
{
note( 'Entering tests_regexflags()' ) ;
my $mysync = {} ;
ok( q{} eq regexflags( $mysync, q{} ), 'regexflags, null string q{}' ) ;
ok( q{\Seen NonJunk $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, nothing to do} ) ;
@{ $mysync->{ regexflag } } = ('I am BAD' ) ;
ok( not ( defined regexflags( $mysync, q{} ) ), 'regexflags, bad regex' ) ;
@{ $mysync->{ regexflag } } = ( 's/NonJunk//g' ) ;
ok( q{\Seen $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, remove NonJunk: 's/NonJunk//g'} ) ;
@{ $mysync->{ regexflag } } = ( q{s/\$Spam//g} ) ;
ok( q{\Seen NonJunk } eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, remove $Spam: 's/\$Spam//g'} ) ;
@{ $mysync->{ regexflag } } = ( 's/\\\\Seen//g' ) ;
ok( q{ NonJunk $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, remove \Seen: 's/\\\\\\\\Seen//g'} ) ;
@{ $mysync->{ regexflag } } = ( 's/(\s|^)[^\\\\]\w+//g' ) ;
ok( q{\Seen \Middle \End} eq regexflags( $mysync, q{\Seen NonJunk \Middle $Spam \End} ), q{regexflags: only \word among \Seen NonJunk \Middle $Spam \End} ) ;
ok( q{ \Seen \Middle \End1} eq regexflags( $mysync, q{Begin \Seen NonJunk \Middle $Spam \End1 End} ),
q{regexflags: only \word among Begin \Seen NonJunk \Middle $Spam \End1 End} ) ;
@{ $mysync->{ regexflag } } = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g} ) ;
ok( 'Keep1 Keep2 ReB' eq regexflags( $mysync, 'ReA Keep1 REM Keep2 ReB' ), 'Keep only regex' ) ;
ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM REM Keep1 Keep2' ), 'Keep only regex' ) ;
ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 REM REM Keep2' ), 'Keep only regex' ) ;
ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM REM Keep2' ), 'Keep only regex' ) ;
ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2' ), 'Keep only regex' ) ;
ok( 'Keep1 ' eq regexflags( $mysync, 'REM Keep1' ), 'Keep only regex' ) ;
@{ $mysync->{ regexflag } } = ( q{s/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g} ) ;
ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2 ReB' ), 'Keep only regex' ) ;
ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2 REM REM REM' ), 'Keep only regex' ) ;
ok( 'Keep2 ' eq regexflags( $mysync, 'Keep2 REM REM REM' ), 'Keep only regex' ) ;
@{ $mysync->{ regexflag } } = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g},
's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g' ) ;
ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2 REM' ), 'Keep only regex' ) ;
ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 REM Keep2 REM' ), 'Keep only regex' ) ;
ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 Keep2 REM' ), 'Keep only regex' ) ;
ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2' ), 'Keep only regex' ) ;
ok( 'Keep1 Keep2 Keep3 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2 REM REM Keep3 REM' ), 'Keep only regex' ) ;
ok( 'Keep1 ' eq regexflags( $mysync, 'REM REM Keep1 REM REM REM ' ), 'Keep only regex' ) ;
ok( 'Keep1 Keep3 ' eq regexflags( $mysync, 'RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 ' ), 'Keep only regex' ) ;
@{ $mysync->{ regexflag } } = ( 's/(.*)/$1 jrdH8u/' ) ;
ok('REM REM REM REM REM jrdH8u' eq regexflags( $mysync, 'REM REM REM REM REM' ), q{Add jrdH8u 's/(.*)/\$1 jrdH8u/'} ) ;
@{ $mysync->{ regexflag } } = ('s/jrdH8u *//' );
ok('REM REM REM REM REM ' eq regexflags( $mysync, 'REM REM REM REM REM jrdH8u' ), q{Remove jrdH8u s/jrdH8u *//} ) ;
@{ $mysync->{ regexflag } } = (
's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg'
);
ok( '\\Deleted \\Answered '
eq regexflags( $mysync, 'Blabla \$Junk \\Deleted machin \\Answered truc' ),
'Keep only regex: Exchange case (Phil)' ) ;
ok( q{} eq regexflags( $mysync, q{} ), 'Keep only regex: Exchange case, null string (Phil)' ) ;
ok( q{}
eq regexflags( $mysync, 'Blabla $Junk machin truc' ),
'Keep only regex: Exchange case, no accepted flags (Phil)' ) ;
ok('\\Deleted \\Answered \\Draft \\Flagged '
eq regexflags( $mysync, '\\Deleted \\Answered \\Draft \\Flagged ' ),
'Keep only regex: Exchange case (Phil)' ) ;
@{ $mysync->{ regexflag } } = ( 's/\\\\Flagged//g' ) ;
is('\Deleted \Answered \Draft ',
regexflags( $mysync, '\\Deleted \\Answered \\Draft \\Flagged ' ),
'regexflags: remove \Flagged 1' ) ;
is('\\Deleted \\Answered \\Draft',
regexflags( $mysync, '\\Deleted \\Flagged \\Answered \\Draft' ),
'regexflags: remove \Flagged 2' ) ;
# I didn't understand why it gives \F
# https://perldoc.perl.org/perlrebackslash.html
# \F Foldcase till \E. Not in [].
# https://perldoc.perl.org/functions/fc.html
# \F Not available in old Perl so I comment the test
# @{ $mysync->{ regexflag } } = ( 's/\\Flagged/X/g' ) ;
#is('\Deleted FX \Answered \FX \Draft \FX',
#regexflags( '\Deleted Flagged \Answered \Flagged \Draft \Flagged' ),
# 'regexflags: remove \Flagged 3 mistery...' ) ;
is( '\\ \ ', '\ \\ ', 'regexflags: \\ \ is \ \\ ' ) ;
note( 'Leaving tests_regexflags()' ) ;
return ;
}
sub regexflags
{
my $mysync = shift @ARG ;
my $flags = shift @ARG ;
foreach my $regexflag ( @{ $mysync->{ regexflag } } )
{
my $flags_orig = $flags ;
$mysync->{ debugflags } and myprint( "eval \$flags =~ $regexflag\n" ) ;
my $ret = eval "\$flags =~ $regexflag ; 1 " ;
$mysync->{ debugflags } and myprint( "regexflag $regexflag [$flags_orig] -> [$flags]\n" ) ;
if( not ( defined $ret ) or $EVAL_ERROR ) {
myprint( "Error: eval regexflag '$regexflag': $EVAL_ERROR\n" ) ;
return( undef ) ;
}
}
return( $flags ) ;
}
sub tests_filterbuggyflags
{
note( 'Entering tests_regexflags()' ) ;
my $mysync = {} ;
$mysync->{ regexflag } = [ ] ;
$mysync->{ filterbuggyflags } = 1 ;
filterbuggyflags( $mysync ) ;
#
is( '\Deleted \Answered \Draft \Flagged ',
regexflags( $mysync, '\\Deleted \\Answered \\RECEIPTCHECKED \\Draft \\Indexed \\Flagged \\JUNK \\Junk' ),
'regexflags: remove famous /X 1' ) ;
is( '\\Deleted \\Flagged \\Answered \\Draft',
regexflags( $mysync, '\\Deleted \\RECEIPTCHECKED \\Flagged \\Answered \\Indexed \\Draft' ),
'regexflags: remove famous /X 2' ) ;
is( '\ ', '\\ ', 'regexflags: \ is \\ ' ) ;
is( '\\ ', '\\ ', 'regexflags: \\ is \\ ' ) ;
note( 'Leaving tests_regexflags()' ) ;
return ;
}
sub buggyflagsregex
{
# From /X analyse
# cut -d: -f1 Error_112_all_syncs.txt | xargs egrep -oih 'Invalid system flag [^( ]+' | sort | uniq -c | sort -g
my @buggyflagsregex = ( 's/\\\\RECEIPTCHECKED|\\\\JUNK|\\\\Indexed|\\\\X-EON-HAS-ATTACHMENT|\\\\UNSEEN|\\\\ATTACHED|\\\\X-HAS-ATTACH|\\\\FORWARDED|\\\\FORWARD|\\\\X-FORWARDED|\\\\\$FORWARDED|\\\\PRIORITY|\\\\READRCPT//gi' ) ;
return( @buggyflagsregex ) ;
}
sub filterbuggyflags
{
my $mysync = shift @ARG ;
if ( $mysync->{ filterbuggyflags } )
{
unshift @{ $mysync->{ regexflag } }, buggyflagsregex( ) ;
}
return ;
}
sub tests_remove_doublequotes_if_any
{
note( 'Entering tests_remove_doublequotes_if_any()' ) ;
# the number of tests is stupid here
is( undef, remove_doublequotes_if_any( ), 'remove_doublequotes_if_any: no args => undef' ) ;
is( q{}, remove_doublequotes_if_any( q{} ), 'remove_doublequotes_if_any: empty string => empty string' ) ;
is( q{}, remove_doublequotes_if_any( q{""} ), 'remove_doublequotes_if_any: double-quotes => empty string' ) ;
is( q{}, remove_doublequotes_if_any( q{"""} ), 'remove_doublequotes_if_any: double-quotes => empty string' ) ;
is( q{}, remove_doublequotes_if_any( q{"""} ), 'remove_doublequotes_if_any: double-quotes => empty string' ) ;
is( q{toto}, remove_doublequotes_if_any( q{"toto"} ), 'remove_doublequotes_if_any: "toto" => toto' ) ;
is( q{toto}, remove_doublequotes_if_any( q{toto} ), 'remove_doublequotes_if_any: toto => toto' ) ;
is( q{toto}, remove_doublequotes_if_any( q{to"to} ), 'remove_doublequotes_if_any: to"to => toto' ) ;
is( q{toto}, remove_doublequotes_if_any( q{toto"} ), 'remove_doublequotes_if_any: toto" => toto' ) ;
is( q{toto}, remove_doublequotes_if_any( q{"toto} ), 'remove_doublequotes_if_any: "toto => toto' ) ;
is( q{toto}, remove_doublequotes_if_any( q{"to"to} ), 'remove_doublequotes_if_any: "to"to => toto' ) ;
is( q{toto}, remove_doublequotes_if_any( q{to"to"} ), 'remove_doublequotes_if_any: to"to" => toto' ) ;
is( q{toto}, remove_doublequotes_if_any( q{to\"to} ), 'remove_doublequotes_if_any: to\"to => toto' ) ;
is( q{toto}, remove_doublequotes_if_any( q{toto\"} ), 'remove_doublequotes_if_any: toto\" => toto' ) ;
is( q{toto}, remove_doublequotes_if_any( q{\"toto} ), 'remove_doublequotes_if_any: \"toto => toto' ) ;
is( q{toto}, remove_doublequotes_if_any( q{\"to\"to} ), 'remove_doublequotes_if_any: \"to\"to => toto' ) ;
is( q{toto}, remove_doublequotes_if_any( q{to\"to\"} ), 'remove_doublequotes_if_any: to\"to" => toto' ) ;
note( 'Leaving tests_remove_doublequotes_if_any()' ) ;
return ;
}
sub remove_doublequotes_if_any
{
my $string = shift @ARG ;
if ( ! defined $string ) { return ; }
$string =~ s/\\\"//g ;
$string =~ tr/"//d ;
return $string ;
}
# No globals here
sub acls_sync
{
# https://tools.ietf.org/html/rfc4314
# Standard Rights:
# https://tools.ietf.org/html/rfc4314#section-2.1
my( $mysync, $h1_fold, $h2_fold ) = @_ ;
if ( $mysync->{ syncacls } ) {
my $h1_hash = $mysync->{imap1}->getacl($h1_fold)
or myprint( "Host1: Could not getacl for $h1_fold: $EVAL_ERROR\n" ) ;
my $h2_hash = $mysync->{imap2}->getacl($h2_fold)
or myprint( "Host2: Could not getacl for $h2_fold: $EVAL_ERROR\n" ) ;
my %users = map { ($_, 1) } ( keys %{ $h1_hash} , keys %{ $h2_hash } ) ;
foreach my $user (sort keys %users ) {
my $h1_acl = remove_doublequotes_if_any( $h1_hash->{$user} ) || '' ;
my $h2_acl = remove_doublequotes_if_any( $h2_hash->{$user} ) || '' ;
myprint( "Host1: user $user has acl [$h1_acl] on host1\n" ) ;
myprint( "Host2: user $user has acl [$h2_acl] on host2\n" ) ;
# removes surrounding double-quotes if any
my $user_no_quotes = remove_doublequotes_if_any( $user ) ;
if ( $h1_hash->{$user}
&& $h2_hash->{$user}
&& $h1_hash->{$user} eq $h2_hash->{$user} )
{
myprint( "Host2: user $user_no_quotes has already the same acl, no need to set it.\n" ) ;
next ;
}
myprint( "Host2: setting acl for folder $h2_fold user $user_no_quotes acl $h1_acl $mysync->{dry_message}\n" ) ;
unless ( $mysync->{dry} ) {
$mysync->{imap2}->setacl( $h2_fold, $user_no_quotes, $h1_acl )
or myprint( "Could not set acl for user $user_no_quotes on host2: $EVAL_ERROR\n" ) ;
}
}
}
return ;
}
sub tests_permanentflags
{
note( 'Entering tests_permanentflags()' ) ;
my $mysync = { } ;
ok( q{} eq permanentflags( $mysync, ' * OK [PERMANENTFLAGS (\* \Draft \Answered)] Limited' ),
'permanentflags \*' ) ;
ok( '\Draft \Answered' eq permanentflags( $mysync, ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited' ),
'permanentflags \Draft \Answered' ) ;
ok( '\Draft \Answered'
eq permanentflags( $mysync, 'Blabla',
' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited',
'Blabla' ),
'permanentflags \Draft \Answered'
) ;
ok( q{} eq permanentflags( $mysync, 'Blabla' ), 'permanentflags nothing' ) ;
note( 'Leaving tests_permanentflags()' ) ;
return ;
}
sub permanentflags
{
my $mysync = shift @ARG ;
my @lines = @ARG ;
foreach my $line ( @lines ) {
if ( $line =~ m{\[PERMANENTFLAGS\s\(([^)]+?)\)\]}x ) {
( $mysync->{ debugflags } or $mysync->{ debug } ) and myprint( "permanentflags: $line" ) ;
my $permanentflags = $1 ;
if ( $permanentflags =~ m{\\\*}x )
{
$permanentflags = q{} ;
}
return( $permanentflags ) ;
} ;
}
return( q{} ) ;
}
sub tests_flags_filter
{
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 = 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 ;
return( $flags_out ) ;
}
sub tests_flagscase
{
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( '\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 flagscase
{
my $flags = shift @ARG ;
my @flags = split /\s+/x, $flags ;
my %rfc_flags = map { $_ => 1 } split q{ }, '\Answered \Flagged \Deleted \Seen \Draft' ;
my @flags_out = map { exists $rfc_flags{ ucsecond( lc $_ ) } ? ucsecond( lc $_ ) : $_ } @flags ;
my $flags_out = join q{ }, @flags_out ;
return( $flags_out ) ;
}
sub tests_flags_for_host2
{
note( 'Entering tests_flags_for_host2()' ) ;
is( undef, flags_for_host2( ), 'flags_for_host2: no args => undef' ) ;
my $mysync ;
is( undef, flags_for_host2( $mysync ), 'flags_for_host2: undef => undef' ) ;
$mysync = { } ;
is( undef, flags_for_host2( $mysync ), 'flags_for_host2: nothing => undef' ) ;
is( q{}, flags_for_host2( $mysync, '' ), 'flags_for_host2: no flags => empty string' ) ;
is( q{}, flags_for_host2( $mysync, '\Recent' ), 'flags_for_host2: \Recent => empty string' ) ;
is( q{\Seen}, flags_for_host2( $mysync, '\Recent \Seen' ), 'flags_for_host2: \Recent \Seen => \Seen' ) ;
is( q{\Deleted \Seen}, flags_for_host2( $mysync, '\Deleted \Recent \Seen' ), 'flags_for_host2: \Deleted \Recent \Seen => \Deleted \Seen' ) ;
$mysync->{ flagscase } = 0 ;
is( q{\DELETED \Seen}, flags_for_host2( $mysync, '\DELETED \Seen' ), 'flags_for_host2: flagscase = 0 \DELETED \Seen => \DELETED \Seen' ) ;
$mysync->{ flagscase } = 1 ;
is( q{\Deleted \Seen}, flags_for_host2( $mysync, '\DELETED \Seen' ), 'flags_for_host2: flagscase = 1 \DELETED \Seen => \Deleted \Seen' ) ;
$mysync->{ filterflags } = 0 ;
is( q{\Seen \Blabla}, flags_for_host2( $mysync, '\Seen \Blabla', '\Seen \Junk' ), 'flags_for_host2: filterflags = 0 \Seen \Blabla among \Seen \Junk => \Seen \Blabla' ) ;
$mysync->{ filterflags } = 1 ;
is( q{\Seen}, flags_for_host2( $mysync, '\Seen \Blabla', '\Seen \Junk' ), 'flags_for_host2: filterflags = 1 \Seen \Blabla among \Seen \Junk => \Seen' ) ;
$mysync->{ filterflags } = 1 ;
is( q{\Seen \Blabla}, flags_for_host2( $mysync, '\Seen \Blabla', '' ), 'flags_for_host2: filterflags = 1 \Seen \Blabla among "" => \Seen \Blabla' ) ;
note( 'Leaving tests_flags_for_host2()' ) ;
return ;
}
sub flags_for_host2
{
my $mysync = shift @ARG ;
my $h1_flags = shift @ARG ;
my $permanentflags2 = shift @ARG ;
if ( ! all_defined( $mysync, $h1_flags ) ) { return ; } ;
# RFC 2060: This flag can not be altered by any client
$h1_flags =~ s@\\Recent\s?@@xgi ;
my $h1_flags_re ;
if ( $mysync->{ regexflag } and defined( $h1_flags_re = regexflags( $mysync, $h1_flags ) ) ) {
$h1_flags = $h1_flags_re ;
}
if ( $mysync->{ flagscase } )
{
$h1_flags = flagscase( $h1_flags ) ;
}
if ( $permanentflags2 and $mysync->{ filterflags } )
{
$h1_flags = flags_filter( $h1_flags, $permanentflags2 ) ;
}
return( $h1_flags ) ;
}
sub ucsecond
{
my $string = shift @ARG ;
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 ) ;
}
sub tests_ucsecond
{
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, $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 ) ;
}
sub select_msgs_by_search
{
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 $sync->{ usecache } )
or ( not defined $maxage and not defined $minage and not defined $search_cmd )
) {
$debugdev and myprint( "Calling messages()\n" ) ;
@msgs_all = $imap->messages( ) ;
return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ;
if ( defined $msgs_all_hash_ref ) {
@{ $msgs_all_hash_ref }{ @msgs_all } = () ;
}
# return all messages
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 ) ;
return( @msgs ) ;
}
# we are here only if $maxage or $minage is defined
@msgs = select_msgs_by_age( $imap ) ;
return( @msgs );
}
sub select_msgs_by_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.
# Need all messages list to avoid deleting useful cache part
# in case of --search or --minage or --maxage
$debugdev and myprint( "Calling fetch_hash()\n" ) ;
my $fetch_hash_uids = $fetch_hash_set || "1:*" ;
%fetch = %{$imap->fetch_hash( $fetch_hash_uids, 'INTERNALDATE' ) } ;
@msgs_all = sort { $a <=> $b } keys %fetch ;
$debugdev and myprint( "Done fetch_hash()\n" ) ;
return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ;
if ( defined $msgs_all_hash_ref ) {
@{ $msgs_all_hash_ref }{ @msgs_all } = () ;
}
# return all messages
if ( not defined $maxage and not defined $minage and not defined $search_cmd ) {
return( @msgs_all ) ;
}
if ( defined $search_cmd ) {
myprint( "Warning: strange to see --search with --noabletosearch, an error can happen\n" ) ;
@msgs = $imap->search( $search_cmd ) ;
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 ;
}
}
@msgs = msgs_from_maxmin( \@max, \@min ) ;
return( @msgs ) ;
}
sub select_msgs_by_age
{
my( $imap ) = @_ ;
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 ) ;
}
@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: {
if ( not ( defined $minage or defined $maxage ) )
{
return ;
}
unless( defined $minage ) { @msgs = @max ; last SWITCH } ;
unless( defined $maxage ) { @msgs = @min ; last SWITCH } ;
my ( %union, %inter ) ;
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 ) ;
}
sub tests_msgs_from_maxmin
{
note( 'Entering tests_msgs_from_maxmin()' ) ;
my @msgs ;
# no maxage nor minage
@msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
is_deeply( [ ], \@msgs , 'msgs_from_maxmin: no maxage nor minage => empty result' ) ;
# maxage alone
$maxage = $NUMBER_200 ;
@msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
is_deeply( [ '1', '2' ], \@msgs , 'msgs_from_maxmin: maxage++' ) ;
# maxage > minage -> intersection
$minage = $NUMBER_100 ;
@msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
is_deeply( [ '2' ], \@msgs , 'msgs_from_maxmin: -maxage++minage-' ) ;
# maxage < minage -> union
$minage = $NUMBER_300 ;
@msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
is_deeply( [ '1', '2', '3' ], \@msgs, 'msgs_from_maxmin: ++maxage-minage++' ) ;
# minage alone
$maxage = undef ;
@msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
is_deeply( [ '2', '3' ], \@msgs, 'msgs_from_maxmin: ++minage-' ) ;
note( 'Leaving tests_msgs_from_maxmin()' ) ;
return ;
}
sub tests_info_date_from_uid
{
note( 'Entering tests_info_date_from_uid()' ) ;
note( 'Leaving tests_info_date_from_uid()' ) ;
return ;
}
sub info_date_from_uid
{
#my $first_uid = $msgs_all[ 0 ] ;
#my $first_idate = $fetch{ $first_uid }->{'INTERNALDATE'} ;
#my $first_epoch = epoch( $first_idate ) ;
#my $first_days = ( $timestart_int - $first_epoch ) / $NB_SECONDS_IN_A_DAY ;
#myprint( "\nOldest msg has UID $first_uid INTERNALDATE $first_idate EPOCH $first_epoch DAYS AGO $first_days\n" ) ;
}
sub lastuid
{
my $imap = shift @ARG ;
my $folder = shift @ARG ;
my $lastuid_guess = shift @ARG ;
my $lastuid ;
# rfc3501: The only reliable way to identify recent messages is to
# 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 ) = @_ ;
$h1_size = 0 if ( ! $h1_size ) ; # null if empty or undef
if ( defined $sync->{ maxsize } and $h1_size > $sync->{ maxsize } ) {
myprint( "msg $h1_fold/$h1_msg skipped ($h1_size exceeds maxsize limit $sync->{ maxsize } bytes)\n" ) ;
$sync->{ total_bytes_skipped } += $h1_size;
$sync->{ nb_msg_skipped } += 1;
return( 1 ) ;
}
if ( defined $minsize and $h1_size <= $minsize ) {
myprint( "msg $h1_fold/$h1_msg skipped ($h1_size smaller than minsize $minsize bytes)\n" ) ;
$sync->{ total_bytes_skipped } += $h1_size;
$sync->{ nb_msg_skipped } += 1;
return( 1 ) ;
}
return( 0 ) ;
}
sub message_exists
{
my( $imap, $msg ) = @_ ;
return( 1 ) if not $imap->Uid( ) ;
my $search_uid ;
( $search_uid ) = $imap->search( "UID $msg" ) ;
#myprint( "$search ? $msg\n" ) ;
return( 1 ) if ( $search_uid eq $msg ) ;
return( 0 ) ;
}
# Globals
# $sync->{ total_bytes_skipped }
# $sync->{ nb_msg_skipped }
# $mysync->{ h1_nb_msg_processed }
sub stats_update_skip_message
{
my $mysync = shift @ARG ; # to be used
my $h1_size = shift @ARG ;
$mysync->{ total_bytes_skipped } += $h1_size ;
$mysync->{ nb_msg_skipped } += 1 ;
$mysync->{ h1_nb_msg_processed } +=1 ;
return ;
}
sub copy_message
{
# copy
my ( $mysync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $cache_dir ) = @_ ;
( $mysync->{ debug } or $mysync->{dry} )
and myprint( "msg $h1_fold/$h1_msg copying to $h2_fold $mysync->{dry_message} " . eta( $mysync ) . "\n" ) ;
if ( $mysync->{dry1} )
{
$mysync->{ h1_nb_msg_processed } +=1 ;
$nb_msg_skipped_dry_mode += 1 ;
return ;
}
my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} || 0 ;
my $h1_flags = $h1_fir_ref->{$h1_msg}->{'FLAGS'} || q{} ;
my $h1_idate = $h1_fir_ref->{$h1_msg}->{'INTERNALDATE'} || q{} ;
if ( size_filtered( $h1_size, $h1_msg, $h1_fold, $h2_fold ) ) {
$mysync->{ h1_nb_msg_processed } +=1 ;
return ;
}
debugsleep( $mysync ) ;
myprint( "- msg $h1_fold/$h1_msg S[$h1_size] F[$h1_flags] I[$h1_idate] has RFC822.SIZE null!\n" ) if ( ! $h1_size ) ;
if ( $checkmessageexists and not message_exists( $mysync->{imap1}, $h1_msg ) ) {
stats_update_skip_message( $mysync, $h1_size ) ;
return ;
}
myprint( debugmemory( $mysync, " at C1" ) ) ;
my ( $string, $string_len ) ;
( $string_len ) = message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, \$string ) ;
myprint( debugmemory( $mysync, " at C2" ) ) ;
# not defined or empty $string
if ( ( not $string ) or ( not $string_len ) ) {
myprint( "- msg $h1_fold/$h1_msg skipped.\n" ) ;
stats_update_skip_message( $mysync, $h1_size ) ;
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 ) {
stats_update_skip_message( $mysync, $h1_size ) ;
return ;
}
}
my $h1_date = date_for_host2( $h1_msg, $h1_idate ) ;
( $mysync->{ debug } or $mysync->{ debugflags } ) and
myprint( "Host1: flags init msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ;
$h1_flags = flags_for_host2( $mysync, $h1_flags, $mysync->{ permanentflags2 } ) ;
( $mysync->{ debug } or $mysync->{ debugflags } ) and
myprint( "Host1: flags filt msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ;
$h1_date = undef if ( $h1_date eq q{} ) ;
my $new_id = append_message_on_host2( $mysync, \$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( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $new_id ) ;
}
myprint( debugmemory( $mysync, " at C3" ) ) ;
return $new_id ;
}
sub linelengthstuff
{
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 ;
}
if ( ( defined $maxlinelength ) and ( $maxlinelength_string > $maxlinelength ) ) {
my $subject = subject( $string ) ;
if ( $maxlinelengthcmd ) {
$string = pipemess( $string, $maxlinelengthcmd ) ;
# string undef means something was bad.
if ( not ( defined $string ) ) {
myprint( "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] "
. "(Subject:[$subject]) could not be successfully transformed by --maxlinelengthcmd option\n" ) ;
return ;
}else{
return $string ;
}
}
myprint( "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] "
. "(Subject:[$subject]) (line length exceeds maxlinelength $maxlinelength bytes)\n" ) ;
return ;
}
return $string ;
}
sub message_for_host2
{
# global variable list:
# @skipmess
# @regexmess
# @pipemess
# $debugcontent
# $debug
#
# API current
#
# at failure:
# * return nothing ( will then be undef or () )
# * $string_ref content is undef or empty
# at success:
# * return string length ($string_ref content length)
# * $string_ref content filled with message
# API future
#
#
my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) = @_ ;
# abort when missing a parameter
if ( ( ! $mysync ) or ( ! $h1_msg ) or ( ! $h1_fold ) or ( ! defined $h1_size )
or ( ! defined $h1_flags) or ( ! defined $h1_idate )
or ( ! $h1_fir_ref) or ( ! $string_ref ) )
{
return ;
}
myprint( debugmemory( $mysync, " at M1" ) ) ;
my $string_ok = $mysync->{imap1}->message_to_file( $string_ref, $h1_msg ) ;
myprint( debugmemory( $mysync, " at M2" ) ) ;
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: ",
$mysync->{imap1}->LastError || q{}, "\n" ;
errors_incr( $mysync, $error ) ;
$mysync->{ h1_nb_msg_processed } +=1 ;
return ;
}
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]"
. " could not be skipped by --skipmess option, bad regex\n" ) ;
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 ;
}
}
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]"
. " could not be transformed by --regexmess\n" ) ;
return ;
}
}
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]"
. " could not be successfully transformed by --pipemess option\n" ) ;
return ;
}
}
if ( $mysync->{addheader} and defined $h1_fir_ref->{$h1_msg}->{'NO_HEADER'} ) {
my $header = add_header( $h1_msg ) ;
$mysync->{ debug } and myprint( "msg $h1_fold/$h1_msg adding custom header [$header]\n" ) ;
${ $string_ref } = $header . "\r\n" . ${ $string_ref } ;
}
if ( ( defined $mysync->{ truncmess } ) and is_integer( $mysync->{ truncmess } ) )
{
${ $string_ref } = truncmess( ${ $string_ref }, $mysync->{ truncmess } ) ;
}
$string_len = length_ref( $string_ref ) ;
$mysync->{ debugcontent } and myprint( debugcontent( $mysync, $string_ref ) ) ;
myprint( debugmemory( $mysync, " at M3" ) ) ;
return $string_len ;
}
sub tests_debugcontent
{
note( 'Entering tests_debugcontent()' ) ;
is( undef, debugcontent( ), 'debugcontent: no args => undef' ) ;
my $mysync = { } ;
is( undef, debugcontent( $mysync ), 'debugcontent: undef => undef' ) ;
is( undef, debugcontent( $mysync, 'mm' ), 'debugcontent: undef, mm => undef' ) ;
#my $string_ref = \'zztop' ;
my $string = '================================================================================
F message content begin next line (2 characters long)
mm
F message content ended on previous line
================================================================================
' ;
is( $string, debugcontent( $mysync, \'mm' ), 'debugcontent: undef, mm => mm' ) ;
note( 'Leaving tests_debugcontent()' ) ;
return ;
}
sub debugcontent
{
my $mysync = shift @ARG ;
if ( ! defined $mysync ) { return ; }
my $string_ref = shift @ARG ;
if ( ! defined $string_ref ) { return ; }
if ( 'SCALAR' ne ref( $string_ref ) ) { return ; }
my $string_len = length_ref( $string_ref ) ;
my $string = join( '',
q{=} x $STD_CHAR_PER_LINE, "\n",
"F message content begin next line ($string_len characters long)\n",
${ $string_ref },
"\nF message content ended on previous line\n", q{=} x $STD_CHAR_PER_LINE, "\n",
) ;
return $string ;
}
sub tests_truncmess
{
note( 'Entering tests_truncmess()' ) ;
is( undef, truncmess( ), 'truncmess: no args => undef' ) ;
is( 'abc', truncmess( 'abc' ), 'truncmess: abc => abc' ) ;
is( 'ab', truncmess( 'abc', 2 ), 'truncmess: abc 2 => ab' ) ;
is( 'abc', truncmess( 'abc', 3 ), 'truncmess: abc 3 => abc' ) ;
is( 'abc', truncmess( 'abc', 4 ), 'truncmess: abc 4 => abc' ) ;
is( '12345', truncmess( "123456789\n", 5 ), 'truncmess: "123456789\n", 5 => 12345' ) ;
is( "123456789\n" x 5000, truncmess( "123456789\n" x 100000, 50000 ), 'truncmess: "123456789\n" x 100000, 50000 => "123456789\n" x 5000' ) ;
note( 'Leaving tests_truncmess()' ) ;
return ;
}
sub truncmess
{
my $string = shift @ARG ;
my $length = shift @ARG ;
if ( not defined $string ) { return ; }
if ( not defined $length ) { return $string ; }
$string = substr $string, 0, $length ;
return $string ;
}
sub tests_message_for_host2
{
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( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), q{message_for_host2: undef args} ) ;
require_ok( "Test::MockObject" ) ;
my $imapT = Test::MockObject->new( ) ;
$mysync->{imap1} = $imapT ;
my $string ;
$h1_msg = 1 ;
$h1_fold = 'FoldFoo';
$h1_size = 9 ;
$h1_flags = q{} ;
$h1_idate = '10-Jul-2015 09:00:00 +0200' ;
$h1_fir_ref = {} ;
$string_ref = \$string ;
$imapT->mock( 'message_to_file',
sub {
my ( $imap, $mystring_ref, $msg ) = @_ ;
${$mystring_ref} = 'blablabla' ;
return length ${$mystring_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: {
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: {
Readonly my $NB_UNX_tests_message_for_host2 => 6 ;
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( $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( $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( $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} ) ;
}
undef @pipemess ;
note( 'Leaving tests_message_for_host2()' ) ;
return ;
}
sub tests_labels_remove_subfolder1
{
note( 'Entering tests_labels_remove_subfolder1()' ) ;
is( undef, labels_remove_subfolder1( ), 'labels_remove_subfolder1: no parameters => undef' ) ;
is( 'Blabla', labels_remove_subfolder1( 'Blabla' ), 'labels_remove_subfolder1: one parameter Blabla => Blabla' ) ;
is( 'Blan blue', labels_remove_subfolder1( 'Blan blue' ), 'labels_remove_subfolder1: one parameter Blan blue => Blan blue' ) ;
is( '\Bla "Blan blan" Blabla', labels_remove_subfolder1( '\Bla "Blan blan" Blabla' ),
'labels_remove_subfolder1: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ;
is( 'Bla', labels_remove_subfolder1( 'Subf/Bla', 'Subf' ), 'labels_remove_subfolder1: Subf/Bla Subf => "Bla"' ) ;
is( '"\\\\Bla"', labels_remove_subfolder1( '"\\\\Bla"', 'Subf' ), 'labels_remove_subfolder1: "\\\\Bla" Subf => "\\\\Bla"' ) ;
is( 'Bla Kii', labels_remove_subfolder1( 'Subf/Bla Subf/Kii', 'Subf' ),
'labels_remove_subfolder1: Subf/Bla Subf/Kii, Subf => "Bla" "Kii"' ) ;
is( '"\\\\Bla" Kii', labels_remove_subfolder1( '"\\\\Bla" Subf/Kii', 'Subf' ),
'labels_remove_subfolder1: "\\\\Bla" Subf/Kii Subf => "\\\\Bla" Kii' ) ;
is( '"Blan blan"', labels_remove_subfolder1( '"Subf/Blan blan"', 'Subf' ),
'labels_remove_subfolder1: "Subf/Blan blan" Subf => "Blan blan"' ) ;
is( '"\\\\Loo" "Blan blan" Kii', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii', 'Subf' ),
'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii + Subf => "\\\\Loo" "Blan blan" Kii' ) ;
is( '"\\\\Inbox"', labels_remove_subfolder1( 'Subf/INBOX', 'Subf' ),
'labels_remove_subfolder1: Subf/INBOX + Subf => "\\\\Inbox"' ) ;
is( '"\\\\Loo" "Blan blan" Kii "\\\\Inbox"', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX', 'Subf' ),
'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX + Subf => "\\\\Loo" "Blan blan" Kii "\\\\Inbox"' ) ;
note( 'Leaving tests_labels_remove_subfolder1()' ) ;
return ;
}
sub labels_remove_subfolder1
{
my $labels = shift @ARG ;
my $subfolder1 = shift @ARG ;
if ( not defined $labels ) { return ; }
if ( not defined $subfolder1 ) { return $labels ; }
my @labels = quotewords('\s+', 1, $labels ) ;
#myprint( "@labels\n" ) ;
my @labels_subfolder2 ;
foreach my $label ( @labels )
{
if ( $label =~ m{zzzzzzzzzz} )
{
# \Seen \Deleted ... stay the same
push @labels_subfolder2, $label ;
}
else
{
# Remove surrounding quotes if any, to add them again in case of space
$label = join( q{}, quotewords('\s+', 0, $label ) ) ;
$label =~ s{$subfolder1/?}{} ;
if ( 'INBOX' eq $label )
{
push @labels_subfolder2, q{"\\\\Inbox"} ;
}
elsif ( $label =~ m{\\} )
{
push @labels_subfolder2, qq{"\\$label"} ;
}
elsif ( $label =~ m{ } )
{
push @labels_subfolder2, qq{"$label"} ;
}
else
{
push @labels_subfolder2, $label ;
}
}
}
my $labels_subfolder2 = join( ' ', sort uniq( @labels_subfolder2 ) ) ;
return $labels_subfolder2 ;
}
sub tests_labels_remove_special
{
note( 'Entering tests_labels_remove_special()' ) ;
is( undef, labels_remove_special( ), 'labels_remove_special: no parameters => undef' ) ;
is( q{}, labels_remove_special( q{} ), 'labels_remove_special: empty string => empty string' ) ;
is( q{}, labels_remove_special( '"\\\\Inbox"' ), 'labels_remove_special:"\\\\Inbox" => empty string' ) ;
is( q{}, labels_remove_special( '"\\\\Inbox" "\\\\Starred"' ), 'labels_remove_special:"\\\\Inbox" "\\\\Starred" => empty string' ) ;
is( 'Bar Foo', labels_remove_special( 'Foo Bar' ), 'labels_remove_special:Foo Bar => Bar Foo' ) ;
is( 'Bar Foo', labels_remove_special( 'Foo Bar "\\\\Inbox"' ), 'labels_remove_special:Foo Bar "\\\\Inbox" => Bar Foo' ) ;
note( 'Leaving tests_labels_remove_special()' ) ;
return ;
}
sub labels_remove_special
{
my $labels = shift @ARG ;
if ( not defined $labels ) { return ; }
my @labels = quotewords('\s+', 1, $labels ) ;
myprint( "labels before remove_non_folded: @labels\n" ) ;
my @labels_remove_special ;
foreach my $label ( @labels )
{
if ( $label =~ m{^\"\\\\} )
{
# not kept
}
else
{
push @labels_remove_special, $label ;
}
}
my $labels_remove_special = join( ' ', sort @labels_remove_special ) ;
return $labels_remove_special ;
}
sub tests_labels_add_subfolder2
{
note( 'Entering tests_labels_add_subfolder2()' ) ;
is( undef, labels_add_subfolder2( ), 'labels_add_subfolder2: no parameters => undef' ) ;
is( 'Blabla', labels_add_subfolder2( 'Blabla' ), 'labels_add_subfolder2: one parameter Blabla => Blabla' ) ;
is( 'Blan blue', labels_add_subfolder2( 'Blan blue' ), 'labels_add_subfolder2: one parameter Blan blue => Blan blue' ) ;
is( '\Bla "Blan blan" Blabla', labels_add_subfolder2( '\Bla "Blan blan" Blabla' ),
'labels_add_subfolder2: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ;
is( 'Subf/Bla', labels_add_subfolder2( 'Bla', 'Subf' ), 'labels_add_subfolder2: Bla Subf => "Subf/Bla"' ) ;
is( 'Subf/\Bla', labels_add_subfolder2( '\\\\Bla', 'Subf' ), 'labels_add_subfolder2: \Bla Subf => \Bla' ) ;
is( 'Subf/Bla Subf/Kii', labels_add_subfolder2( 'Bla Kii', 'Subf' ),
'labels_add_subfolder2: Bla Kii Subf => "Subf/Bla" "Subf/Kii"' ) ;
is( 'Subf/Kii Subf/\Bla', labels_add_subfolder2( '\\\\Bla Kii', 'Subf' ),
'labels_add_subfolder2: \Bla Kii Subf => \Bla Subf/Kii' ) ;
is( '"Subf/Blan blan"', labels_add_subfolder2( '"Blan blan"', 'Subf' ),
'labels_add_subfolder2: "Blan blan" Subf => "Subf/Blan blan"' ) ;
is( '"Subf/Blan blan" Subf/Kii Subf/\Loo', labels_add_subfolder2( '\\\\Loo "Blan blan" Kii', 'Subf' ),
'labels_add_subfolder2: \Loo "Blan blan" Kii + Subf => "Subf/Blan blan" Subf/Kii Subf/\Loo' ) ;
# "\\Inbox" is special, add to subfolder INBOX also because Gmail will but ...
is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox"', 'Subf' ),
'labels_add_subfolder2: "\\\\Inbox" Subf => "Subf/\\\\Inbox" Subf/INBOX' ) ;
# but not with INBOX folder
is( '"Subf/\\\\Inbox"', labels_add_subfolder2( '"\\\\Inbox"', 'Subf', 'INBOX' ),
'labels_add_subfolder2: "\\\\Inbox" Subf INBOX => "Subf/\\\\Inbox"' ) ;
# two times => one time
is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox" "\\\\Inbox"', 'Subf' ),
'labels_add_subfolder2: "\\\\Inbox" "\\\\Inbox" Subf => "Subf/\\\\Inbox"' ) ;
is( '"Subf/\\\\Starred"', labels_add_subfolder2( '"\\\\Starred"', 'Subf' ),
'labels_add_subfolder2: "\\\\Starred" Subf => "Subf/\\\\Starred"' ) ;
note( 'Leaving tests_labels_add_subfolder2()' ) ;
return ;
}
sub labels_add_subfolder2
{
my $labels = shift @ARG ;
my $subfolder2 = shift @ARG ;
my $h1_folder = shift || q{} ;
if ( not defined $labels ) { return ; }
if ( not defined $subfolder2 ) { return $labels ; }
# Isn't it messy?
if ( 'INBOX' eq $h1_folder )
{
$labels .= ' "\\\\Inbox"' ;
}
my @labels = uniq( quotewords('\s+', 1, $labels ) ) ;
myprint( "labels before subfolder2: @labels\n" ) ;
my @labels_subfolder2 ;
foreach my $label ( @labels )
{
# Isn't it more messy?
if ( ( q{"\\\\Inbox"} eq $label ) and ( 'INBOX' ne $h1_folder ) )
{
if ( $subfolder2 =~ m{ } )
{
push @labels_subfolder2, qq{"$subfolder2/INBOX"} ;
}
else
{
push @labels_subfolder2, "$subfolder2/INBOX" ;
}
}
if ( $label =~ m{^\"\\\\} )
{
# \Seen \Deleted ... stay the same
#push @labels_subfolder2, $label ;
# Remove surrounding quotes if any, to add them again
$label = join( q{}, quotewords('\s+', 0, $label ) ) ;
push @labels_subfolder2, qq{"$subfolder2/\\$label"} ;
}
else
{
# Remove surrounding quotes if any, to add them again in case of space
$label = join( q{}, quotewords('\s+', 0, $label ) ) ;
if ( $label =~ m{ } )
{
push @labels_subfolder2, qq{"$subfolder2/$label"} ;
}
else
{
push @labels_subfolder2, "$subfolder2/$label" ;
}
}
}
my $labels_subfolder2 = join( ' ', sort @labels_subfolder2 ) ;
return $labels_subfolder2 ;
}
sub tests_labels
{
note( 'Entering tests_labels()' ) ;
is( undef, labels( ), 'labels: no parameters => undef' ) ;
is( undef, labels( undef ), 'labels: undef => undef' ) ;
require_ok( "Test::MockObject" ) ;
my $myimap = Test::MockObject->new( ) ;
$myimap->mock( 'fetch_hash',
sub {
return(
{ '1' => {
'X-GM-LABELS' => '\Seen Blabla'
}
}
) ;
}
) ;
$myimap->mock( 'Debug' , sub { } ) ;
$myimap->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one
is( undef, labels( $myimap ), 'labels: one parameter => undef' ) ;
is( '\Seen Blabla', labels( $myimap, '1' ), 'labels: $mysync UID_1 => \Seen Blabla' ) ;
note( 'Leaving tests_labels()' ) ;
return ;
}
sub labels
{
my ( $myimap, $uid ) = @ARG ;
if ( not all_defined( $myimap, $uid ) ) {
return ;
}
my $hash = $myimap->fetch_hash( [ $uid ], 'X-GM-LABELS' ) ;
my $labels = $hash->{ $uid }->{ 'X-GM-LABELS' } ;
#$labels = $myimap->Unescape( $labels ) ;
return $labels ;
}
sub tests_synclabels
{
note( 'Entering tests_synclabels()' ) ;
is( undef, synclabels( ), 'synclabels: no parameters => undef' ) ;
is( undef, synclabels( undef ), 'synclabels: undef => undef' ) ;
my $mysync ;
is( undef, synclabels( $mysync ), 'synclabels: var undef => undef' ) ;
require_ok( "Test::MockObject" ) ;
$mysync = {} ;
my $myimap1 = Test::MockObject->new( ) ;
$myimap1->mock( 'fetch_hash',
sub {
return(
{ '1' => {
'X-GM-LABELS' => '\Seen Blabla'
}
}
) ;
}
) ;
$myimap1->mock( 'Debug', sub { } ) ;
$myimap1->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one
my $myimap2 = Test::MockObject->new( ) ;
$myimap2->mock( 'store',
sub {
return 1 ;
}
) ;
$mysync->{imap1} = $myimap1 ;
$mysync->{imap2} = $myimap2 ;
is( undef, synclabels( $mysync ), 'synclabels: fresh $mysync => undef' ) ;
is( undef, synclabels( $mysync, '1' ), 'synclabels: $mysync UID_1 alone => undef' ) ;
is( 1, synclabels( $mysync, '1', '2' ), 'synclabels: $mysync UID_1 UID_2 => 1' ) ;
note( 'Leaving tests_synclabels()' ) ;
return ;
}
sub synclabels
{
my( $mysync, $uid1, $uid2 ) = @ARG ;
if ( not all_defined( $mysync, $uid1, $uid2 ) ) {
return ;
}
my $myimap1 = $mysync->{ 'imap1' } || return ;
my $myimap2 = $mysync->{ 'imap2' } || return ;
$mysync->{debuglabels} and $myimap1->Debug( 1 ) ;
my $labels1 = labels( $myimap1, $uid1 ) ;
$mysync->{debuglabels} and $myimap1->Debug( 0 ) ;
$mysync->{debuglabels} and myprint( "Host1 labels: $labels1\n" ) ;
if ( $mysync->{ subfolder1 } and $labels1 )
{
$labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ;
$mysync->{debuglabels} and myprint( "Host1 labels with subfolder1: $labels1\n" ) ;
}
if ( $mysync->{ subfolder2 } and $labels1 )
{
$labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 } ) ;
$mysync->{debuglabels} and myprint( "Host1 labels with subfolder2: $labels1\n" ) ;
}
my $store ;
if ( $labels1 and not $mysync->{ dry } )
{
$mysync->{ debuglabels } and $myimap2->Debug( 1 ) ;
$store = $myimap2->store( $uid2, "X-GM-LABELS ($labels1)" ) ;
$mysync->{ debuglabels } and $myimap2->Debug( 0 ) ;
}
return $store ;
}
sub tests_resynclabels
{
note( 'Entering tests_resynclabels()' ) ;
is( undef, resynclabels( ), 'resynclabels: no parameters => undef' ) ;
is( undef, resynclabels( undef ), 'resynclabels: undef => undef' ) ;
my $mysync ;
is( undef, resynclabels( $mysync ), 'resynclabels: var undef => undef' ) ;
my ( $h1_fir_ref, $h2_fir_ref ) ;
$mysync->{ debuglabels } = 1 ;
$h1_fir_ref->{ 11 }->{ 'X-GM-LABELS' } = '\Seen Baa Kii' ;
$h2_fir_ref->{ 22 }->{ 'X-GM-LABELS' } = '\Seen Baa Kii' ;
# labels are equal
is( 1, resynclabels( $mysync, 11, 22, $h1_fir_ref, $h2_fir_ref ),
'resynclabels: $mysync UID_1 UID_2 labels are equal => 1' ) ;
# labels are different
$h2_fir_ref->{ 22 }->{ 'X-GM-LABELS' } = '\Seen Zuu' ;
require_ok( "Test::MockObject" ) ;
my $myimap2 = Test::MockObject->new( ) ;
$myimap2->mock( 'store',
sub {
return 1 ;
}
) ;
$myimap2->mock( 'Debug', sub { } ) ;
$mysync->{imap2} = $myimap2 ;
is( 1, resynclabels( $mysync, 11, 22, $h1_fir_ref, $h2_fir_ref ),
'resynclabels: $mysync UID_1 UID_2 labels are not equal => store => 1' ) ;
note( 'Leaving tests_resynclabels()' ) ;
return ;
}
sub resynclabels
{
my( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref, $h1_folder ) = @ARG ;
if ( not all_defined( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref ) ) {
return ;
}
my $labels1 = $h1_fir_ref->{ $uid1 }->{ 'X-GM-LABELS' } || q{} ;
my $labels2 = $h2_fir_ref->{ $uid2 }->{ 'X-GM-LABELS' } || q{} ;
if ( $mysync->{ subfolder1 } and $labels1 )
{
$labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ;
}
if ( $mysync->{ subfolder2 } and $labels1 )
{
$labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 }, $h1_folder ) ;
$labels2 = labels_remove_special( $labels2 ) ;
}
$mysync->{ debuglabels } and myprint( "Host1 labels fixed: $labels1\n" ) ;
$mysync->{ debuglabels } and myprint( "Host2 labels : $labels2\n" ) ;
my $store ;
if ( $labels1 eq $labels2 )
{
# no sync needed
$mysync->{ debuglabels } and myprint( "Labels are already equal\n" ) ;
return 1 ;
}
elsif ( not $mysync->{ dry } )
{
# sync needed
$mysync->{debuglabels} and $mysync->{imap2}->Debug( 1 ) ;
$store = $mysync->{imap2}->store( $uid2, "X-GM-LABELS ($labels1)" ) ;
$mysync->{debuglabels} and $mysync->{imap2}->Debug( 0 ) ;
}
return $store ;
}
sub tests_uniq
{
note( 'Entering tests_uniq()' ) ;
is( 0, uniq( ), 'uniq: undef => 0' ) ;
is_deeply( [ 'one' ], [ uniq( 'one' ) ], 'uniq: one => one' ) ;
is_deeply( [ 'one' ], [ uniq( 'one', 'one' ) ], 'uniq: one one => one' ) ;
is_deeply( [ 'one', 'two' ], [ uniq( 'one', 'one', 'two', 'one', 'two' ) ], 'uniq: one one two one two => one two' ) ;
note( 'Leaving tests_uniq()' ) ;
return ;
}
sub uniq
{
my @list = @ARG ;
my %seen = ( ) ;
my @uniq = ( ) ;
foreach my $item ( @list ) {
if ( ! $seen{ $item } ) {
$seen{ $item } = 1 ;
push( @uniq, $item ) ;
}
}
return @uniq ;
}
sub length_ref
{
my $string_ref = shift @ARG ;
my $string_len = defined ${ $string_ref } ? length( ${ $string_ref } ) : q{} ; # length or empty string
return $string_len ;
}
sub tests_length_ref
{
note( 'Entering tests_length_ref()' ) ;
my $notdefined ;
is( q{}, length_ref( \$notdefined ), q{length_ref: value not defined} ) ;
my $notref ;
is( q{}, length_ref( $notref ), q{length_ref: param not a 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_date = q{} ;
if ( $syncinternaldates ) {
$h1_date = $h1_idate ;
$sync->{ debug } and myprint( "internal date from host1: [$h1_date]\n" ) ;
$h1_date = good_date( $h1_date ) ;
$sync->{ debug } and myprint( "internal date from host1: [$h1_date] (fixed)\n" ) ;
}
if ( $idatefromheader ) {
$h1_date = $sync->{imap1}->get_header( $h1_msg, 'Date' ) ;
$sync->{ debug } and myprint( "header date from host1: [$h1_date]\n" ) ;
$h1_date = good_date( $h1_date ) ;
$sync->{ debug } and myprint( "header date from host1: [$h1_date] (fixed)\n" ) ;
}
return( $h1_date ) ;
}
sub subject
{
my $string = shift @ARG ;
my $subject = q{} ;
my $header = extract_header( $string ) ;
if( $header =~ m/^Subject:[ \t]*([^\n\r]*)\r?$/msx ) {
#myprint( "MMM[$1]\n" ) ;
$subject = $1 ;
}
return( $subject ) ;
}
sub tests_subject
{
note( 'Entering tests_subject()' ) ;
ok( q{} eq subject( q{} ), 'subject: null') ;
is( '', subject( 'Subject:' ), 'Subject:') ;
is( '', subject( "Subject:\r\n" ), 'Subject:\r\n') ;
ok( 'toto le hero' eq subject( 'Subject: toto le hero' ), 'Subject: toto le hero') ;
ok( 'toto le hero' eq subject( 'Subject:toto le hero' ), 'Subject:toto le hero') ;
ok( 'toto le hero' eq subject( "Subject:toto le hero\r\n" ), 'Subject: toto le hero\r\n') ;
my $MESS ;
$MESS = <<'EOF';
From: lalala
Subject: toto le hero
Date: zzzzzz
Boogie boogie
EOF
ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 2') ;
$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') ;
$MESS = <<'EOF';
From: lalala
Subject: cuicui
Date: zzzzzz
Subject: toto le hero
EOF
ok( 'cuicui' eq subject( $MESS ), 'subject: cuicui') ;
$MESS = <<'EOF';
From: lalala
Date: zzzzzz
Subject: toto le hero
EOF
ok( q{} eq subject( $MESS ), 'subject: null but body could') ;
$MESS = <<'EOF';
From: lalala
Subject:
Date: zzzzzz
Subject: toto le hero
EOF
is( '', subject( $MESS ), 'Subject:') ;
note( 'Leaving tests_subject()' ) ;
return ;
}
# GlobVar
# $h2_uidguess
# ...
#
#
sub append_message_on_host2
{
my( $mysync, $string_ref, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) = @_ ;
myprint( debugmemory( $mysync, " at A1" ) ) ;
my $new_id ;
if ( ! $mysync->{dry} ) {
$new_id = $mysync->{imap2}->append_string( $h2_fold, ${ $string_ref }, $h1_flags, $h1_date ) ;
myprint( debugmemory( $mysync, " at A2" ) ) ;
if ( ! defined $new_id ){
my $subject = subject( ${ $string_ref } ) ;
my $error_imap = $mysync->{imap2}->LastError || q{} ;
my $error = "- msg $h1_fold/$h1_msg {$string_len} could not append ( Subject:[$subject], Date:[$h1_date], Size:[$h1_size], Flags:[$h1_flags] ) to folder $h2_fold: $error_imap\n" ;
errors_incr( $mysync, $error ) ;
$mysync->{ 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( $mysync->{imap2}, $h2_fold, $h2_uidguess ) ;
}
if ( $mysync->{ synclabels } ) { synclabels( $mysync, $h1_msg, $new_id ) }
$h2_uidguess += 1 ;
$mysync->{ total_bytes_transferred } += $string_len ;
$mysync->{ nb_msg_transferred } += 1 ;
$mysync->{ h1_nb_msg_processed } +=1 ;
$mysync->{ biggest_message_transferred } = max( $string_len, $mysync->{ biggest_message_transferred } ) ;
my $time_spent = timesince( $mysync->{begin_transfer_time} ) ;
my $rate = bytes_display_string_bin( $mysync->{total_bytes_transferred} / $time_spent ) ;
my $eta = eta( $mysync ) ;
my $amount_transferred = bytes_display_string_bin( $mysync->{total_bytes_transferred} ) ;
myprintf( "msg %s/%-19s copied to %s/%-10s %.2f msgs/s %s/s %s copied %s\n",
$h1_fold, "$h1_msg {$string_len}", $h2_fold, $new_id, $mysync->{nb_msg_transferred}/$time_spent, $rate,
$amount_transferred,
$eta );
sleep_if_needed( $mysync ) ;
if ( $sync->{ 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" ) ;
}
if ( $mysync->{ delete1 } ) {
delete_message_on_host1( $mysync, $h1_fold, $mysync->{ expungeaftereach }, $h1_msg ) ;
}
#myprint( "PRESS ENTER" ) and my $a = <> ;
return( $new_id ) ;
}
}
else{
$nb_msg_skipped_dry_mode += 1 ;
$mysync->{ 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( $mysync ) = shift @ARG ;
if ( ! $mysync ) {
return ;
}
# No need to go further if there is no limit set
if (
not (
$mysync->{maxmessagespersecond}
or $mysync->{maxbytespersecond}
)
) {
return ;
}
$mysync->{maxsleep} = defined $mysync->{maxsleep} ? $mysync->{maxsleep} : $MAX_SLEEP ;
# Must be positive
$mysync->{maxsleep} = max( 0, $mysync->{maxsleep} ) ;
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 ) {
myprint( "sleeping $sleep_max s\n" ) ;
sleep $sleep_max ;
# Slept
return $sleep_max ;
}
# No sleep
return 0 ;
}
sub sleep_max_messages
{
# 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 ;
# the sleep must be positive
return( max( 0, $sleep ) ) ;
}
sub tests_sleep_max_messages
{
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_to_consider, $time_spent, $maxbytespersecond ) = @_ ;
$total_bytes_to_consider ||= 0 ;
$time_spent ||= 0 ;
if ( ( not defined $maxbytespersecond ) or $maxbytespersecond <= 0 ) { return( 0 ) } ;
#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
{
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 ;
}
sub delete_message_on_host1
{
my( $mysync, $h1_fold, $expunge, @h1_msg ) = @_ ;
if ( ! $mysync->{ delete1 } ) { return ; }
if ( ! @h1_msg ) { return ; }
delete_messages_on_any(
$mysync,
$mysync->{ acc1 },
$mysync->{ imap1 },
"Host1: $h1_fold",
$expunge,
$split1,
@h1_msg ) ;
return ;
}
sub tests_operators_and_exclam_precedence
{
note( 'Entering tests_operators_and_exclam_precedence()' ) ;
is( 1, ! 0, 'tests_operators_and_exclam_precedence: ! 0 => 1' ) ;
is( "", ! 1, 'tests_operators_and_exclam_precedence: ! 1 => ""' ) ;
is( 1, not( 0 ), 'tests_operators_and_exclam_precedence: not( 0 ) => 1' ) ;
is( "", not( 1 ), 'tests_operators_and_exclam_precedence: not( 1 ) => ""' ) ;
# I wrote those tests to avoid perlcrit "Mixed high and low-precedence booleans"
# and change sub delete_messages_on_any() but got 4 more warnings... So now commented.
#is( 0, ( ! 0 and 0 ), 'tests_operators_and_exclam_precedence: ! 0 and 0 ) => 0' ) ;
#is( 1, ( ! 0 and 1 ), 'tests_operators_and_exclam_precedence: ! 0 and 1 ) => 1' ) ;
#is( "", ( ! 1 and 0 ), 'tests_operators_and_exclam_precedence: ! 1 and 0 ) => ""' ) ;
#is( "", ( ! 1 and 1 ), 'tests_operators_and_exclam_precedence: ! 1 and 1 ) => ""' ) ;
is( 0, ( ! 0 && 0 ), 'tests_operators_and_exclam_precedence: ! 0 && 0 ) => 0' ) ;
is( 1, ( ! 0 && 1 ), 'tests_operators_and_exclam_precedence: ! 0 && 1 ) => 1' ) ;
is( "", ( ! 1 && 0 ), 'tests_operators_and_exclam_precedence: ! 1 && 0 ) => ""' ) ;
is( "", ( ! 1 && 1 ), 'tests_operators_and_exclam_precedence: ! 1 && 1 ) => ""' ) ;
is( 2, ( ! 0 && 2 ), 'tests_operators_and_exclam_precedence: ! 0 && 2 ) => 1' ) ;
note( 'Leaving tests_operators_and_exclam_precedence()' ) ;
return ;
}
sub delete_messages_on_any
{
# $acc is not used yet,
#
my( $mysync, $acc, $imap, $hostX_folder, $expunge, $split, @messages ) = @_ ;
my $expunge_message = q{} ;
my $dry_message = $mysync->{ dry_message } ;
$expunge_message = 'and expunged' if ( $expunge ) ;
# "Host1: msg "
# $imap->Debug( 1 ) ;
my @messages_to_mark_deleted = @messages ;
while ( my @messages_part = splice @messages_to_mark_deleted, 0, $split )
{
foreach my $message ( @messages_part )
{
myprint( "$hostX_folder/$message marking deleted $expunge_message $dry_message\n" ) ;
}
if ( ! $mysync->{dry} && @messages_part )
{
my $nb_deleted = $imap->delete_message( $imap->Range( @messages_part ) ) ;
if ( defined $nb_deleted )
{
# $nb_deleted is not accurate
$acc->{ nb_msg_deleted } += scalar @messages_part ;
}
else
{
my $error_imap = $imap->LastError || q{} ;
my $error = join( q{}, "$hostX_folder folder, could not delete ",
scalar @messages_part, ' messages: ', $error_imap, "\n" ) ;
errors_incr( $mysync, $error ) ;
}
}
}
if ( $expunge ) {
uidexpunge_or_expunge( $mysync, $imap, @messages ) ;
}
#$imap->Debug( 0 ) ;
return ;
}
sub tests_uidexpunge_or_expunge
{
note( 'Entering tests_uidexpunge_or_expunge()' ) ;
is( undef, uidexpunge_or_expunge( ), 'uidexpunge_or_expunge: no args => undef' ) ;
my $mysync ;
is( undef, uidexpunge_or_expunge( $mysync ), 'uidexpunge_or_expunge: undef args => undef' ) ;
$mysync = {} ;
is( undef, uidexpunge_or_expunge( $mysync ), 'uidexpunge_or_expunge: arg empty => undef' ) ;
my $imap ;
is( undef, uidexpunge_or_expunge( $mysync, $imap ), 'uidexpunge_or_expunge: undef Mail-IMAPClient instance => undef' ) ;
require_ok( "Test::MockObject" ) ;
$imap = Test::MockObject->new( ) ;
is( undef, uidexpunge_or_expunge( $mysync, $imap ), 'uidexpunge_or_expunge: no message (1) to uidexpunge => undef' ) ;
my @messages = ( ) ;
is( undef, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: no message (2) to uidexpunge => undef' ) ;
@messages = ( '2', '1' ) ;
$imap->mock( 'uidexpunge', sub { return ; } ) ;
$imap->mock( 'expunge', sub { return ; } ) ;
is( undef, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: uidexpunge failure => expunge failure => undef' ) ;
$imap->mock( 'expunge', sub { return 1 ; } ) ;
is( 1, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: uidexpunge failure => expunge ok => 1' ) ;
$imap->mock( 'uidexpunge', sub { return 1 ; } ) ;
is( 1, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: messages to uidexpunge ok => 1' ) ;
note( 'Leaving tests_uidexpunge_or_expunge()' ) ;
return ;
}
sub uidexpunge_or_expunge
{
my $mysync = shift @ARG ;
my $imap = shift @ARG ;
my @messages = @ARG ;
if ( ! $imap ) { return ; } ;
if ( ! @messages ) { return ; } ;
# Doing uidexpunge
my @uidexpunge_result = $imap->uidexpunge( @messages ) ;
if ( @uidexpunge_result ) {
return 1 ;
}
# Failure so doing expunge
my $expunge_result = $imap->expunge( ) ;
if ( $expunge_result ) {
return 1 ;
}
# bad trip
return ;
}
sub eta_print
{
my $mysync = shift @ARG ;
if ( my $eta = eta( $mysync ) )
{
myprint( "$eta\n" ) ;
}
return ;
}
sub tests_eta
{
note( 'Entering tests_eta()' ) ;
is( q{}, eta( ), 'eta: no args => ""' ) ;
is( q{}, eta( undef ), 'eta: undef => ""' ) ;
my $mysync = {} ;
# No foldersizes
is( q{}, eta( $mysync ), 'eta: No foldersizes => ""' ) ;
$mysync->{ foldersizes } = 1 ;
$mysync->{ begin_transfer_time } = time ; # Now
$mysync->{ h1_nb_msg_processed } = 0 ;
is( "ETA: " . localtimez( time ) . " 0 s 0/0 msgs left",
eta( $mysync ),
'eta: no args => ETA: "Now" 0 s 0/0 msgs left' ) ;
$mysync->{ h1_nb_msg_processed } = 1 ;
$mysync->{ h1_nb_msg_start } = 2 ;
is( "ETA: " . localtimez( time ) . " 0 s 1/2 msgs left",
eta( $mysync ),
'eta: 1, 1, 2 => ETA: "Now" 0 s 1/2 msgs left' ) ;
note( 'Leaving tests_eta()' ) ;
return ;
}
sub eta
{
my( $mysync ) = shift @ARG ;
if ( ! $mysync )
{
return q{} ;
}
return( q{} ) if not $mysync->{ foldersizes } ;
my $h1_nb_msg_start = $mysync->{ h1_nb_msg_start } ;
my $h1_nb_processed = $mysync->{ h1_nb_msg_processed } ;
my $nb_msg_transferred = ( $mysync->{dry} ) ? $mysync->{ h1_nb_msg_processed } : $mysync->{ nb_msg_transferred } ;
my $time_spent = timesince( $mysync->{ begin_transfer_time } ) ;
$h1_nb_processed ||= 0 ;
$h1_nb_msg_start ||= 0 ;
$time_spent ||= 0 ;
my $time_remaining = time_remaining( $time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_msg_transferred ) ;
$mysync->{ debug } and myprint( "time_spent: $time_spent time_remaining: $time_remaining\n" ) ;
my $nb_msg_remaining = $h1_nb_msg_start - $h1_nb_processed ;
my $eta_date = localtimez( time + $time_remaining ) ;
return( mysprintf( 'ETA: %s %1.0f s %s/%s msgs left',
$eta_date, $time_remaining, $nb_msg_remaining, $h1_nb_msg_start ) ) ;
}
sub time_remaining
{
my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @_ ;
$nb_transferred ||= 1 ; # At least one is done (no division by zero)
$h1_nb_processed ||= 0 ;
$h1_nb_msg_start ||= $h1_nb_processed ;
$my_time_spent ||= 0 ;
my $time_remaining = ( $my_time_spent / $nb_transferred ) * ( $h1_nb_msg_start - $h1_nb_processed ) ;
return( $time_remaining ) ;
}
sub tests_time_remaining
{
note( 'Entering tests_time_remaining()' ) ;
# time_spent, nb_processed, nb_to_do_total, nb_transferred
is( 0, time_remaining( ), 'time_remaining: no args -> 0' ) ;
is( 0, time_remaining( 0, 0, 0, 0 ), 'time_remaining: 0, 0, 0, 0 -> 0' ) ;
is( 1, time_remaining( 1, 1, 2, 1 ), 'time_remaining: 1, 1, 2, 1 -> 1' ) ;
is( 1, time_remaining( 9, 9, 10, 9 ), 'time_remaining: 9, 9, 10, 9 -> 1' ) ;
is( 9, time_remaining( 1, 1, 10, 1 ), 'time_remaining: 1, 1, 10, 1 -> 9' ) ;
is( 5, time_remaining( 5, 5, 10, 5 ), 'time_remaining: 5, 5, 10, 5 -> 5' ) ;
is( 25, time_remaining( 5, 5, 10, 0 ), 'time_remaining: 5, 5, 10, 0 -> ( 5 / 1 ) * ( 10 - 5) = 25' ) ;
is( 25, time_remaining( 5, 5, 10, 1 ), 'time_remaining: 5, 5, 10, 1 -> ( 5 / 1 ) * ( 10 - 5) = 25' ) ;
note( 'Leaving tests_time_remaining()' ) ;
return ;
}
sub tests_usecache_and_skipcrossduplicates
{
note( 'Entering tests_usecache_and_skipcrossduplicates()' ) ;
is( undef, usecache_and_skipcrossduplicates( ), 'usecache_and_skipcrossduplicates: no args => undef' ) ;
my $mysync = { } ;
is( undef, usecache_and_skipcrossduplicates( $mysync ), 'usecache_and_skipcrossduplicates: undef => undef' ) ;
$mysync->{ usecache } = $mysync->{ skipcrossduplicates } = 1 ;
is( 1, usecache_and_skipcrossduplicates( $mysync ), 'usecache_and_skipcrossduplicates: usecache=skipcrossduplicates=1 => wrong' ) ;
note( 'Leaving tests_usecache_and_skipcrossduplicates()' ) ;
return ;
}
sub usecache_and_skipcrossduplicates
{
my $mysync = shift @ARG ;
if ( ! defined $mysync ) { return ; }
if ( ( $mysync->{ usecache } ) and ( $mysync->{ skipcrossduplicates } ) )
{
return 1 ;
}
return ;
}
sub cache_map
{
my ( $cache_files_ref, $h1_msgs_ref, $h2_msgs_ref ) = @_;
my ( %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) ;
}
sub tests_cache_map
{
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" ) ;
note( 'Leaving tests_cache_map()' ) ;
return ;
}
sub cache_dir_fix
{
my $cache_dir = shift @ARG ;
$cache_dir =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\])/\\$1/xg ;
#myprint( "cache_dir_fix: $cache_dir\n" ) ;
return( $cache_dir ) ;
}
sub tests_cache_dir_fix
{
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 @ARG ;
$cache_dir =~ s/(\[|\])/[$1]/xg ;
#myprint( "cache_dir_fix_win: $cache_dir\n" ) ;
return( $cache_dir ) ;
}
sub tests_cache_dir_fix_win
{
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 ) = @_;
$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" ) ;
if ( 'MSWin32' ne $OSNAME ) {
$cache_dir = cache_dir_fix( $cache_dir ) ;
}else{
$cache_dir = cache_dir_fix_win( $cache_dir ) ;
}
$debugcache and myprint( "cache_dir_fix: $cache_dir\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" ) ;
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 ) ;
$debugcache and myprint( "Exiting get_cache\n" ) ;
return( $cache_1_2_ref, $cache_2_1_ref ) ;
}
sub tests_get_cache
{
note( 'Entering tests_get_cache()' ) ;
ok( not( get_cache('/cache_no_exist') ), 'get_cache: /cache_no_exist' );
ok( ( not -d 'W/tmp/cache/F1/F2' or rmtree( 'W/tmp/cache/F1/F2' ) ), 'get_cache: rmtree W/tmp/cache/F1/F2' ) ;
ok( mkpath( 'W/tmp/cache/F1/F2' ), 'get_cache: mkpath W/tmp/cache/F1/F2' ) ;
my @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 ] ;
$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');
note( 'Leaving tests_get_cache()' ) ;
return ;
}
sub match_a_cache_file
{
my $file = shift @ARG ;
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 ) ;
}
sub tests_match_a_cache_file
{
note( 'Entering tests_match_a_cache_file()' ) ;
my ( $tuid1, $tuid2 ) ;
ok( ( $tuid1, $tuid2 ) = match_a_cache_file( ), 'match_a_cache_file: no arg' ) ;
ok( ! defined $tuid1 , 'match_a_cache_file: no arg 1' ) ;
ok( ! defined $tuid2 , 'match_a_cache_file: no arg 2' ) ;
ok( ( $tuid1, $tuid2 ) = match_a_cache_file( q{} ), 'match_a_cache_file: empty arg' ) ;
ok( ! defined $tuid1 , 'match_a_cache_file: empty arg 1' ) ;
ok( ! defined $tuid2 , 'match_a_cache_file: empty arg 2' ) ;
ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '000_000' ), 'match_a_cache_file: 000_000' ) ;
ok( '000' eq $tuid1, 'match_a_cache_file: 000_000 1' ) ;
ok( '000' eq $tuid2, 'match_a_cache_file: 000_000 2' ) ;
ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '123_456' ), 'match_a_cache_file: 123_456' ) ;
ok( '123' eq $tuid1, 'match_a_cache_file: 123_456 1' ) ;
ok( '456' eq $tuid2, 'match_a_cache_file: 123_456 2' ) ;
ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/tmp/truc/123_456' ), 'match_a_cache_file: /tmp/truc/123_456' ) ;
ok( '123' eq $tuid1, 'match_a_cache_file: /tmp/truc/123_456 1' ) ;
ok( '456' eq $tuid2, 'match_a_cache_file: /tmp/truc/123_456 2' ) ;
ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/lala123_456' ), 'match_a_cache_file: NO /lala123_456' ) ;
ok( ! $tuid1, 'match_a_cache_file: /lala123_456 1' ) ;
ok( ! $tuid2, 'match_a_cache_file: /lala123_456 2' ) ;
ok( ( $tuid1, $tuid2 ) = match_a_cache_file( 'la123_456' ), 'match_a_cache_file: NO la123_456' ) ;
ok( ! $tuid1, '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 )
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( "$OS_ERROR" ) ;
}
}
$debugcache and myprint( "Exiting clean_cache\n" ) ;
return( 1 ) ;
}
sub tests_clean_cache
{
note( 'Entering tests_clean_cache()' ) ;
ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache: rmtree W/tmp/cache/G1/G2' ) ;
ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache: mkpath W/tmp/cache/G1/G2' ) ;
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{},
177 => q{},
} ;
my $all_2 = {
200 => q{},
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' );
note( 'Leaving tests_clean_cache()' ) ;
return ;
}
sub tests_clean_cache_2
{
note( 'Entering tests_clean_cache_2()' ) ;
ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache_2: rmtree W/tmp/cache/G1/G2' ) ;
ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache_2: mkpath W/tmp/cache/G1/G2' ) ;
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{},
142 => q{},
177 => q{},
} ;
my $all_2 = {
200 => q{},
242 => q{},
777 => q{},
} ;
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' );
note( 'Leaving tests_clean_cache_2()' ) ;
return ;
}
sub tests_mkpath
{
note( 'Entering tests_mkpath()' ) ;
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', 13 ) if ( 'MSWin32' ne $OSNAME ) ;
my $long_path_2_prefix = ".\\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' ) ;
} ;
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/' )), '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++ ;
}
}
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' ) ;
note( 'Leaving tests_tmpdir_has_colon_bug()' ) ;
return ;
}
sub tmpdir_has_colon_bug
{
my $path = shift @ARG ;
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 ) ;
}
sub tmpdir_fix_colon_bug
{
my $mysync = shift @ARG ;
my $err = 0 ;
if ( not (-d $mysync->{ tmpdir } and -r _ and -w _) ) {
myprint( "tmpdir $mysync->{ tmpdir } is not valid\n" ) ;
return( 0 ) ;
}
my $cachedir_new = "$mysync->{ tmpdir }/imapsync_cache" ;
if ( not tmpdir_has_colon_bug( $cachedir_new ) ) { return( 0 ) } ;
# check if old cache directory already exists
my $cachedir_old = filter_forbidden_characters( $cachedir_new ) ;
if ( not ( -d $cachedir_old ) ) {
myprint( "Old cache directory $cachedir_new no exists, nothing to do\n" ) ;
return( 1 ) ;
}
# check if new cache directory already exists
if ( -d $cachedir_new ) {
myprint( "New fixed cache directory $cachedir_new already exists, not moving the old one $cachedir_old. Fix this manually.\n" ) ;
return( 0 ) ;
}else{
# move the old one to the new place
myprint( "Moving $cachedir_old to $cachedir_new Do not interrupt this task.\n" ) ;
File::Copy::Recursive::rmove( $cachedir_old, $cachedir_new )
or do {
myprint( "Could not move $cachedir_old to $cachedir_new\n" ) ;
$err++ ;
} ;
# check it succeeded
if ( -d $cachedir_new and -r _ and -w _ ) {
myprint( "New fixed cache directory $cachedir_new ok\n" ) ;
}else{
myprint( "New fixed cache directory $cachedir_new does not exist\n" ) ;
$err++ ;
}
if ( -d $cachedir_old ) {
myprint( "Old cache directory $cachedir_old still exists\n" ) ;
$err++ ;
}else{
myprint( "Old cache directory $cachedir_old successfully moved\n" ) ;
}
}
return( not $err ) ;
}
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: *|?:"<> -> //_______' ) ;
note( 'Leaving tests_cache_folder()' ) ;
return ;
}
sub cache_folder
{
my( $cache_base, $cache_dir, $h1_fold, $h2_fold ) = @_ ;
my $sep_1 = $sync->{ h1_sep } || '/';
my $sep_2 = $sync->{ 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 ) ;
my $cache_folder = "$cache_base" . filter_forbidden_characters( "$cache_dir/$h1_fold/$h2_fold" ) ;
#myprint( "cache_folder [$cache_folder]\n" ) ;
return( $cache_folder ) ;
}
sub tests_filter_forbidden_characters
{
note( 'Entering tests_filter_forbidden_characters()' ) ;
is( undef , filter_forbidden_characters( ), 'filter_forbidden_characters: no args -> undef' ) ;
is( '' , filter_forbidden_characters( '' ), 'filter_forbidden_characters: empty string -> empty string' ) ;
is( 'a_b' , filter_forbidden_characters( 'a_b' ), 'filter_forbidden_characters: a_b -> a_b' ) ;
is( 'a_b' , filter_forbidden_characters( 'a*b' ), 'filter_forbidden_characters: a*b -> a_b' ) ;
is( 'a_b' , filter_forbidden_characters( 'a|b' ), 'filter_forbidden_characters: a|b -> a_b' ) ;
is( 'a_b' , filter_forbidden_characters( 'a?b' ), 'filter_forbidden_characters: a?b -> a_b' ) ;
is( 'a________b', filter_forbidden_characters( q{a*|?:"<>'b} ), q{filter_forbidden_characters: a*|?:"<>'b -> a________b} ) ;
is( 'a_b_' , filter_forbidden_characters( 'a b ' ), 'filter_forbidden_characters: "a b " -> "a_b_"' ) ;
is( 'a_b' , filter_forbidden_characters( "a\tb" ), 'filter_forbidden_characters: a\tb -> a_b' ) ;
is( "a_b" , filter_forbidden_characters( "a\rb" ), 'filter_forbidden_characters: a\rb -> a_b' ) ;
is( "a_b" , filter_forbidden_characters( "a\nb" ), 'filter_forbidden_characters: a\nb -> a_b' ) ;
is( "a_b" , filter_forbidden_characters( "a\\b" ), 'filter_forbidden_characters: a\b -> a_b' ) ;
is( 'a-b' , filter_forbidden_characters( 'a-b' ), 'filter_forbidden_characters: a-b -> a-b' ) ;
is( 'a__-__-__-__-__b' , filter_forbidden_characters( 'aé-è-à -ç-Öb' ), 'filter_forbidden_characters: aé-è-à -ç-Öb -> a__-__-__-__-__b' ) ;
is( 'abcdABCDwxyzWXYZ012789' , filter_forbidden_characters( 'abcdABCDwxyzWXYZ012789' ),
'filter_forbidden_characters: abcdABCDwxyzWXYZ012789 -> abcdABCDwxyzWXYZ012789' ) ;
note( 'Leaving tests_filter_forbidden_characters()' ) ;
return ;
}
sub filter_forbidden_characters
{
my $string = shift @ARG ;
if ( ! defined $string ) { return ; }
$string =~ s{[\Q*|?:"<>' \E\t\r\n\\]}{_}xg ;
# replace all non-ascii and control characters by _
$string =~ s/[[:^ascii:][:cntrl:]]/_/xg ;
#myprint( "[$string]\n" ) ;
return( $string ) ;
}
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');
note( 'Leaving tests_convert_sep_to_slash()' ) ;
return ;
}
sub convert_sep_to_slash
{
my ( $folder, $sep ) = @_ ;
$folder =~ s{\Q$sep\E}{/}xg ;
return( $folder ) ;
}
sub tests_regexmess
{
note( 'Entering tests_regexmess()' ) ;
ok( 'blabla' eq regexmess( 'blabla' ), 'regexmess: no regexmess, nothing to do' ) ;
@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{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{}),
'regexmess: From mbox 1 add colon blank');
ok( 'From:<[email protected]>'
eq regexmess('From <[email protected]>'),
'regexmess: From mbox 2 add colo');
ok( "\n" . 'From <[email protected]>'
eq regexmess("\n" . 'From <[email protected]>'),
'regexmess: From mbox 3 add colo') ;
ok( "From: zzz\n" . 'From <[email protected]>'
eq regexmess("From zzz\n" . 'From <[email protected]>'),
'regexmess: From mbox 4 add colo') ;
@regexmess = ( 's{\AFrom\ [^\n]*(\n)?}{}gxms' ) ;
ok( q{}
eq regexmess(q{}),
'regexmess: From mbox 1 remove, blank');
ok( q{}
eq regexmess('From <[email protected]>'),
'regexmess: From mbox 2 remove');
ok( "\n" . 'From <[email protected]>'
eq regexmess("\n" . 'From <[email protected]>'),
'regexmess: 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]>'),
'regexmess: From mbox 4 remove');
is(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
, regexmess(
<<'EOM'
From zzz
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
), 'regexmess: From mbox 5 remove');
@regexmess = ( 's{\A((?:[^\n]+\n)+|)^Disposition-Notification-To:[^\n]*\n(\r?\n|.*\n\r?\n)}{$1$2}xms' ) ; # SUPER SUPER BEST!
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
From:<[email protected]>
Hello,
Bye.
EOM
),
'regexmess: 1 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Hello,
Bye.
EOM
),
'regexmess: 2 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
eq regexmess(
<<'EOM'
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
),
'regexmess: 3 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
eq regexmess(
<<'EOM'
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
'regexmess: 4 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
'regexmess: 5 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
'regexmess: 6 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
'regexmess: 7 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
),
'regexmess: 8 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
'regexmess: 9 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
'regexmess: 10 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
'regexmess: 11 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
'regexmess: 12 Delete header Disposition-Notification-To:');
@regexmess = ( 's{\A(.*?(?! ^$))^Disposition-Notification-To:(.*?)$}{$1X-Disposition-Notification-To:$2}igxms' ) ; # BAD!
@regexmess = ( 's{\A((?:[^\n]+\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims' ) ;
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
'regexmess: 13 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
X-Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
From:<[email protected]>
Hello,
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Bye.
EOM
),
'regexmess: 14 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
X-Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
From:<[email protected]>
Hello,
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
From:<[email protected]>
Hello,
Bye.
EOM
),
'regexmess: 15 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
X-Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Hello,
Bye.
EOM
eq regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Hello,
Bye.
EOM
),
'regexmess: 16 Delete header Disposition-Notification-To:');
ok(
<<'EOM'
X-Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
eq regexmess(
<<'EOM'
Disposition-Notification-To: Gilles LAMIRAL <[email protected]>
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
),
'regexmess: 17 Delete header Disposition-Notification-To:');
@regexmess = ( 's/.{11}\K.*//gs' ) ;
is( "0123456789\n", regexmess( "0123456789\n" x 100 ), 'regexmess: truncate whole message after 11 characters' ) ;
is( "0123456789\n", regexmess( "0123456789\n" x 100_000 ), 'regexmess: truncate whole message after 11 characters ~ 1MB' ) ;
@regexmess = ( 's/.{10000}\K.*//gs' ) ;
is( "123456789\n" x 1000, regexmess( "123456789\n" x 100_000 ), 'regexmess: truncate whole message after 10000 characters ~ 1MB' ) ;
@regexmess = ( 's/^(X-Ham-Report.*?\n)^X-/X-/sm' ) ;
is(
<<'EOM'
X-Spam-Score: -1
X-Spam-Bar: /
X-Spam-Flag: NO
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
,
regexmess(
<<'EOM'
X-Spam-Score: -1
X-Spam-Bar: /
X-Ham-Report: =?utf-8?Q?Spam_detection_software=2C_running?=
=?utf-8?Q?_on_the_system_=22ohp-ag006.int200?=
_has_NOT_identified_thi?=
=?utf-8?Q?s_incoming_email_as_spam.__The_o?=
_message_has_been_attac?=
=?utf-8?Q?hed_to_this_so_you_can_view_it_o?=
___________________________?=
=?utf-8?Q?__author's_domain
X-Spam-Flag: NO
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
),
'regexmess: Delete header X-Ham-Report:');
# regex to play with Date: from the FAQ
#@regexmess = 's{\A(.*?(?! ^$))^Date:(.*?)$}{$1Date:$2\nX-Date:$2}gxms'
# Change 8bit characters in whole email to X characters
@regexmess = ( 's{[\x80-\xff]}{X}gxms' ) ;
is( 'X-8bit: kaka 1 XX kiki', regexmess('X-8bit: kaka 1 ¤ kiki'), 'regexmess: 1 Change 8bit characters in whole email to X characters');
# Same change but using tr
@regexmess = ( 'tr [\x80-\xff] [X]' ) ;
is( 'X-8bit: kaka 1 XXXX kiki', regexmess('X-8bit: kaka 1 ¤£ kiki'), 'regexmess: 2 Change 8bit characters in whole email to X characters, using tr');
# Add a final \r\n if missing
@regexmess = ( 's{(?<![\n])\z}{\r\n}gxms' ) ;
is( "\r\n", regexmess(""), 'regexmess: 1. Add a final \r\n if missing. Missing' ) ;
is( "abc\r\n", regexmess("abc"), 'regexmess: 2. Add a final \r\n if missing. Missing' ) ;
is( "abc\ndef\r\n", regexmess("abc\ndef"), 'regexmess: 3. Add a final \r\n if missing. Missing' ) ;
is( "abc\r\ndef\r\n", regexmess("abc\r\ndef"), 'regexmess: 3. Add a final \r\n if missing. Missing' ) ;
is( "\r\n", regexmess("\r\n"), 'regexmess: 3. Add a final \r\n if missing. Not missing' ) ;
is( "abc\n", regexmess("abc\n"), 'regexmess: 4. Add a final \r\n if missing. Not missing' ) ;
is( "abc\r\n", regexmess("abc\r\n"), 'regexmess: 4. Add a final \r\n if missing. Not missing' ) ;
is( "abc\ndef\n", regexmess("abc\ndef\n"), 'regexmess: 4. Add a final \r\n if missing. Not missing' ) ;
is( "abc\r\ndef\r\n", regexmess("abc\r\ndef\r\n"), 'regexmess: 4. Add a final \r\n if missing. Not missing' ) ;
# Remove the fucking buggy X-Spam-Report: a bad header on several lines that can even begin without a space!
@regexmess = ( 's{X-Spam-Report:.*?\n(^[^\n]+:|^\r?\n)}{$1}xms' ) ;
# Damien regexes:
#@regexmess = ( 's{X-Spam-Report:.*?\n(^[a-zA-Z0-9\-]+:)}{$1}xms' ) ;
#@regexmess = ( 's{X-Spam-Report:.*?\n(^[a-zA-Z0-9\-]+:|^\r?\n)}{$1}xms' ) ;
is(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
LaSuite: super
Hello,
Bye.
EOM
, regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
X-Spam-Report: caca
caca
caca
caca
LaSuite: super
Hello,
Bye.
EOM
), 'regexmess: 1 remove buggy X-Spam-Report: across several lines, not the final header');
is(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
LaSuite: super
LaSuite2: super 2
Hello,
Bye.
EOM
, regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
X-Spam-Report: caca
caca
caca
caca
LaSuite: super
LaSuite2: super 2
Hello,
Bye.
EOM
), 'regexmess: 2 remove buggy X-Spam-Report: across several lines, not the final header');
is(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
LaSuite: super
LaSuite2: super 2
Hello,
Bye.
EOM
, regexmess(
<<'EOM'
X-Spam-Report: caca
caca
caca
caca
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
LaSuite: super
LaSuite2: super 2
Hello,
Bye.
EOM
), 'regexmess: 3 remove buggy X-Spam-Report: across several lines, first header');
is(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
, regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
X-Spam-Report: caca
caca
caca
caca
Hello,
Bye.
EOM
), 'regexmess: 4 remove buggy X-Spam-Report: across several lines, final header');
is(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
, regexmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello,
Bye.
EOM
), 'regexmess: 5 remove buggy X-Spam-Report: not there at all');
is(
<<"EOM"
Date: Sat, 10 Jul 2010 05:34:45 -0700\r
From:<tartanpion>\r
LaSuite: super\r
LaSuite2: super 2\r
\r
Hello,\r
Bye.\r
EOM
, regexmess(
<<"EOM"
X-Spam-Report: caca\r
caca\r
caca\r
caca\r
Date: Sat, 10 Jul 2010 05:34:45 -0700\r
From:<tartanpion>\r
LaSuite: super\r
LaSuite2: super 2\r
\r
Hello,\r
Bye.\r
EOM
), 'regexmess: 6 remove buggy X-Spam-Report: across several lines, first header, with \r');
is(
<<"EOM"
Date: Sat, 10 Jul 2010 05:34:45 -0700\r
From:<tartanpion>\r
LaSuite: super\r
LaSuite2: super 2\r
\r
Hello,\r
Bye.\r
EOM
, regexmess(
<<"EOM"
Date: Sat, 10 Jul 2010 05:34:45 -0700\r
From:<tartanpion>\r
X-Spam-Report: caca\r
caca\r
caca\r
caca\r
LaSuite: super\r
LaSuite2: super 2\r
\r
Hello,\r
Bye.\r
EOM
), 'regexmess: 7 remove buggy X-Spam-Report: across several lines, middle header, with \r');
is(
<<"EOM"
Date: Sat, 10 Jul 2010 05:34:45 -0700\r
From:<tartanpion>\r
\r
Hello,\r
Bye.\r
EOM
, regexmess(
<<"EOM"
Date: Sat, 10 Jul 2010 05:34:45 -0700\r
From:<tartanpion>\r
X-Spam-Report: caca\r
caca\r
caca\r
caca\r
\r
Hello,\r
Bye.\r
EOM
), 'regexmess: 8 remove buggy X-Spam-Report: across several lines, final header, with \r');
undef @regexmess ;
note( 'Leaving tests_regexmess()' ) ;
return ;
}
sub regexmess
{
my ( $string ) = @_ ;
foreach my $regexmess ( @regexmess ) {
$sync->{ debug } and myprint( "eval \$string =~ $regexmess\n" ) ;
my $ret = eval "\$string =~ $regexmess ; 1" ;
#myprint( "eval [$ret]\n" ) ;
if ( ( not $ret ) or $EVAL_ERROR ) {
myprint( "Error: eval regexmess '$regexmess': $EVAL_ERROR" ) ;
return( undef ) ;
}
}
$sync->{ debug } and myprint( "$string\n" ) ;
return( $string ) ;
}
sub tests_skipmess
{
note( 'Entering tests_skipmess()' ) ;
ok( not( defined skipmess( 'blabla' ) ), 'skipmess, no skipmess, no skip' ) ;
@skipmess = ('[') ;
ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex [' ) ;
@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( 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{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{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!
ok( 1 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Content-Type: Message/Partial; blabla
From:<[email protected]>
Hello!
Bye.
EOM
),
'skipmess: 1 match Content-Type: Message/Partial' ) ;
ok( 0 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello!
Bye.
EOM
),
'skipmess: 2 not match Content-Type: Message/Partial' ) ;
ok( 1 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Content-Type: Message/Partial; blabla
Hello!
Bye.
EOM
),
'skipmess: 3 match Content-Type: Message/Partial' ) ;
ok( 0 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello!
Content-Type: Message/Partial; blabla
Bye.
EOM
),
'skipmess: 4 not match Content-Type: Message/Partial' ) ;
ok( 0 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<[email protected]>
Hello!
Content-Type: Message/Partial; blabla
Bye.
EOM
),
'skipmess: 5 not match Content-Type: Message/Partial' ) ;
ok( 1 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Content-Type: Message/Partial; blabla
From:<[email protected]>
Hello!
Content-Type: Message/Partial; blabla
Bye.
EOM
),
'skipmess: 6 match Content-Type: Message/Partial' ) ;
ok( 1 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
Content-Type: Message/Partial;
From:<[email protected]>
Hello!
Bye.
EOM
),
'skipmess: 7 match Content-Type: Message/Partial' ) ;
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
6HQ6Hh3CdXj77qEGixerQ6zHx0OnQ/Cf5On4W0Y6vtU2crABZQtD46Hx1EOh8dDz4+OnTr1G
Hello!
Bye.
EOM
),
'skipmess: 8 match Content-Type: Message/Partial' ) ;
ok( 1 == skipmess(
<<'EOM'
Return-Path: <[email protected]>
Received: by lamiral.info (Postfix, from userid 1000)
id 21EB12443BF; Mon, 2 Mar 2015 15:38:35 +0100 (CET)
Subject: test: aethaecohngiexao
To: <[email protected]>
X-Mailer: mail (GNU Mailutils 2.2)
Message-Id: <[email protected]>
Content-Type: message/partial;
id="TAN_U_P<1404267997.00007489ed17>";
number=3;
total=3
Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET)
From: [email protected] (Gilles LAMIRAL)
test: aethaecohngiexao
EOM
),
'skipmess: 9 match Content-Type: Message/Partial' ) ;
ok( 1 == skipmess(
<<'EOM'
Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET)
From: [email protected] (Gilles LAMIRAL)
Content-Type: message/partial;
id="TAN_U_P<1404267997.00007489ed17>";
number=3;
total=3
test: aethaecohngiexao
EOM
. "lalala\n" x 3_000_000
),
'skipmess: 10 match Content-Type: Message/Partial' ) ;
ok( 0 == skipmess(
<<'EOM'
Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET)
From: [email protected] (Gilles LAMIRAL)
test: aethaecohngiexao
EOM
. "lalala\n" x 3_000_000
),
'skipmess: 11 match Content-Type: Message/Partial' ) ;
ok( 0 == skipmess(
<<"EOM"
From: fff\r
To: fff\r
Subject: Testing imapsync --skipmess\r
Date: Mon, 22 Aug 2011 08:40:20 +0800\r
Mime-Version: 1.0\r
Content-Type: text/plain; charset=iso-8859-1\r
Content-Transfer-Encoding: 7bit\r
\r
EOM
. 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;
undef @skipmess ;
note( 'Leaving tests_skipmess()' ) ;
return ;
}
sub tests_skipmess_neg
{
note( 'Entering tests_skipmess_neg()' ) ;
@skipmess = ('m{i}') ;
ok( 1 == skipmess( 'Hi!' ), 'skipmess: i string yes' ) ;
ok( 0 == skipmess( 'Ho!' ), 'skipmess: i string no' ) ;
@skipmess = ('m{\A(?!.*i)}') ;
ok( 0 == skipmess( 'Hi!' ), 'skipmess: not i string no' ) ;
ok( 1 == skipmess( 'Ho!' ), 'skipmess: not i string yes' ) ;
@skipmess = ('m{\A(?!.*^From:[^\n]*tartanpion\@machin\.truc)}xms') ;
ok( 0 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From: <[email protected]>
Bye.
EOM
),
'skipmess: 1 not From [email protected]' ) ;
ok( 1 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From: <[email protected]>
Bye.
EOM
),
'skipmess: 2 not From [email protected]' ) ;
ok( 0 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From: <[email protected]>
From: <[email protected]>
Bye.
EOM
),
'skipmess: 3 not From [email protected]' ) ;
ok( 1 == skipmess(
<<'EOM'
Date: Sat, 10 Jul 2010 05:34:45 -0700
From: <[email protected]>
From: <[email protected]>
Bye.
EOM
),
'skipmess: 4 not From [email protected]' ) ;
undef @skipmess ;
note( 'Leaving tests_skipmess_neg()' ) ;
return ;
}
sub skipmess
{
my ( $string ) = @_ ;
my $match ;
#myprint( "$string\n" ) ;
foreach my $skipmess ( @skipmess ) {
$sync->{ debug } and myprint( "eval \$match = \$string =~ $skipmess\n" ) ;
my $ret = eval "\$match = \$string =~ $skipmess ; 1" ;
#myprint( "eval [$ret]\n" ) ;
$sync->{ 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_bin
{
note( 'Entering tests_bytes_display_string_bin()' ) ;
is( 'NA', bytes_display_string_bin( ), 'bytes_display_string_bin: no args => NA' ) ;
is( 'NA', bytes_display_string_bin( undef ), 'bytes_display_string_bin: undef => NA' ) ;
is( 'NA', bytes_display_string_bin( 'blabla' ), 'bytes_display_string_bin: blabla => NA' ) ;
is( '0.000 KiB', bytes_display_string_bin( 0 ), 'bytes_display_string_bin: 0 => 0.000 KiB' ) ;
is( '0.001 KiB', bytes_display_string_bin( 1 ), 'bytes_display_string_bin: 1 => 0.001 KiB' ) ;
is( '0.010 KiB', bytes_display_string_bin( 10 ), 'bytes_display_string_bin: 10 => 0.010 KiB' ) ;
is( '0.976 KiB', bytes_display_string_bin( 999 ), 'bytes_display_string_bin: 999 => 0.976 KiB' ) ;
note( bytes_display_string_bin( 999 ) ) ;
is( '0.999 KiB', bytes_display_string_bin( 1023 ), 'bytes_display_string_bin: 1023 => 0.999 KiB' ) ;
note( bytes_display_string_bin( 1023 ) ) ;
is( '1.000 KiB', bytes_display_string_bin( 1024 ), 'bytes_display_string_bin: 1024 => 1.000 KiB' ) ;
note( bytes_display_string_bin( 1024 ) ) ;
is( '1.001 KiB', bytes_display_string_bin( 1025 ), 'bytes_display_string_bin: 1025 => 1.001 KiB' ) ;
is( '9.999 KiB', bytes_display_string_bin( 10_239 ), 'bytes_display_string_bin: 10_239 => 9.999 KiB' ) ;
note( bytes_display_string_bin( 10_239 ) ) ;
is( '10.000 KiB', bytes_display_string_bin( 10_240 ), 'bytes_display_string_bin: 10_240 => 10.000 KiB' ) ;
note( bytes_display_string_bin( 10_240 ) ) ;
is( '999.999 KiB', bytes_display_string_bin( 1_023_999 ), 'bytes_display_string_bin: 1_023_999 => 999.999 KiB' ) ;
note( bytes_display_string_bin( 1_023_999 ) ) ;
is( '0.977 MiB', bytes_display_string_bin( 1_024_000 ), 'bytes_display_string_bin: 1_024_000 => 0.977 MiB' ) ;
note( bytes_display_string_bin( 1_024_000 ) ) ;
is( '0.999 MiB', bytes_display_string_bin( 1_047_527 ), 'bytes_display_string_bin: 1_047_527 => 0.999 MiB' ) ;
note( bytes_display_string_bin( 1_047_527 ) ) ;
is( '0.999 MiB', bytes_display_string_bin( 1_048_051 ), 'bytes_display_string_bin: 1_048_051 => 0.999 MiB' ) ;
note( bytes_display_string_bin( 1_048_051 ) ) ;
is( '1.000 MiB', bytes_display_string_bin( 1_048_052 ), 'bytes_display_string_bin: 1_048_052 => 1.000 MiB' ) ;
note( bytes_display_string_bin( 1_048_052 ) ) ;
is( '1.000 MiB', bytes_display_string_bin( 1_048_575 ), 'bytes_display_string_bin: 1_048_575 => 1.000 MiB' ) ;
is( '1.000 MiB', bytes_display_string_bin( 1_048_576 ), 'bytes_display_string_bin: 1_048_576 => 1.000 MiB' ) ;
is( '1.000 GiB', bytes_display_string_bin( 1_073_741_823 ), 'bytes_display_string_bin: 1_073_741_823 => 1.000 GiB' ) ;
is( '1.000 GiB', bytes_display_string_bin( 1_073_741_824 ), 'bytes_display_string_bin: 1_073_741_824 => 1.000 GiB' ) ;
is( '1.000 TiB', bytes_display_string_bin( 1_099_511_627_775 ), 'bytes_display_string_bin: 1_099_511_627_775 => 1.000 TiB' ) ;
is( '1.000 TiB', bytes_display_string_bin( 1_099_511_627_776 ), 'bytes_display_string_bin: 1_099_511_627_776 => 1.000 TiB' ) ;
is( '1.000 PiB', bytes_display_string_bin( 1_125_899_906_842_623 ), 'bytes_display_string_bin: 1_125_899_906_842_623 => 1.000 PiB' ) ;
is( '1.000 PiB', bytes_display_string_bin( 1_125_899_906_842_624 ), 'bytes_display_string_bin: 1_125_899_906_842_624 => 1.000 PiB' ) ;
is( '1024.000 PiB', bytes_display_string_bin( 1_152_921_504_606_846_975 ), 'bytes_display_string_bin: 1_152_921_504_606_846_975 => 1024.000 PiB' ) ;
is( '1024.000 PiB', bytes_display_string_bin( 1_152_921_504_606_846_976 ), 'bytes_display_string_bin: 1_152_921_504_606_846_976 => 1024.000 PiB' ) ;
is( '1048576.000 PiB', bytes_display_string_bin( 1_180_591_620_717_411_303_424 ), 'bytes_display_string_bin: 1_180_591_620_717_411_303_424 => 1048576.000 PiB' ) ;
note( bytes_display_string_bin( 1_180_591_620_717_411_303_424 ) ) ;
note( bytes_display_string_bin( 3_000_000_000 ) ) ;
note( 'Leaving tests_bytes_display_string_bin()' ) ;
return ;
}
sub bytes_display_string_bin
{
my ( $bytes ) = @_ ;
my $readable_value = q{} ;
if ( ! defined( $bytes ) ) {
return( 'NA' ) ;
}
if ( not match_number( $bytes ) ) {
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!
}
#myprint( "$bytes = $readable_value\n" ) ;
return( $readable_value ) ;
}
sub tests_bytes_display_string_dec
{
note( 'Entering tests_bytes_display_string_dec()' ) ;
is( 'NA', bytes_display_string_dec( ), 'bytes_display_string_dec: no args => NA' ) ;
is( 'NA', bytes_display_string_dec( undef ), 'bytes_display_string_dec: undef => NA' ) ;
is( 'NA', bytes_display_string_dec( 'blabla' ), 'bytes_display_string_dec: blabla => NA' ) ;
is( '0 bytes', bytes_display_string_dec( 0 ), 'bytes_display_string_dec: 0 => 0 bytes' ) ;
is( '1 bytes', bytes_display_string_dec( 1 ), 'bytes_display_string_dec: 1 => 1 bytes' ) ;
is( '10 bytes', bytes_display_string_dec( 10 ), 'bytes_display_string_dec: 10 => 10 bytes' ) ;
is( '999 bytes', bytes_display_string_dec( 999 ), 'bytes_display_string_dec: 999 => 999 bytes' ) ;
is( '1.000 KB', bytes_display_string_dec( 1000 ), 'bytes_display_string_dec: 1000 => 1.000 KB' ) ;
is( '1.001 KB', bytes_display_string_dec( 1001 ), 'bytes_display_string_dec: 1000 => 1.1001 KB' ) ;
is( '999.999 KB', bytes_display_string_dec( 999_999 ), 'bytes_display_string_dec: 999_999 => 999.999 KB' ) ;
is( '1.000 MB', bytes_display_string_dec( 1_000_000 ), 'bytes_display_string_dec: 1_000_000 => 1.000 MB' ) ;
is( '1.000 MB', bytes_display_string_dec( 1_000_500 ), 'bytes_display_string_dec: 1_000_500 => 1.000 MB' ) ;
is( '1.001 MB', bytes_display_string_dec( 1_000_501 ), 'bytes_display_string_dec: 1_000_501 => 1.001 MB' ) ;
is( '999.999 MB', bytes_display_string_dec( 999_999_000 ), 'bytes_display_string_dec: 999_999_000 => 999.999 MB' ) ;
is( '999.999 MB', bytes_display_string_dec( 999_999_499 ), 'bytes_display_string_dec: 999_999_499 => 999.999 MB' ) ;
is( '1.000 GB', bytes_display_string_dec( 999_999_500 ), 'bytes_display_string_dec: 999_999_500 => 1.000 GB' ) ;
is( '1.000 GB', bytes_display_string_dec( 1_000_000_000 ), 'bytes_display_string_dec: 1_000_000_000 => 1.000 GB' ) ;
is( '1.000 GB', bytes_display_string_dec( 1_000_500_000 ), 'bytes_display_string_dec: 1_000_500_000 => 1.000 GB' ) ;
is( '1.001 GB', bytes_display_string_dec( 1_000_500_001 ), 'bytes_display_string_dec: 1_000_501_000 => 1.001 GB' ) ;
is( '999.999 GB', bytes_display_string_dec( 999_999_000_000 ), 'bytes_display_string_dec: 999_999_000_000 => 999.999 GB' ) ;
is( '999.999 GB', bytes_display_string_dec( 999_999_499_999 ), 'bytes_display_string_dec: 999_999_499_999 => 999.999 GB' ) ;
is( '1.000 TB', bytes_display_string_dec( 999_999_500_000 ), 'bytes_display_string_dec: 999_999_500_000 => 1.000 TB' ) ;
is( '1.000 TB', bytes_display_string_dec( 1_000_000_000_000 ), 'bytes_display_string_dec: 1_000_000_000_000 => 1.000 TB' ) ;
is( '1.000 TB', bytes_display_string_dec( 1_000_500_000_000 ), 'bytes_display_string_dec: 1_000_500_000_000 => 1.000 TB' ) ;
is( '1.001 TB', bytes_display_string_dec( 1_000_500_000_001 ), 'bytes_display_string_dec: 1_000_500_000_000 => 1.000 TB' ) ;
is( '999.999 TB', bytes_display_string_dec( 999_999_000_000_000 ), 'bytes_display_string_dec: 999_999_000_000_000 => 999.999 TB' ) ;
is( '999.999 TB', bytes_display_string_dec( 999_999_499_999_999 ), 'bytes_display_string_dec: 999_999_499_999_999 => 999.999 TB' ) ;
is( '1.000 PB', bytes_display_string_dec( 999_999_500_000_000 ), 'bytes_display_string_dec: 999_999_500_000_000 => 1.000 PB' ) ;
is( '3.000 GB', bytes_display_string_dec( 3_000_000_000 ), 'bytes_display_string_dec: 3_000_000_000 => 3.000 GB' ) ;
note( 'Leaving tests_bytes_display_string_dec()' ) ;
return ;
}
sub bytes_display_string_dec
{
my ( $bytes ) = @_ ;
my $readable_value = q{} ;
if ( ! defined( $bytes ) ) {
return( 'NA' ) ;
}
if ( not match_number( $bytes ) ) {
return( 'NA' ) ;
}
SWITCH: {
if ( abs( $bytes ) < ( 1000 ) ) {
$readable_value = mysprintf( '%.0f bytes', $bytes ) ;
last SWITCH ;
}
if ( abs( $bytes ) < ( 1000**2 ) ) {
$readable_value = mysprintf( '%.3f KB', $bytes / 1000 ) ;
last SWITCH ;
}
if ( abs( $bytes ) < ( 999_999_500 ) ) {
$readable_value = mysprintf( '%.3f MB', $bytes / ( 1000**2 ) ) ;
last SWITCH ;
}
if ( abs( $bytes ) < ( 999_999_500_000 ) ) {
$readable_value = mysprintf( '%.3f GB', $bytes / ( 1000**3 ) ) ;
last SWITCH ;
}
if ( abs( $bytes ) < ( 999_999_500_000_000 ) ) {
$readable_value = mysprintf( '%.3f TB', $bytes / ( 1000**4 ) ) ;
last SWITCH ;
} else {
$readable_value = mysprintf( '%.3f PB', $bytes / ( 1000**5 ) ) ;
}
# if you have exabytes (EiB) of email to transfer, you have too much email!
}
#myprint( "$bytes = $readable_value\n" ) ;
return( $readable_value ) ;
}
sub tests_useheader_suggestion
{
note( 'Entering tests_useheader_suggestion()' ) ;
is( undef, useheader_suggestion( ), 'useheader_suggestion: no args => undef' ) ;
my $mysync = {} ;
$mysync->{ h1_nb_msg_noheader } = 0 ;
is( q{}, useheader_suggestion( $mysync ), 'useheader_suggestion: h1_nb_msg_noheader count null => no suggestion' ) ;
$mysync->{ h1_nb_msg_noheader } = 2 ;
is( q{in order to sync those 2 unidentified messages, add option --addheader}, useheader_suggestion( $mysync ),
'useheader_suggestion: h1_nb_msg_noheader count 2 => suggestion of --addheader' ) ;
note( 'Leaving tests_useheader_suggestion()' ) ;
return ;
}
sub useheader_suggestion
{
my $mysync = shift @ARG ;
if ( ! defined $mysync->{ h1_nb_msg_noheader } )
{
return ;
}
elsif ( 1 <= $mysync->{ h1_nb_msg_noheader } )
{
return qq{in order to sync those $mysync->{ h1_nb_msg_noheader } unidentified messages, add option --addheader} ;
}
else
{
return q{} ;
}
return ;
}
sub do_and_print_stats
{
my $mysync = shift @ARG ;
if ( ! $mysync->{can_do_stats} ) {
return ;
}
my $timeend = time ;
my $timediff = $timeend - $mysync->{timestart} ;
my $timeend_str = localtimez( $timeend ) ;
my $cpu_time = cpu_time( $mysync ) ;
my $cpu_percent = cpu_percent( $mysync, $cpu_time, $timediff ) ;
my $cpu_percent_global = cpu_percent_global( $mysync, $cpu_percent ) ;
my $memory_consumption_at_end = memory_consumption_of_myself( ) || 0 ;
my $memory_consumption_at_start = $mysync->{ memory_consumption_at_start } || 0 ;
my $memory_ratio = ( $mysync->{ biggest_message_transferred } ) ?
mysprintf( '%.1f', $memory_consumption_at_end / $mysync->{ biggest_message_transferred } ) : 'NA' ;
# my $useheader_suggestion = useheader_suggestion( $mysync ) ;
myprint( "++++ Statistics\n" ) ;
myprint( "Transfer started on : $mysync->{ timestart_str }\n" ) ;
myprint( "Transfer ended on : $timeend_str\n" ) ;
myprintf( "Transfer time : %.1f sec\n", $timediff ) ;
myprint( "Folders synced : $h1_folders_wanted_ct/$h1_folders_wanted_nb synced\n" ) ;
myprint( "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 : $mysync->{ nb_msg_skipped }\n" ) ;
myprint( "Messages found duplicate on host1 : $mysync->{ acc1 }->{ nb_msg_duplicate }\n" ) ;
myprint( "Messages found duplicate on host2 : $mysync->{ acc2 }->{ nb_msg_duplicate }\n" ) ;
myprint( "Messages found crossduplicate on host2 : $mysync->{ h2_nb_msg_crossdup }\n" ) ;
myprint( "Messages void (noheader) on host1 : $mysync->{ h1_nb_msg_noheader } ", useheader_suggestion( $mysync ), "\n" ) ;
myprint( "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n" ) ;
nb_messages_in_1_not_in_2( $mysync ) ;
nb_messages_in_2_not_in_1( $mysync ) ;
myprintf( "Messages found in host1 not in host2 : %s messages\n", $mysync->{ nb_messages_in_1_not_in_2 } ) ;
myprintf( "Messages found in host2 not in host1 : %s messages\n", $mysync->{ nb_messages_in_2_not_in_1 } ) ;
myprint( "Messages deleted on host1 : $mysync->{ acc1 }->{ nb_msg_deleted }\n" ) ;
myprint( "Messages deleted on host2 : $mysync->{ acc2 }->{ nb_msg_deleted }\n" ) ;
myprintf( "Total bytes transferred : %s (%s)\n",
$mysync->{total_bytes_transferred},
bytes_display_string_bin( $mysync->{total_bytes_transferred} ) ) ;
myprintf( "Total bytes skipped : %s (%s)\n",
$mysync->{ total_bytes_skipped },
bytes_display_string_bin( $mysync->{ total_bytes_skipped } ) ) ;
$timediff ||= 1 ; # No division per 0
myprintf("Message rate : %.1f messages/s\n", $mysync->{nb_msg_transferred} / $timediff ) ;
myprintf("Average bandwidth rate : %.1f KiB/s\n", $mysync->{total_bytes_transferred} / $KIBI / $timediff ) ;
myprint( "Reconnections to host1 : $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ;
myprint( "Reconnections to host2 : $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ;
myprintf("Memory consumption at the end : %.1f MiB (*time %.1f MiB*h) (started with %.1f MiB)\n",
$memory_consumption_at_end / $KIBI / $KIBI,
memory_consumption_surface( $mysync, $memory_consumption_at_end, $timediff ),
$memory_consumption_at_start / $KIBI / $KIBI ) ;
myprint( "Load end is : " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $mysync->{cpu_number} cores\n" ) ;
myprint( "CPU time and %cpu : $cpu_time sec $cpu_percent %cpu $cpu_percent_global %allcpus\n" ) ;
myprintf("Biggest message transferred : %s bytes (%s)\n",
$mysync->{ biggest_message_transferred },
bytes_display_string_bin( $mysync->{ biggest_message_transferred } ) ) ;
myprint( "Memory/biggest message ratio : $memory_ratio\n" ) ;
if ( $mysync->{ foldersizesatend } and $mysync->{ foldersizes } ) {
my $nb_msg_start_diff = diff_or_NA( $mysync->{ h2_nb_msg_start }, $mysync->{ h1_nb_msg_start } ) ;
my $bytes_start_diff = diff_or_NA( $mysync->{ h2_bytes_start }, $mysync->{ h1_bytes_start } ) ;
myprintf("Start difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_start_diff,
$bytes_start_diff,
bytes_display_string_bin( $bytes_start_diff ) ) ;
my $nb_msg_end_diff = diff_or_NA( $h2_nb_msg_end, $h1_nb_msg_end ) ;
my $bytes_end_diff = diff_or_NA( $h2_bytes_end, $h1_bytes_end ) ;
myprintf("Final difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_end_diff,
$bytes_end_diff,
bytes_display_string_bin( $bytes_end_diff ) ) ;
}
comment_on_final_diff_in_1_not_in_2( $mysync ) ;
comment_on_final_diff_in_2_not_in_1( $mysync ) ;
myprint( "Detected $mysync->{nb_errors} errors\n" ) ;
myprint( $mysync->{ warn_release }, "\n" ) ;
myprint( homepage( ), "\n" ) ;
return ;
}
sub tests_memory_consumption_surface
{
note( 'Entering tests_memory_consumption_surface()' ) ;
is( undef, memory_consumption_surface( ), 'memory_consumption_surface: no args => undef' ) ;
my $mysync = { } ;
is( undef, memory_consumption_surface( $mysync ), 'memory_consumption_surface: { } => undef' ) ;
is( "1.0", memory_consumption_surface( $mysync, 1_048_576, 3600 ), 'memory_consumption_surface: 1 MB 1 hour => 1' ) ;
is( "238.4", memory_consumption_surface( $mysync, 500_000_000, 1800 ), 'memory_consumption_surface: 500 MB 30 min => 238' ) ;
note( 'Leaving tests_memory_consumption_surface()' ) ;
return ;
}
sub memory_consumption_surface
{
my ( $mysync, $memory_consumption_at_end, $timediff ) = @ARG ;
if ( ! all_defined( $mysync, $memory_consumption_at_end, $timediff ) ) { return } ;
my $memory_consumption_surface = sprintf( "%.1f", $timediff * $memory_consumption_at_end / $KIBI / $KIBI / 3600 ) ;
return $memory_consumption_surface ;
}
sub tests_email_report_message_id
{
note( 'Entering tests_email_report_message_id()' ) ;
local $ENV{TZ} = 'GMT' ;
like( email_report_message_id( ),
qr{^...._.._.._.._.._.._...__\@imapsync.tk$}xms,
'email_report_message_id: no args => [email protected]' ) ;
my $mysync = { } ;
like( email_report_message_id( $mysync ),
qr{^...._.._.._.._.._.._...__\@imapsync.tk$}xms,
'email_report_message_id: undef => [email protected]' ) ;
$mysync->{ timestart } = 1357902468.531 ;
like(
email_report_message_id( $mysync ),
qr{^2013_01_11_\d\d_07_48_530__\@imapsync.tk$}xms,
'email_report_message_id: 1357902468.531 => 2013_01_11_\d\[email protected]' ) ;
$mysync->{ user1 } = 'sarah' ;
$mysync->{ user2 } = 'haras' ;
$mysync->{ timestart } = 1357902468.531 ;
like(
email_report_message_id( $mysync ),
qr{^2013_01_11_\d\d_07_48_530_sarah_haras\@imapsync.tk$}xms,
'email_report_message_id: 1357902468.531 sarah haras => 2013_01_11_\d\[email protected]' ) ;
$mysync->{ user1 } = 'sar@ah' ;
$mysync->{ user2 } = 'har@as' ;
$mysync->{ timestart } = 1357902468.531 ;
like(
email_report_message_id( $mysync ),
qr{2013_01_11_\d\d_07_48_530_sar_ah_har_as\@imapsync.tk},
'email_report_message_id: 1357902468.531 sar@ah har@as => 2013_01_11_\d\[email protected]' ) ;
note( 'Leaving tests_email_report_message_id()' ) ;
return ;
}
sub email_report_message_id
{
my $mysync = shift @ARG ;
my $time = $mysync->{ timestart } || time ;
my $user1_filtered = $mysync->{ user1 } || '' ;
my $user2_filtered = $mysync->{ user2 } || '' ;
# Nothing but alphanumeric characters and underscores to replace the others
$user1_filtered =~ s/[^a-zA-Z0-9]/_/g ;
$user2_filtered =~ s/[^a-zA-Z0-9]/_/g ;
my $message_id = join( '',
year_month_day_hour_min_sec_ms( $time ),
'_',
$user1_filtered,
'_',
$user2_filtered,
'@imapsync.tk',
) ;
return $message_id ;
}
sub tests_date_rfc822
{
note( 'Entering tests_email_report_date()' ) ;
ok( date_rfc822( ), 'date_rfc822: no args => now: ' . date_rfc822( ) ) ;
if ( 'MSWin32' eq $OSNAME )
{
like( date_rfc822( 1671706800 ), qr{Thu, 22 Dec 2022 \d\d:00:00 \+0000}, 'date_rfc822: 1671706800 => Thu, 22 Dec 2022 \d\d:00:00 \+0000' ) ;
like( date_rfc822( 1671534000 ), qr{Tue, 20 Dec 2022 \d\d:00:00 \+0000}, 'date_rfc822: 1671534000 => Tue, 20 Dec 2022 \d\d:00:00 \+0000' ) ;
}
else
{
local $ENV{TZ} = 'GMT' ;
is( 'Thu, 01 Jan 1970 00:00:00 +0000', date_rfc822( 0 ), 'date_rfc822: 0 => Thu, 01 Jan 1970 00:00:00 +0000' ) ;
is( 'Thu, 22 Dec 2022 11:00:00 +0000', date_rfc822( 1671706800 ), 'date_rfc822: 1671706800 => Thu, 22 Dec 2022 11:00:00 +0000' ) ;
}
note( 'Leaving tests_email_report_date()' ) ;
return ;
}
sub date_rfc822
{
# Later I found Mail::IMAPCLient::Rfc822_date()
# https://metacpan.org/pod/Mail::IMAPClient#Rfc822_date
my $time = shift @ARG ;
$time = defined( $time ) ? $time : time ;
my $old_locale = POSIX::setlocale( POSIX::LC_TIME, "C" ) ;
my $date_rfc822 ;
if ( 'MSWin32' eq $OSNAME )
{
$date_rfc822 = POSIX::strftime( "%a, %d %b %Y %H:%M:%S +0000", localtime( $time ) ) ;
}
else
{
$date_rfc822 = POSIX::strftime( "%a, %d %b %Y %H:%M:%S %z", localtime( $time ) ) ;
}
POSIX::setlocale( POSIX::LC_TIME, $old_locale ) ;
return $date_rfc822 ;
}
sub tests_email_report_from
{
note( 'Entering tests_email_report_from()' ) ;
is( '[email protected]', email_report_from( ), 'email_report_from: no args => [email protected]' ) ;
my $mysync = { } ;
is( '[email protected]', email_report_from( $mysync ), 'email_report_from: undef => [email protected]' ) ;
$mysync->{ email_report_from } = '[email protected]' ;
is( '[email protected]', email_report_from( $mysync ), 'email_report_from: [email protected] => [email protected]' ) ;
note( 'Leaving tests_email_report_from()' ) ;
return ;
}
sub email_report_from
{
my $mysync = shift @ARG ;
my $email_report_from = defined( $mysync->{ email_report_from } )
? $mysync->{ email_report_from }
: '[email protected]' ;
return $email_report_from ;
}
sub tests_email_report_to
{
note( 'Entering tests_email_report_from()' ) ;
is( '[email protected]', email_report_to( ), 'email_report_to: no args => [email protected]' ) ;
my $mysync = { } ;
is( '[email protected]', email_report_to( $mysync ), 'email_report_to: undef => [email protected]' ) ;
$mysync->{ user2 } = '[email protected]' ;
is( '[email protected]', email_report_to( $mysync ), 'email_report_to: [email protected] => [email protected]' ) ;
note( 'Leaving tests_email_report_from()' ) ;
return ;
}
sub email_report_to
{
my $mysync = shift @ARG ;
my $email_report_to = defined( $mysync->{ user2 } )
? $mysync->{ user2 }
: '[email protected]' ;
return $email_report_to ;
}
sub email_report_subject
{
my $mysync = shift @ARG ;
my $email_report_subject = 'Imapsync transferred your account' ;
return $email_report_subject ;
}
sub tests_email_report_body_base
{
note( 'Entering tests_email_report_body_base()' ) ;
is( '', email_report_body_base( ), 'email_report_body_base: no args => empty string' ) ;
my $mysync = { } ;
is( '', email_report_body_base( $mysync ), 'email_report_body_base: undef => empty string' ) ;
$mysync->{ user1 } = '[email protected]' ;
$mysync->{ user2 } = '[email protected]' ;
note( email_report_body_base( $mysync ) ) ;
note( 'Leaving tests_email_report_body_base()' ) ;
return ;
}
sub email_report_body_base
{
my $mysync = shift @ARG ;
if( ! $mysync ) { return '' ; }
if( ! all_defined(
$mysync->{ user1 },
$mysync->{ user2 },
) ) { return '' ; }
my $email_report_body_base = <<"EOM";
<!DOCTYPE html>\r
<html lang="en">\r
<head>\r
<title>Imapsync transfer from $mysync->{ user1 } to $mysync->{ user2 }</title>\r
</head>\r
<body>\r
<p>Hello!</p>\r
<p>\r
Imapsync just ended the synchronization from the imap account <b>$mysync->{ user1 }</b> to the imap account <b>$mysync->{ user2 }</b>.<br />\r
</p>\r
EOM
return $email_report_body_base ;
}
sub email_report_body_extra1
{
my $image = '<a href="https://imapsync.lamiral.info/">'
.'<img src="https://imapsync.lamiral.info/S/images/logo_imapsync_s1.png" alt="imapsync website" />'
.'</a>'
. "\r\n"
;
return $image ;
}
sub email_report_body_extra2
{
my $image = '<a href="https://imapsync.lamiral.info/">'
.'<img src="https://imapsync.lamiral.info/S/images/logo_imapsync_s2.png" alt="imapsync website" />'
.'</a>'
. "\r\n"
;
return $image ;
}
sub email_report_html_begin
{
return '<html>'
. "\r\n"
;
}
sub email_report_html_end
{
return '</html>'
. "\r\n"
;
}
sub email_report_body_begin
{
return '<body>'
. "\r\n"
;
}
sub email_report_body_end
{
return '</body>'
. "\r\n"
;
}
sub email_report_header
{
my $mysync = shift @ARG ;
my @header ;
push( @header, join( "\r\n",
'Message-Id: ' . email_report_message_id( $mysync ),
'Date: ' . date_rfc822( time ),
'From: ' . email_report_from( $mysync ),
'To: ' . email_report_to( $mysync ),
'Subject: ' . email_report_subject( $mysync ),
'Content-Type: text/html',
"\r\n",
)
) ;
return @header ;
}
sub tests_email_report
{
note( 'Entering tests_email_report()' ) ;
is( '', email_report( ), 'email_report: undef => empty string' ) ;
my $mysync = { } ;
$mysync->{ user1 } = '[email protected]' ;
$mysync->{ user2 } = '[email protected]' ;
note( email_report( $mysync, "c'est extra !\r\n" ) ) ;
note( 'Leaving tests_email_report()' ) ;
return ;
}
sub email_report
{
my $mysync = shift @ARG ;
my $extra = shift @ARG ;
if ( ! defined $mysync ) { return '' ; }
my @email_report = ( ) ;
push( @email_report, email_report_header( $mysync ),
email_report_html_begin( ),
email_report_body_begin( ),
email_report_body_base( $mysync ),
$extra,
email_report_body_end( ),
email_report_html_end( ),
) ;
my $email_report = join( "", @email_report ) ;
return $email_report ;
}
sub email_report_append
{
my $acc = shift @ARG ;
my $text = shift @ARG ;
if ( $acc->{ imap }->IsAuthenticated && $text )
{
my $newuid = $acc->{ imap }->append_string( 'INBOX', $text ) ;
if ( $newuid )
{
myprint( "$acc->{ Side }: Successfully put the email final report in INBOX. Use --noemailreport" . $acc->{N} . " to avoid it.\n" ) ;
}
else
{
myprint( "$acc->{ Side }: Failed to put the email final report in INBOX. Use --noemailreport" . $acc->{N} . " to avoid it.\n" ) ;
}
return $newuid ;
}
else
{
return ;
}
}
sub final_emails_reports
{
my $mysync = shift @ARG ;
if ( condition_to_put_final_emails_reports( $mysync ) )
{
$mysync->{ emailreport2 } and email_report_append( $mysync->{ acc2 }, email_report( $mysync, email_report_body_extra2( ) ) ) ;
$mysync->{ emailreport1 } and email_report_append( $mysync->{ acc1 }, email_report( $mysync, email_report_body_extra1( ) ) ) ;
}
return ;
}
sub condition_to_put_final_emails_reports
{
my $mysync = shift @ARG ;
if ( $mysync->{ dry } ) { return 0 ; }
if ( $mysync->{ justfolders } ) { return 0 ; }
return 1 ;
}
sub diff_or_NA
{
my( $n1, $n2 ) = @ARG ;
if ( not defined $n1 or not defined $n2 ) {
return 'NA' ;
}
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]?/x ) {
return 1 ;
}
else {
return 0 ;
}
}
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' ) ;
is( 0, match_number( 'blabla' ), 'match_number: blabla => 0' ) ;
is( 1, match_number( 0 ), 'match_number: 0 => 1' ) ;
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' ) ;
is( 'NA', diff_or_NA( undef, undef ), 'diff_or_NA: undef undef => NA' ) ;
is( 'NA', diff_or_NA( undef, 1 ), 'diff_or_NA: undef 1 => NA' ) ;
is( 'NA', diff_or_NA( 1, undef ), 'diff_or_NA: 1 undef => NA' ) ;
is( 'NA', diff_or_NA( 'blabla', 1 ), 'diff_or_NA: blabla 1 => NA' ) ;
is( 'NA', diff_or_NA( 1, 'blabla' ), 'diff_or_NA: 1 blabla => NA' ) ;
is( 0, diff_or_NA( 1, 1 ), 'diff_or_NA: 1 1 => 0' ) ;
is( 1, diff_or_NA( 1, 0 ), 'diff_or_NA: 1 0 => 1' ) ;
is( -1, diff_or_NA( 0, 1 ), 'diff_or_NA: 0 1 => -1' ) ;
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 homepage
{
return( 'Homepage: https://imapsync.lamiral.info/' ) ;
}
sub load_modules
{
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 ;
}
# Globals: $skipsize $wholeheaderifneeded
sub parse_header_msg
{
my ( $mysync, $imap, $m_uid, $folder, $s_heads, $s_fir, $side, $s_hash ) = @_ ;
my $head = $s_heads->{$m_uid} ;
my $headnum = scalar keys %{ $head } ;
$mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid number of headers, pass one: ", $headnum, "\n" ) ;
if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){
$mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid no header by parse_headers so taking whole header with BODY.PEEK[HEADER]\n" ) ;
$imap->fetch($m_uid, 'BODY.PEEK[HEADER]' ) ;
my $whole_header = $imap->_transaction_literals ;
#myprint( $whole_header ) ;
$head = decompose_header( $whole_header ) ;
$headnum = scalar keys %{ $head } ;
$mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid number of headers, pass two: ", $headnum, "\n" ) ;
}
#myprint( Data::Dumper->Dump( [ $head, \%useheader ] ) ) ;
my $headstr = header_construct( $mysync, $head, $side, $folder, $m_uid ) ;
if ( ( ! $headstr ) and ( $mysync->{addheader} ) and ( $side eq 'Host1' ) ) {
my $header = add_header( $m_uid ) ;
$mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid no header found so adding our own [$header]\n" ) ;
$headstr .= uc $header ;
$s_fir->{$m_uid}->{NO_HEADER} = 1;
}
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 ) ;
my $key ;
if ( $skipsize ) {
$key = "$m_md5";
}
else {
$key = "$m_md5:$size";
}
if ( exists $s_hash->{"$key"} )
{
# 0 return code is used to identify duplicate message hash
my $dup_ref = $s_hash->{"$key"}->{'U'} ;
my $num = scalar( @{ $dup_ref } ) ;
push( @{ $dup_ref }, $m_uid ) ;
my $keydup = "$key#$num" ;
$mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid sig $keydup size $size idate $idate dup @{ $dup_ref }\n" ) ;
if ( $mysync->{ syncduplicates } )
{
$s_hash->{"$keydup"}{'5'} = $m_md5 ;
$s_hash->{"$keydup"}{'s'} = $size ;
$s_hash->{"$keydup"}{'D'} = $idate ;
$s_hash->{"$keydup"}{'F'} = $flags ;
$s_hash->{"$keydup"}{'m'} = $m_uid ;
}
return 0 ;
}
else
{
$s_hash->{"$key"}{'5'} = $m_md5 ;
$s_hash->{"$key"}{'s'} = $size ;
$s_hash->{"$key"}{'D'} = $idate ;
$s_hash->{"$key"}{'F'} = $flags ;
$s_hash->{"$key"}{'m'} = $m_uid ;
$s_hash->{"$key"}{'U'} = [ $m_uid ] ; # ? or [ ] ?
$mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid sig $key size $size idate $idate\n" ) ;
return( 1 ) ;
}
# we should not be here
return ;
}
sub tests_header_construct
{
note( 'Entering tests_header_construct()' ) ;
is( undef, header_construct( ), 'header_construct: no args => undef' ) ;
my $mysync = {} ;
my $head = {
'key1' => [ 'val1_key1' ]
} ;
is( undef, header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), 'header_construct: key1 val1_key1 no useheader => undef' ) ;
$mysync->{useheader}->{ 'KEY1' } = 1 ;
is( 'KEY1: VAL1_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), 'header_construct: key1 val1_key1 => KEY1: VAL1_KEY1' ) ;
$head = {
'key1' => [ 'val1_key1', 'val3_key1', 'val2_key1' ]
} ;
is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ),
'header_construct: key1 val1_key1 val3_key1 val2_key1 => KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1' ) ;
$head = {
'key1' => [ 'val1_key1', 'val3_key1', ' val2_key1' ]
} ;
is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ),
'header_construct: key1 val1_key1 val3_key1 val2_key1 => KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1' ) ;
$mysync->{useheader}->{ 'ALL' } = 1 ;
is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ),
'header_construct: key1 val1_key1 val3_key1 val2_key1 useheader ALL => KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1' ) ;
$mysync->{skipheader} = 'key1' ;
is( undef, header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ),
'header_construct: key1 val1_key1 val3_key1 val2_key1 useheader ALL => undef' ) ;
$head = {
'key1' => [ 'val1_key1', 'val3_key1', ' val2_key1' ],
'key2' => [ 'val1_key2', 'val3_key2', ' val2_key2' ]
} ;
is( 'KEY2: VAL1_KEY2KEY2: VAL2_KEY2KEY2: VAL3_KEY2', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ),
'header_construct: ... useheader ALL skipheader key1 => KEY2: VAL1_KEY2KEY2: VAL2_KEY2KEY2: VAL3_KEY2' ) ;
note( 'Leaving tests_header_construct()' ) ;
return ;
}
# No global in header_construct
sub header_construct
{
my( $mysync, $head, $side, $folder, $m_uid ) = @_ ;
my @headstr ;
foreach my $h ( sort keys %{ $head } ) {
next if ( not ( exists $mysync->{useheader}->{ uc $h } )
and ( not exists $mysync->{useheader}->{ 'ALL' } )
) ;
foreach my $val ( @{$head->{$h}} ) {
my $H = header_line_normalize( $h, $val ) ;
# show stuff in debug mode
$mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid header [$H]", "\n" ) ;
if ( $mysync->{skipheader} and $H =~ m/$mysync->{skipheader}/xi) {
$mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid skipping header [$H]\n" ) ;
next ;
}
push @headstr, $H ;
}
}
my $headstr = join( '', sort @headstr ) || undef ;
return( $headstr ) ;
}
sub header_line_normalize
{
my( $header_key, $header_val ) = @_ ;
# no 8-bit data in headers !
$header_val =~ s/[\x80-\xff]/X/xog;
# change tabulations to space (Gmail bug on with "Received:" on multilines)
$header_val =~ s/\t/\ /xgo ;
# remove the first blanks ( dbmail bug? )
$header_val =~ s/^\s*//xo;
# remove the last blanks ( Gmail bug )
$header_val =~ s/\s*$//xo;
# remove successive blanks ( Mailenable does it )
$header_val =~ s/\s+/ /xgo;
# remove Message-Id value domain part ( Mailenable changes it )
if ( ( $messageidnodomain ) and ( 'MESSAGE-ID' eq uc $header_key ) ) { $header_val =~ s/^([^@]+).*$/$1/xo ; }
# and uppercase header line
# (dbmail and dovecot)
my $header_line = uc "$header_key: $header_val" ;
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' ) ;
note( 'Leaving tests_header_line_normalize()' ) ;
return ;
}
sub tests_firstline
{
note( 'Entering tests_firstline()' ) ;
is( q{}, firstline( 'W/tmp/tests/noexist.txt' ), 'firstline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ;
ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'firstline: mkpath W/tmp/tests/' ) ;
is( "blabla\n" , string_to_file( "blabla\n", 'W/tmp/tests/firstline.txt' ), 'firstline: put blabla in W/tmp/tests/firstline.txt' ) ;
is( 'blabla' , firstline( 'W/tmp/tests/firstline.txt' ), 'firstline: get blabla from W/tmp/tests/firstline.txt' ) ;
is( q{} , string_to_file( q{}, 'W/tmp/tests/firstline2.txt' ), 'firstline: put empty string in W/tmp/tests/firstline2.txt' ) ;
is( q{} , firstline( 'W/tmp/tests/firstline2.txt' ), 'firstline: get empty string from W/tmp/tests/firstline2.txt' ) ;
is( "\n" , string_to_file( "\n", 'W/tmp/tests/firstline3.txt' ), 'firstline: put CR in W/tmp/tests/firstline3.txt' ) ;
is( q{} , firstline( 'W/tmp/tests/firstline3.txt' ), 'firstline: get empty string from W/tmp/tests/firstline3.txt' ) ;
is( "blabla\nTiti\n" , string_to_file( "blabla\nTiti\n", 'W/tmp/tests/firstline4.txt' ), 'firstline: put blabla\nTiti\n in W/tmp/tests/firstline4.txt' ) ;
is( 'blabla' , firstline( 'W/tmp/tests/firstline4.txt' ), 'firstline: get blabla from W/tmp/tests/firstline4.txt' ) ;
note( 'Leaving tests_firstline()' ) ;
return ;
}
sub firstline
{
# extract the first line of a file (without \n)
# return empty string if error or empty string
my $file = shift @ARG ;
my $line ;
$line = nthline( $file, 1 ) ;
return $line ;
}
sub tests_secondline
{
note( 'Entering tests_secondline()' ) ;
is( q{}, secondline( 'W/tmp/tests/noexist.txt' ), 'secondline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ;
is( q{}, secondline( 'W/tmp/tests/noexist.txt', 2 ), 'secondline: 2nd getting empty string from inexisting W/tmp/tests/noexist.txt' ) ;
ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'secondline: mkpath W/tmp/tests/' ) ;
is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/secondline.txt' ), 'secondline: put L1\nL2\nL3\nL4\n in W/tmp/tests/secondline.txt' ) ;
is( 'L2' , secondline( 'W/tmp/tests/secondline.txt' ), 'secondline: get L2 from W/tmp/tests/secondline.txt' ) ;
note( 'Leaving tests_secondline()' ) ;
return ;
}
sub secondline
{
# extract the second line of a file (without \n)
# return empty string if error or empty string
my $file = shift @ARG ;
my $line ;
$line = nthline( $file, 2 ) ;
return $line ;
}
sub tests_nthline
{
note( 'Entering tests_nthline()' ) ;
is( q{}, nthline( 'W/tmp/tests/noexist.txt' ), 'nthline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ;
is( q{}, nthline( 'W/tmp/tests/noexist.txt', 2 ), 'nthline: 2nd getting empty string from inexisting W/tmp/tests/noexist.txt' ) ;
ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'nthline: mkpath W/tmp/tests/' ) ;
is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/nthline.txt' ), 'nthline: put L1\nL2\nL3\nL4\n in W/tmp/tests/nthline.txt' ) ;
is( 'L3' , nthline( 'W/tmp/tests/nthline.txt', 3 ), 'nthline: get L3 from W/tmp/tests/nthline.txt' ) ;
note( 'Leaving tests_nthline()' ) ;
return ;
}
sub nthline
{
# extract the nth line of a file (without \n)
# return empty string if error or empty string
my $file = shift @ARG ;
my $num = shift @ARG ;
if ( ! all_defined( $file, $num ) ) { return q{} ; }
my $line ;
$line = ( file_to_array( $file ) )[$num - 1] ;
if ( ! defined $line )
{
return q{} ;
}
else
{
chomp $line ;
return $line ;
}
}
sub tests_file_to_array
{
note( 'Entering tests_file_to_array()' ) ;
is( undef, file_to_array( ), 'file_to_array: no args => undef' ) ;
is( undef, file_to_array( '/noexist' ), 'file_to_array: /noexist => undef' ) ;
is( undef, file_to_array( '/' ), 'file_to_array: reading a directory => undef' ) ;
ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'file_to_array: mkpath W/tmp/tests/' ) ;
is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/file_to_array.txt' ), 'file_to_array: put L1\nL2\nL3\nL4\n in W/tmp/tests/file_to_array.txt' ) ;
is_deeply( [ "L1\n", "L2\n", "L3\n", "L4\n" ] , [ file_to_array( 'W/tmp/tests/file_to_array.txt' ) ], 'file_to_array: get back L1\n L2\n L3\n L4\n from W/tmp/tests/file_to_array.txt' ) ;
note( 'Leaving tests_file_to_array()' ) ;
return ;
}
sub file_to_array
{
my( $file ) = shift @ARG ;
if ( ! $file ) { return ; }
if ( ! -e $file ) { return ; }
if ( ! -f $file ) { return ; }
if ( ! -r $file ) { return ; }
my @string ;
if ( open my $FILE, '<', $file )
{
@string = <$FILE> ;
close $FILE ;
return( @string ) ;
}
else
{
myprint( "Error reading file $file : $OS_ERROR\n" ) ;
return ;
}
}
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 = shift @ARG ;
if ( ! $file ) { return ; }
if ( ! -e $file ) { return ; }
if ( ! -f $file ) { return ; }
if ( ! -r $file ) { return ; }
return( join q{}, file_to_array( $file ) ) ;
}
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 non-root', $NB_UNX_tests_string_to_file ) if ('MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) ;
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 ) = @_ ;
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 ;
}
0 and <<'MULTILINE_COMMENT' ;
This is a multiline comment.
Based on David Carter discussion, to do:
* Call parameters stay the same.
* Now always "return( $string, $error )". Descriptions below.
OK * Still capture STDOUT via "1> $output_tmpfile" to finish in $string and "return( $string, $error )"
OK * Now also capture STDERR via "2> $error_tmpfile" to finish in $error and "return( $string, $error )"
OK * in case of CHILD_ERROR, return( undef, $error )
and print $error, with folder/UID/maybeSubject context,
on console and at the end with the final error listing. Count this as a sync error.
* in case of good command, take final $string as is, unless void. In case $error with value then print it.
* in case of good command and final $string empty, consider it like CHILD_ERROR =>
return( undef, $error ) and print $error, with folder/UID/maybeSubject context,
on console and at the end with the final error listing. Count this as a sync error.
MULTILINE_COMMENT
# End of multiline comment.
sub pipemess
{
my ( $string, @commands ) = @_ ;
my $error = q{} ;
foreach my $command ( @commands ) {
my $input_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.inp.txt" ;
my $output_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.out.txt" ;
my $error_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.err.txt" ;
string_to_file( $string, $input_tmpfile ) ;
` $command < $input_tmpfile 1> $output_tmpfile 2> $error_tmpfile ` ;
my $is_command_ko = $CHILD_ERROR ;
my $error_cmd = file_to_string( $error_tmpfile ) ;
chomp( $error_cmd ) ;
$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 ;
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 ) {
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} ) ;
}
}
#myprint( "[$string]\n" ) ;
if ( wantarray ) {
return ( $string, $error ) ;
}else{
return $string ;
}
}
sub tests_pipemess
{
note( 'Entering tests_pipemess()' ) ;
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' ) ;
} ;
my ( $stringT, $errorT ) ;
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' ) ;
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( "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' ) ;
# success with true but no output at all
is( undef, pipemess( q{blabla}, 'true' ), 'pipemess: true but no output' ) ;
# 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 )' ) ;
( $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{\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{\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', '/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"}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"}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{\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}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{\QFailure: --pipemess command "cacaprout" ended with "0" characters exit value\E}xm,
'pipemess: list context, cacaprout not found, error' ) ;
note( 'Leaving tests_pipemess()' ) ;
return ;
}
sub tests_is_a_release_number
{
note( 'Entering tests_is_a_release_number()' ) ;
is( undef, is_a_release_number( ), 'is_a_release_number: no args => undef' ) ;
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 @ARG ;
if ( ! defined $number ) { return ; }
return( $number =~ m{^\d+\.\d+$}xo ) ;
}
sub imapsync_version_public
{
my $local_version = imapsync_version( $sync ) ;
my $imapsync_basename = imapsync_basename( ) ;
my $context = imapsync_context( ) ;
my $agent_info = "$OSNAME system, perl "
. mysprintf( '%vd', $PERL_VERSION)
. ", Mail::IMAPClient $Mail::IMAPClient::VERSION"
. " $imapsync_basename"
. " $context" ;
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 @ARG ;
if ( $fake ) { return $fake }
my $val ;
# Doesn't work with gethostbyname (see perlipc)
#local $SIG{ALRM} = sub { die "alarm\n" } ;
if ('MSWin32' eq $OSNAME) {
local $SIG{ALRM} = sub { die "alarm\n" } ;
}else{
POSIX::sigaction(SIGALRM,
POSIX::SigAction->new(sub { 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 @ARG ;
my $public_release = not_long_imapsync_version_public( $fake ) ;
$sync->{ debug } and myprint( "check_last_release: [$public_release]\n" ) ;
my $inline_help_when_on = '( Use --noreleasecheck to avoid this release check. )' ;
if ( $public_release eq 'unknown' ) {
return( 'Imapsync public release is unknown.' . $inline_help_when_on ) ;
}
if ( $public_release eq 'timeout' ) {
return( 'Imapsync public release is unknown (timeout).' . $inline_help_when_on ) ;
}
if ( ! is_a_release_number( $public_release ) ) {
return( "Imapsync public release is unknown ($public_release)." . $inline_help_when_on ) ;
}
my $imapsync_here = imapsync_version( $sync ) ;
if ( $public_release > $imapsync_here ) {
return( 'This imapsync is not up to date. ' . "( local $imapsync_here < official $public_release )" . $inline_help_when_on ) ;
}else{
return( 'This imapsync is up to date. ' . "( local $imapsync_here >= official $public_release )" . $inline_help_when_on ) ;
}
return( 'really unknown' ) ; # Should never arrive here
}
sub tests_check_last_release
{
note( 'Entering tests_check_last_release()' ) ;
diag( check_last_release( 1.1 ) ) ;
# \Q \E here to avoid putting \ before each space
like( check_last_release( 1.1 ), qr/\Qis up 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/\Qnot up to date\E/mxs, 'check_last_release: not up to date' ) ;
like( check_last_release( 999.999 ), qr/999\.999/mxs, 'check_last_release: not up to date, include number' ) ;
like( check_last_release( 'unknown' ), qr/\QImapsync public release is unknown\E/mxs, 'check_last_release: unknown' ) ;
like( check_last_release( 'timeout' ), qr/\QImapsync public release is unknown (timeout)\E/mxs, 'check_last_release: timeout' ) ;
like( check_last_release( 'lalala' ), qr/\QImapsync public release is unknown (lalala)\E/mxs, 'check_last_release: lalala' ) ;
diag( check_last_release( ) ) ;
note( 'Leaving tests_check_last_release()' ) ;
return ;
}
sub tests_imapsync_context
{
note( 'Entering tests_imapsync_context()' ) ;
like( imapsync_context( ), qr/^CGI|^Docker|^DockerCGI|^Standard/, 'imapsync_context: CGI or Docker or DockerCGI or Standard' ) ;
note( 'Leaving tests_imapsync_context()' ) ;
return ;
}
sub imapsync_context
{
my $mysync = shift @ARG ;
my $context = q{} ;
if ( under_docker_context( $mysync ) && under_cgi_context( $mysync ) )
{
$context = 'DockerCGI' ;
}
elsif ( under_docker_context( $mysync ) )
{
$context = 'Docker' ;
}
elsif ( under_cgi_context( $mysync ) )
{
$context = 'CGI' ;
}
else
{
$context = 'Standard' ;
}
return $context ;
}
sub imapsync_version
{
my $mysync = shift @ARG ;
my $rcs = $mysync->{rcs} ;
my $version ;
$version = version_from_rcs( $rcs ) ;
return( $version ) ;
}
sub tests_version_from_rcs
{
note( 'Entering tests_version_from_rcs()' ) ;
is( undef, version_from_rcs( ), 'version_from_rcs: no args => undef' ) ;
is( 1.831, version_from_rcs( q{imapsync,v 1.831 2017/08/27} ), 'version_from_rcs: imapsync,v 1.831 2017/08/27 => 1.831' ) ;
is( 'UNKNOWN', version_from_rcs( 1.831 ), 'version_from_rcs: 1.831 => UNKNOWN' ) ;
note( 'Leaving tests_version_from_rcs()' ) ;
return ;
}
sub version_from_rcs
{
my $rcs = shift @ARG ;
if ( ! $rcs ) { return ; }
my $version = 'UNKNOWN' ;
if ( $rcs =~ m{,v\s+(\d+\.\d+)}mxso ) {
$version = $1
}
return( $version ) ;
}
sub tests_imapsync_basename
{
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
{
return basename( $PROGRAM_NAME ) ;
}
sub localhost_info
{
my $mysync = shift @ARG ;
my( $infos ) = join( q{},
"Here is imapsync ", imapsync_version( $mysync ),
" on host " . hostname(),
", a $OSNAME system with ",
ram_memory_info( $mysync ),
"\n",
'with Perl ',
mysprintf( '%vd ', $PERL_VERSION),
"and Mail::IMAPClient $Mail::IMAPClient::VERSION",
) ;
return( $infos ) ;
}
sub tests_cpu_number
{
note( 'Entering tests_cpu_number()' ) ;
is( 1, is_integer( cpu_number( ) ), "cpu_number: is_integer" ) ;
ok( 1 <= cpu_number( ), "cpu_number: 1 or more" ) ;
is( 1, cpu_number( 1 ), "cpu_number: 1 => 1" ) ;
is( 1, cpu_number( $MINUS_ONE ), "cpu_number: -1 => 1" ) ;
is( 1, cpu_number( 'lalala' ), "cpu_number: lalala => 1" ) ;
is( $NUMBER_42, cpu_number( $NUMBER_42 ), "cpu_number: $NUMBER_42 => $NUMBER_42" ) ;
note( "cpu_number = " . cpu_number( ) . "\n" ) ;
note( "hostname = " . hostname( ) . "\n" ) ;
SKIP: {
if ( ! ( 'i005' eq hostname() ) )
{
skip( 'cpu_number on host != i005 (FreeBSD)', 1 ) ;
}
is( 4, cpu_number( ), "cpu_number: on i005 (FreeBSD) => 4" ) ;
} ;
SKIP: {
if ( ! ( 'petite' eq hostname() ) )
{
skip( 'cpu_number on host != petite (Linux)', 1 ) ;
}
is( 2, cpu_number( ), "cpu_number: on petite (Linux) => 2" ) ;
#is( 1, cpu_number( ), "cpu_number: on petite (Linux) => 2" ) ;
} ;
SKIP: {
if ( ! ( skip_macosx( ) ) )
{
skip( 'cpu_number on host != polarhome macosx (Darwin MacOS X 10.7.5 Lion)', 1 ) ;
}
is( 2, cpu_number( ), "cpu_number: on polarhome macosx (Darwin MacOS X 10.7.5 Lion) => 2" ) ;
} ;
SKIP: {
if ( ! ( 'pcHPDV7-HP' eq hostname() ) )
{
skip( 'cpu_number on host != pcHPDV7-HP (Windows 7, 64bits)', 1 ) ;
}
is( 2, cpu_number( ), "cpu_number: on pcHPDV7-HP (Windows 7, 64bits) => 2" ) ;
} ;
SKIP: {
if ( ! ( 'CUILLERE' eq hostname() ) )
{
skip( 'cpu_number on host != CUILLERE (Windows XP, 32bits)', 1 ) ;
}
is( 1, cpu_number( ), "cpu_number: on CUILLERE (Windows XP, 32bits) => 1" ) ;
} ;
note( 'Leaving tests_cpu_number()' ) ;
return ;
}
sub cpu_number {
my $cpu_number_forced = shift @ARG ;
# Well, here 1 is better than 0 or undef
my $cpu_number = 1 ; # Default value, erased if better found
my @cpuinfo ;
if ( $ENV{"NUMBER_OF_PROCESSORS"} )
{
# might be under a Windows system
$cpu_number = $ENV{"NUMBER_OF_PROCESSORS"} ;
#myprint( "Number of processors found by env var NUMBER_OF_PROCESSORS: $cpu_number\n" ) ;
}
if ( 'darwin' eq $OSNAME )
{
$cpu_number = backtick( "sysctl -n hw.ncpu" ) ;
chomp( $cpu_number ) ;
#myprint( "Number of processors found by cmd 'sysctl -n hw.ncpu': $cpu_number\n" ) ;
}
if ( 'freebsd' eq $OSNAME )
{
$cpu_number = backtick( "sysctl -n kern.smp.cpus" ) ;
chomp( $cpu_number ) ;
#myprint( "Number of processors found by cmd 'sysctl -n kern.smp.cpus': $cpu_number\n" ) ;
}
if ( 'linux' eq $OSNAME && -e '/proc/cpuinfo' )
{
@cpuinfo = file_to_array( '/proc/cpuinfo' ) ;
$cpu_number = grep { /^processor/mxs } @cpuinfo ;
#myprint( "Number of processors found via /proc/cpuinfo: $cpu_number\n" ) ;
}
if ( defined $cpu_number_forced )
{
$cpu_number = $cpu_number_forced ;
}
return( integer_or_1( $cpu_number ) ) ;
}
sub tests_integer_or_1
{
note( 'Entering tests_integer_or_1()' ) ;
is( 1, integer_or_1( ), 'integer_or_1: no args => 1' ) ;
is( 1, integer_or_1( undef ), 'integer_or_1: undef => 1' ) ;
is( $NUMBER_10, integer_or_1( $NUMBER_10 ), 'integer_or_1: 10 => 10' ) ;
is( 1, integer_or_1( q{} ), 'integer_or_1: empty string => 1' ) ;
is( 1, integer_or_1( 'lalala' ), 'integer_or_1: lalala => 1' ) ;
note( 'Leaving tests_integer_or_1()' ) ;
return ;
}
sub integer_or_1
{
my $number = shift @ARG ;
if ( is_integer( $number ) ) {
return $number ;
}
# else
return 1 ;
}
sub tests_is_integer
{
note( 'Entering tests_is_integer()' ) ;
is( undef, is_integer( ), 'is_integer: no args => undef ' ) ;
ok( is_integer( 1 ), 'is_integer: 1 => yes ') ;
ok( is_integer( $NUMBER_42 ), 'is_integer: 42 => yes ') ;
ok( is_integer( "$NUMBER_42" ), 'is_integer: "$NUMBER_42" => yes ') ;
ok( is_integer( '42' ), 'is_integer: "42" => yes ') ;
ok( is_integer( $NUMBER_104_857_600 ), 'is_integer: 104_857_600 => yes') ;
ok( is_integer( "$NUMBER_104_857_600" ), 'is_integer: "$NUMBER_104_857_600" => yes') ;
ok( is_integer( '104857600' ), 'is_integer: 104857600 => yes') ;
ok( ! is_integer( 'blabla' ), 'is_integer: blabla => no' ) ;
ok( ! is_integer( q{} ), 'is_integer: empty string => no' ) ;
note( 'Leaving tests_is_integer()' ) ;
return ;
}
sub is_integer
{
my $number = shift @ARG ;
if ( ! defined $number ) { return ; }
return( $number =~ m{^\d+$}xo ) ;
}
sub tests_loadavg
{
note( 'Entering tests_loadavg()' ) ;
SKIP: {
skip( 'Tests for darwin', 3 ) if ('darwin' ne $OSNAME) ;
is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ;
is_deeply(
[ '0.11', '0.22', '0.33' ],
[ loadavg( 'vm.loadavg: { 0.11 0.22 0.33 }' ) ],
'loadavg: "vm.loadavg: { 0.11 0.22 0.33 }" => 0.11 0.22 0.33'
) ;
note( join( " ", "loadavg:", loadavg( ) ) ) ;
is( 3, scalar( my @loadavg = loadavg( ) ), 'loadavg: 3 values' ) ;
} ;
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 ( 'freebsd' eq $OSNAME ) {
return ( loadavg_freebsd( @ARG ) ) ;
}
if ( 'darwin' eq $OSNAME ) {
return ( loadavg_darwin( @ARG ) ) ;
}
if ( 'MSWin32' eq $OSNAME ) {
return ( loadavg_windows( @ARG ) ) ;
}
return( 'unknown' ) ;
}
sub loadavg_linux
{
my $line = shift @ARG ;
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 ) ) {
$sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min $current_runs\n" ) ;
return ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) ;
}
return ;
}
sub loadavg_freebsd
{
my $file = shift @ARG ;
# Example of output of command "sysctl vm.loadavg":
# vm.loadavg: { 0.15 0.08 0.08 }
my $loadavg ;
if ( ! defined $file ) {
eval {
$loadavg = `LANG=C /sbin/sysctl vm.loadavg` ;
#myprint( "LOADAVG FREEBSD: $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 ;
$sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min\n" ) ;
return ( $avg_1_min, $avg_5_min, $avg_15_min ) ;
}
sub loadavg_darwin
{
my $line = shift @ARG ;
# Example of output of command "sysctl vm.loadavg":
# vm.loadavg: { 0.15 0.08 0.08 }
my $loadavg ;
if ( ! defined $line ) {
eval {
# $loadavg = `/usr/sbin/sysctl vm.loadavg` ;
$loadavg = `LANG=C /usr/sbin/sysctl vm.loadavg` ;
#myprint( "LOADAVG DARWIN: $loadavg\n" ) ;
} ;
if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; }
}else{
$loadavg = $line ;
}
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 ;
#$sync->{ debug } and myprint( "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 @ARG ;
# 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 ;
$sync->{ 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, 2 ), 'load_and_delay: not 3 args => undef ' ) ;
is( undef, load_and_delay( 2, 0, 1, 1, 1 ), 'load_and_delay: division per 0 => undef ' ) ;
# ( $max_load_per_core, $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min )
# load max = 1 per cpu
is( 0, load_and_delay( 1, 1, 0 ), 'load_and_delay: max=1, one core, loads is 0 => ok ' ) ;
is( 0, load_and_delay( 1, 1, 0, 0, 0 ), 'load_and_delay: max=1, one core, loads are all 0 => ok ' ) ;
is( 0, load_and_delay( 3, 1, 1, 1, 1, 1 ), 'load_and_delay: six arguments => ok' ) ;
is( 0, load_and_delay( 1, 2, 1, 1, 1 ), 'load_and_delay: max=1, two core, loads are all 1 => ok ' ) ;
is( 0, load_and_delay( 1, 2, 1, 4, 5 ), 'load_and_delay: max=1, two core, load1m is 1 => ok ' ) ;
is( 0, load_and_delay( 1, 1, 0, 0, 0 ), 'load_and_delay: max=1, one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ;
is( 0, load_and_delay( 1, 1, 0, 0, 2 ), 'load_and_delay: max=1, one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ;
is( 0, load_and_delay( 1, 1, 0, 2, 0 ), 'load_and_delay: max=1, one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ;
is( 0, load_and_delay( 1, 1, 0, 2, 2 ), 'load_and_delay: max=1, one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ;
is( 0, load_and_delay( 1, 1, 0, 3, 3 ), 'load_and_delay: max=1, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ;
is( 0, load_and_delay( 1, 1, 0, 4, 4 ), 'load_and_delay: max=1, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ;
is( 0, load_and_delay( 1, 1, .2, 0, 0 ), 'load_and_delay: max=1, one core, load1m=.2 load5m=0 load15m=0 => 0 ' ) ;
is( 0, load_and_delay( 1, 1, .2, 0, .2 ), 'load_and_delay: max=1, one core, load1m=.2 load5m=0 load15m=.2 => 0 ' ) ;
is( 0, load_and_delay( 1, 1, .2, .2, 0 ), 'load_and_delay: max=1, one core, load1m=2 load5m=2 load15m=0 => 0 ' ) ;
is( 0, load_and_delay( 1, 1, .2, .2, .2 ), 'load_and_delay: max=1, one core, load1m=.2 load5m=.2 load15m=.2 => 0 ' ) ;
is( 1, load_and_delay( 1, 1, 1, 0, 0 ), 'load_and_delay: max=1, one core, load1m=3 load5m=0 load15m=0 => 0 ' ) ;
is( 1, load_and_delay( 1, 1, 1, .9, .9 ), 'load_and_delay: max=1, one core, load1m=3 load5m=.9 load15m=.9 => 0 ' ) ;
is( 5, load_and_delay( 1, 1, 1, 1, .9 ), 'load_and_delay: max=1, one core, load1m=3 load5m=3 load15m=.9 => 5 ' ) ;
is( 15, load_and_delay( 1, 1, 1, 1, 1 ), 'load_and_delay: max=1, one core, load1m=3 load5m=3 load15m=3 => 15 ' ) ;
is( 0, load_and_delay( 1, 1, .9, .9, .9 ), 'load_and_delay: max=1, one core, load1m=.9 load5m=.9 load15m=.9 => 0 ' ) ;
# load max = 3 per cpu
is( 0, load_and_delay( 3, 1, 1, 1, 1 ), 'load_and_delay: max=3, one core, loads are all 1 => ok ' ) ;
is( 0, load_and_delay( 3, 2, 2, 2, 2 ), 'load_and_delay: max=3, two core, loads are all 2 => ok ' ) ;
is( 0, load_and_delay( 3, 2, 2, 4, 5 ), 'load_and_delay: max=3, two core, load1m is 2 => ok ' ) ;
is( 0, load_and_delay( 3, 1, 0, 0, 0 ), 'load_and_delay: max=3, one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ;
is( 0, load_and_delay( 3, 1, 0, 0, 2 ), 'load_and_delay: max=3, one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ;
is( 0, load_and_delay( 3, 1, 0, 2, 0 ), 'load_and_delay: max=3, one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ;
is( 0, load_and_delay( 3, 1, 0, 2, 2 ), 'load_and_delay: max=3, one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ;
is( 0, load_and_delay( 3, 1, 0, 3, 3 ), 'load_and_delay: max=3, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ;
is( 0, load_and_delay( 3, 1, 0, 4, 4 ), 'load_and_delay: max=3, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ;
is( 0, load_and_delay( 3, 1, 2, 0, 0 ), 'load_and_delay: max=3, one core, load1m=2 load5m=0 load15m=0 => 0 ' ) ;
is( 0, load_and_delay( 3, 1, 2, 0, 2 ), 'load_and_delay: max=3, one core, load1m=2 load5m=0 load15m=2 => 0 ' ) ;
is( 0, load_and_delay( 3, 1, 2, 2, 0 ), 'load_and_delay: max=3, one core, load1m=2 load5m=2 load15m=0 => 0 ' ) ;
is( 0, load_and_delay( 3, 1, 2, 2, 2 ), 'load_and_delay: max=3, one core, load1m=2 load5m=2 load15m=2 => 0 ' ) ;
is( 1, load_and_delay( 3, 1, 3, 0, 0 ), 'load_and_delay: max=3, one core, load1m=3 load5m=0 load15m=0 => 0 ' ) ;
is( 1, load_and_delay( 3, 1, 3, 2.9, 2.9 ), 'load_and_delay: max=3, one core, load1m=3 load5m=2.9 load15m=2.9 => 0 ' ) ;
is( 5, load_and_delay( 3, 1, 3, 3, 2.9 ), 'load_and_delay: max=3, one core, load1m=3 load5m=3 load15m=2.9 => 0 ' ) ;
is( 15, load_and_delay( 3, 1, 3, 3, 3 ), 'load_and_delay: max=3, one core, load1m=3 load5m=3 load15m=3 => 0 ' ) ;
is( 0, load_and_delay( 3, 1, 2.9, 2.9, 2.9 ), 'load_and_delay: max=3, one core, load1m=2.9 load5m=2.9 load15m=2.9 => 0 ' ) ;
is( 1, load_and_delay( 6, 1, 6, 0, 0 ), 'load_and_delay: max=6, one core, load1m=6 load5m=0 load15m=0 => 1 ' ) ;
is( 1, load_and_delay( 6, 1, 6, 5.9, 5.9 ), 'load_and_delay: max=6, one core, load1m=6 load5m=5.9 load15m=5.9 => 1 ' ) ;
is( 5, load_and_delay( 6, 1, 6, 6, 5.9 ), 'load_and_delay: max=6, one core, load1m=6 load5m=6 load15m=5.9 => 5 ' ) ;
is( 15, load_and_delay( 6, 1, 6, 6, 6 ), 'load_and_delay: max=6, one core, load1m=6 load5m=6 load15m=6 => 15 ' ) ;
is( 0, load_and_delay( 6, 1, 5.9, 5.9, 5.9 ), 'load_and_delay: max=6, one core, load1m=5.9 load5m=5.9 load15m=5.9 => 1 ' ) ;
note( 'Leaving tests_load_and_delay()' ) ;
return ;
}
sub load_and_delay
{
# Basically return 0 if load is not heavy, ie load 1 min <= $max_load_per_core
# 5 arguments at least (loadavg return 4 arguments like "0.19 0.16 0.17 3/444" )
if ( 3 > scalar @ARG ) { return ; }
my ( $max_load_per_core, $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) = @ARG ;
if ( 0 == $cpu_num ) { return ; }
# No avg_5_min nor avg_15_min on Windows
$avg_5_min ||= 0 ;
$avg_15_min ||= 0 ;
# Let divide by number of cores
( $avg_1_min, $avg_5_min, $avg_15_min ) = map { $_ / $cpu_num } ( $avg_1_min, $avg_5_min, $avg_15_min ) ;
# If one period 1m is ok => ok ( 0 ) else Nok ( return > 0, 1 or 5 or 15 )
if ( $avg_1_min < $max_load_per_core ) { return 0 ; }
if ( $avg_5_min < $max_load_per_core ) { return 1 ; } # Message: retry in 1 minute
if ( $avg_15_min < $max_load_per_core ) { return 5 ; } # Message: retry in 5 minutes
return 15 ; # Message: retry in 15 minutes
}
sub tests_cpu_time
{
note( 'Entering tests_cpu_time()' ) ;
ok( is_number( cpu_time( ) ), 'cpu_time: no args => a number' ) ;
my $mysync = { } ;
$mysync->{ debug } = 1 ;
ok( is_number( cpu_time( $mysync ) ), 'cpu_time: {} => a number' ) ;
note( 'Leaving tests_cpu_time()' ) ;
return ;
}
sub cpu_time
{
my $mysync = shift @ARG ;
my @cpu_times = times ;
if ( ! @cpu_times ) { return ; }
my $cpu_time = 0 ;
# last element is the sum of all elements
$cpu_time = ( map { $cpu_time += $_ } @cpu_times )[ -1 ] ;
my $cpu_time_rounded = mysprintf( '%.2f', $cpu_time ) ;
$mysync->{ debug } and myprint( join(' + ', @cpu_times), " = $cpu_time ~ $cpu_time_rounded\n" ) ;
return $cpu_time ;
}
sub tests_cpu_percent
{
note( 'Entering tests_cpu_percent()' ) ;
is( '0.0', cpu_percent( ), 'cpu_percent: no args => 0.0' ) ;
my $mysync = { } ;
$mysync->{ debug } = 1 ;
is( '0.0', cpu_percent( $mysync ), 'cpu_percent: {} => 0.0' ) ;
is( '0.0', cpu_percent( $mysync, 0 ), 'cpu_percent: {} 0 => 0.0' ) ;
is( '300.0', cpu_percent( $mysync, 3 ), 'cpu_percent: {} 3 => 300.0' ) ;
is( '30.0', cpu_percent( $mysync, 3, 10 ), 'cpu_percent: {} 3 10 => 30.0' ) ;
is( '0.0', cpu_percent( $mysync, 0, 10 ), 'cpu_percent: {} 0 10 => 0.0' ) ;
note( 'Leaving tests_cpu_percent()' ) ;
return ;
}
sub cpu_percent
{
my $mysync = shift @ARG ;
my $cpu_time = shift || 0 ;
my $timediff = shift || 1 ; # no division by 0
if ( $cpu_time > $timediff )
{
myprint( "Strange: cpu_time $cpu_time > timediff $timediff\n" ) ;
}
my $cpu_percent = 0 ;
$cpu_percent = mysprintf( '%.1f', 100 * $cpu_time / $timediff ) ;
$mysync->{ debug } and myprint( "cpu_percent: $cpu_percent \n" ) ;
return $cpu_percent ;
}
sub tests_cpu_percent_global
{
note( 'Entering tests_cpu_percent_global()' ) ;
is( '0.0', cpu_percent_global( ), 'cpu_percent_global: no args => 0' ) ;
my $mysync = { } ;
$mysync->{ debug } = 1 ;
is( '0.0', cpu_percent_global( $mysync ), 'cpu_percent_global: {} => 0' ) ;
is( '0.0', cpu_percent_global( $mysync, 0 ), 'cpu_percent_global: {} 0 => 0' ) ;
SKIP: {
if ( ! ( 'i005' eq hostname() ) )
{
skip( 'cpu_percent_global on host != i005', 1 ) ;
}
is( '25.0', cpu_percent_global( $mysync, 100 ), 'cpu_percent_global: {} 100 => 25 on host i005' ) ;
} ;
SKIP: {
if ( ! ( 'petite' eq hostname() ) )
{
skip( 'cpu_percent_global on host != petite', 1 ) ;
}
is( '50.0', cpu_percent_global( $mysync, 100 ), 'cpu_percent_global: {} 100 => 50 on host petite' ) ;
#is( '100.0', cpu_percent_global( $mysync, 100 ), 'cpu_percent_global: {} 100 => 100 on host petite' ) ;
} ;
note( 'Leaving tests_cpu_percent_global()' ) ;
return ;
}
sub cpu_percent_global
{
my $mysync = shift @ARG ;
my $cpu_percent = shift || 0 ;
my $cpu_number = cpu_number( ) ;
my $cpu_percent_global ;
$cpu_percent_global = mysprintf( '%.1f', $cpu_percent / $cpu_number ) ;
$mysync->{ debug } and myprint( "cpu_percent_global: $cpu_percent_global \n" ) ;
return( $cpu_percent_global ) ;
}
sub tests_ram_memory_info
{
note( 'Entering tests_ram_memory_info()' ) ;
note( "ram_memory_info:", ram_memory_info( ) ) ;
note( "total_ram_memory_bytes_sys_meminfo:", total_ram_memory_bytes_sys_meminfo( ) ) ;
#note( "total_ram_memory_bytes_hw_memsize:", total_ram_memory_bytes_hw_memsize( ) ) ;
ok( ram_memory_info( ), 'ram_memory_info: => some text' ) ;
note( 'Leaving tests_ram_memory_info()' ) ;
return ;
}
sub total_ram_memory_bytes
{
my $total_ram_memory_bytes ;
# Found Sys::MemInfo::get( "totalmem" )
# wrong on macOS 11.5.2 (20G95)
# good on Mac OS X 10.7.5 (11G63)
# ( commands "sw_vers" or "system_profiler SPSoftwareDataType" )
if ( 'darwin' eq $OSNAME )
{
$total_ram_memory_bytes = total_ram_memory_bytes_hw_memsize( ) ;
}
else
{
$total_ram_memory_bytes = total_ram_memory_bytes_sys_meminfo( ) ;
}
}
sub total_ram_memory_bytes_hw_memsize
{
my $total_ram_memory_bytes = `sysctl -n hw.memsize` ;
chomp $total_ram_memory_bytes ;
return $total_ram_memory_bytes ;
}
sub total_ram_memory_bytes_sys_meminfo
{
my $total_ram_memory_bytes = Sys::MemInfo::get( "totalmem" ) ;
return $total_ram_memory_bytes ;
}
sub ram_memory_info
{
my $mysync = shift @ARG ;
# In GigaBytes so division by 1024 * 1024 * 1024
#
my $ram_memory_info = sprintf(
"%.1f/%.1f free GiB of RAM",
Sys::MemInfo::get("freemem") / ( $KIBI ** 3 ),
total_ram_memory_bytes( ) / ( $KIBI ** 3 ),
) ;
my $memory_consumption_all_pids_percent = memory_consumption_all_pids_percent( $mysync ) || 0 ;
if ( $memory_consumption_all_pids_percent )
{
$ram_memory_info .= ", $memory_consumption_all_pids_percent% used by processes."
}
return $ram_memory_info ;
}
sub tests_memory_stress
{
note( 'Entering tests_memory_stress()' ) ;
my $mysync = { } ;
sig_install( $mysync, 'catch_ignore', ( 'QUIT', 'TERM', 'INT' ) ) ;
is( undef, memory_stress( ), 'memory_stress: => undef' ) ;
note( 'Leaving tests_memory_stress()' ) ;
return ;
}
sub memory_stress
{
my $total_ram_in_MB = total_ram_memory_bytes( ) / ( $KIBI * $KIBI ) ;
my $i = 1 ;
myprintf("Stress memory consumption before: %.1f MiB of %.1f MiB\n", memory_consumption_of_myself( ) / $KIBI / $KIBI, $total_ram_in_MB ) ;
while ( $i < $total_ram_in_MB / 1.7 )
{
$a .= "A" x 1000_000;
myprintf( "$i " ) ;
$i++ ;
} ;
myprintf( "\nStress memory consumption after: %.1f MiB of %.1f MiB\n", memory_consumption_of_myself( ) / $KIBI / $KIBI, $total_ram_in_MB ) ;
return ;
}
sub tests_memory_consumption_of_myself
{
note( 'Entering tests_memory_consumption_of_myself()' ) ;
note( "memory_consumption_of_myself: " . memory_consumption_of_myself( ) . " bytes aka " . bytes_display_string_dec( memory_consumption_of_myself( ) ) ) ;
like( memory_consumption_of_myself( ), qr{\d+}xms,'tests_memory_consumption_of_myself no args') ;
like( memory_consumption_of_myself( 1 ), qr{\d+}xms,'tests_memory_consumption_of_myself 1') ;
like( memory_consumption_of_myself( $PROCESS_ID ), qr{\d+}xms,"tests_memory_consumption_of_myself $PROCESS_ID") ;
note( 'Leaving tests_memory_consumption_of_myself()' ) ;
return ;
}
sub memory_consumption_of_myself
{
# memory consumed by imapsync until now in bytes
return( ( memory_consumption_of_pids( ) )[0] );
}
sub debugmemory
{
my $mysync = shift @ARG ;
if ( ! $mysync->{ debugmemory } ) { return q{} ; }
my $precision = shift @ARG ;
return( mysprintf( "Memory consumption$precision: %.1f MiB\n", memory_consumption_of_myself( ) / $KIBI / $KIBI ) ) ;
}
sub memory_consumption_of_pids
{
my @pid = @ARG ;
# No pid in ARG means find myself memory
@pid = ( @pid ) ? @pid : ( $PROCESS_ID ) ;
#$sync->{ debug } and myprint( "memory_consumption_of_pids PIDs: @pid\n" ) ;
my @val ;
if ( ( 'MSWin32' eq $OSNAME ) or ( 'cygwin' eq $OSNAME ) )
{
@val = memory_consumption_of_pids_win32( @pid ) ;
}
else
{
# Unix, Mac OS X included
@val = memory_consumption_of_pids_unix( @pid ) ;
}
return( @val ) ;
}
sub memory_consumption_of_pids_unix
{
my @pid = @_ ;
# Use IPC::Open3 from perlcrit -3
# But it stalls on Darwin, I don't understand why!
#my @ps = backtick( "ps -o rss -p @pid" ) ;
#myprint( "ps: @ps" ) ;
my @ps = qx{ ps -o rss -p @pid } ;
shift @ps ; # First line is the column name "RSS"
chomp @ps ;
# convert to octets
my @val = map { $_ * $KIBI } @ps ;
return( @val ) ;
}
sub tests_memory_consumption_of_all_pids
{
note( 'Entering tests_memory_consumption_of_all_pids()' ) ;
note( "memory_consumption_of_all_pids: " . memory_consumption_of_all_pids( ) . " bytes aka " . bytes_display_string_dec( memory_consumption_of_all_pids( ) ) ) ;
like( memory_consumption_of_all_pids( ), qr{\d+}xms, 'tests_memory_consumption_of_all_pids no args') ;
note( 'Leaving tests_memory_consumption_of_all_pids()' ) ;
return ;
}
sub memory_consumption_of_all_pids
{
my @all_pids = all_pids( ) ;
my @memory_consumption_of_all_pids = memory_consumption_of_pids( @all_pids ) ;
my $memory_consumption_of_all_pids = add( @memory_consumption_of_all_pids ) ;
return $memory_consumption_of_all_pids ;
}
sub tests_all_pids
{
note( 'Entering tests_all_pids()' ) ;
note( 'all_pids', join( ' ', all_pids( ) ) ) ;
ok( all_pids( ), 'tests_all_pids: no args => list of pids' ) ;
note( 'Leaving tests_all_pids()' ) ;
return ;
}
sub all_pids
{
my @all_pids ;
if ( ( 'MSWin32' eq $OSNAME ) or ( 'cygwin' eq $OSNAME ) ) {
@all_pids = all_pids_win32( ) ;
}
else
{
# Unix
@all_pids = all_pids_unix( ) ;
}
return( @all_pids ) ;
}
sub all_pids_unix
{
my @ps = qx{ ps -e -o pid } ;
shift @ps ; # First line is the column name "PID"
chomp @ps ;
return @ps ;
}
sub tests_memory_consumption_of_pids_win32
{
note( 'Entering tests_memory_consumption_of_pids_win32()' ) ;
note( memory_consumption_of_pids_win32( $PROCESS_ID ) ) ;
#ok( memory_consumption_of_pids_win32( $PROCESS_ID ), 'tests_memory_consumption_of_pids_win32: no args => ' ) ;
note( 'Leaving tests_memory_consumption_of_pids_win32()' ) ;
return ;
}
sub memory_consumption_of_pids_win32
{
# Windows
my @PID = @_;
my %PID;
# hash of pids as key values
map { $PID{$_}++ } @PID;
# Does not work but should work reading the tasklist documentation
#@ps = qx{ tasklist /FI "PID eq @PID" };
my @ps = qx{ tasklist /NH /FO TABLE } ;
#my @ps = backtick( 'tasklist /NH /FO TABLE' ) ;
#myprint( "-" x $STD_CHAR_PER_LINE, "\n", @ps, "-" x $STD_CHAR_PER_LINE, "\n" ) ;
my @val ;
#myprint( @ps ) ;
foreach my $line ( @ps ) {
my( $name, $pid, $mem ) = ( split / +/, $line )[ 0, 1, 4 ] ;
next if (! $pid);
#myprint( "[$name][$pid][$mem]\n" ) ;
$pid = remove_qq( $pid ) ;
if ( $PID{ $pid } )
{
#myprint( "MATCH $pid\n" ) ;
chomp $mem ;
$mem = remove_qq( $mem ) ;
$mem = remove_not_num( $mem ) ;
if ( is_number( $mem ) )
{
#myprint( "[$mem] ", $mem * $KIBI, "\n" ) ;
push @val, $mem * $KIBI ;
}
}
}
return( @val ) ;
}
sub all_pids_win32
{
my @ps = qx{ tasklist /NH /FO CSV } ;
my @pids ;
foreach my $line ( @ps )
{
my( $name, $pid, $mem ) = ( split ',', $line )[ 0, 1, 4 ] ;
next if ( ! $pid ) ;
#myprint( "[$name][$pid][$mem]\n" ) ;
$pid = remove_qq( $pid ) ;
push @pids, $pid ;
}
return( @pids ) ;
}
sub tests_memory_consumption_all_pids_percent
{
note( 'Entering tests_memory_consumption_all_pids_percent()' ) ;
note( memory_consumption_all_pids_percent( ) . " (%)" ) ;
like( memory_consumption_all_pids_percent( ), qr{^0|^(\d+\.\d+)$}xms, 'tests_memory_consumption_all_pids_percent: no args => like 12.34' ) ;
ok( 0 <= memory_consumption_all_pids_percent( ), 'tests_memory_consumption_all_pids_percent: > 0' ) ;
ok( 100 >= memory_consumption_all_pids_percent( ), 'tests_memory_consumption_all_pids_percent: <= 100' ) ;
note( 'Leaving tests_memory_consumption_all_pids_percent()' ) ;
return ;
}
sub memory_consumption_all_pids_percent
{
my $percent ;
my $memory_consumption_of_all_pids = memory_consumption_of_all_pids( ) ;
my $total_memory_bytes = total_ram_memory_bytes( ) || return 0 ;
$percent = sprintf( "%.2f", 100 * $memory_consumption_of_all_pids / $total_memory_bytes ) ;
return $percent ;
}
sub tests_memory_consumption_all_pids_percent_Proc_ProcessTable
{
note( 'Entering tests_memory_consumption_all_pids_percent_Proc_ProcessTable()' ) ;
require_ok( 'Proc::ProcessTable' ) ;
note( memory_consumption_all_pids_percent_Proc_ProcessTable( ) . " (%)" ) ;
like( memory_consumption_all_pids_percent_Proc_ProcessTable( ), qr{^0|^(\d+\.\d+)$}xms, 'tests_memory_consumption_all_pids_percent_Proc_ProcessTable: no args => like 12.34' ) ;
my $mysync = { } ;
like( memory_consumption_all_pids_percent_Proc_ProcessTable( $mysync ), qr{^0|^(\d+\.\d+)$}xms, 'tests_memory_consumption_all_pids_percent_Proc_ProcessTable: { } => like 12.34' ) ;
note( 'Leaving tests_memory_consumption_all_pids_percent_Proc_ProcessTable()' ) ;
return ;
}
# Proc::ProcessTable pctmem does NOT work for Win32 Darwin
# Negative values and negative zeros for Darwin
# zeros for Win32
#
sub memory_consumption_all_pids_percent_Proc_ProcessTable
{
my $mysync = shift @ARG ;
my $percent ;
if ( eval { require Proc::ProcessTable } )
{
my $table_all_processes = Proc::ProcessTable->new( ) ;
if ( pctmem_available( $table_all_processes ) )
{
#pctmem is memory percentage of a process
foreach my $process ( @{ $table_all_processes->table( ) } )
{
#myprint( "pctmem: ", $process->pctmem( ), "\n" ) ;
#
$percent += max( 0, $process->pctmem( ) ) ;
}
}
else
{
$percent = 0 ;
}
}
else
{
$percent = 0 ;
}
$percent = sprintf( "%.2f", $percent ) ;
return $percent ;
}
sub tests_pctmem_available
{
note( 'Entering tests_pctmem_available()' ) ;
is( undef, pctmem_available( ), 'pctmem_available: no args => undef' ) ;
SKIP: {
skip( 'no Proc::ProcessTable', 1 ) if ( ! eval { require Proc::ProcessTable } ) ;
my $table_all_processes = Proc::ProcessTable->new( ) ;
like( pctmem_available( $table_all_processes ), qr{^(0|1)$}xms, 'pctmem_available: => 0 or 1' ) ;
}
note( 'Leaving tests_pctmem_available()' ) ;
return ;
}
sub pctmem_available
{
my $table_all_processes = shift @ARG ;
if ( ! defined $table_all_processes ) { return ; } ;
my @fields = $table_all_processes->fields( ) ;
my %fields = map { defined( $_ ) ? ( $_ => 1 ) : ( ) } @fields ;
if ( exists( $fields{ pctmem } ) )
{
return 1 ;
}
else
{
return 0 ;
}
return ;
}
sub tests_backtick
{
note( 'Entering tests_backtick()' ) ;
is( undef, backtick( ), 'backtick: no args' ) ;
is( undef, backtick( q{} ), 'backtick: empty command' ) ;
SKIP: {
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!' ) ;
$sync->{ 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' ) ;
$sync->{ 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( '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!' ) ;
$sync->{ 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' ) ;
$sync->{ 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' ) ;
my $mem = backtick( "ps -o vsz -p $PROCESS_ID" ) ;
$sync->{ debug } and myprint( "MEM=$mem\n" ) ;
}
note( 'Leaving tests_backtick()' ) ;
return ;
}
sub backtick
{
my $command = shift @ARG ;
if ( ! $command ) { return ; }
my ( $writer, $reader, $err ) ;
my @output ;
my $pid ;
my $eval = eval {
$pid = IPC::Open3::open3( $writer, $reader, $err, $command ) ;
} ;
if ( $EVAL_ERROR ) {
myprint( $EVAL_ERROR ) ;
return ;
}
if ( ! $eval ) { return ; }
if ( ! $pid ) { return ; }
waitpid( $pid, 0 ) ;
@output = <$reader>; # Output here
#
#my @errors = <$err>; #Errors here, instead of the console
if ( not @output ) { return ; }
#myprint( @output ) ;
if ( $output[0] =~ /\Qopen3: exec of $command failed\E/mxs ) { return ; }
if ( wantarray ) {
return( @output ) ;
} else {
return( join( q{}, @output) ) ;
}
}
sub tests_check_binary_embed_all_dyn_libs
{
note( 'Entering tests_check_binary_embed_all_dyn_libs()' ) ;
is( 1, check_binary_embed_all_dyn_libs( ), 'check_binary_embed_all_dyn_libs: no args => 1' ) ;
note( 'Leaving tests_check_binary_embed_all_dyn_libs()' ) ;
return ;
}
sub check_binary_embed_all_dyn_libs
{
my @search_dyn_lib_locale = search_dyn_lib_locale( ) ;
if ( @search_dyn_lib_locale )
{
myprint( "Found myself $PROGRAM_NAME pid $PROCESS_ID using locale dynamic libraries that seems out of myself:\n" ) ;
myprint( @search_dyn_lib_locale ) ;
if ( $PROGRAM_NAME =~ m{imapsync_bin_Darwin} )
{
return 0 ;
}
elsif ( $PROGRAM_NAME =~ m{imapsync.*\.exe} )
{
return 0 ;
}
else
{
# is always ok for non binary
return 1 ;
}
}
else
{
# Found only embedded dynamic lib
myprint( "Found only embedded dynamic lib. Good!\n" ) ;
return 1 ;
}
}
sub search_dyn_lib_locale
{
if ( 'darwin' eq $OSNAME )
{
return search_dyn_lib_locale_darwin( ) ;
}
if ( 'linux' eq $OSNAME )
{
return search_dyn_lib_locale_linux( ) ;
}
if ( 'MSWin32' eq $OSNAME )
{
return search_dyn_lib_locale_MSWin32( ) ;
}
}
sub search_dyn_lib_locale_darwin
{
my $command = qq{ lsof -p $PROCESS_ID | grep ' REG ' | grep .dylib | grep -v '/par-' } ;
myprint( "Search non embeded dynamic libs with the command: $command\n" ) ;
return backtick( $command ) ;
}
sub search_dyn_lib_locale_linux
{
my $command = qq{ lsof -p $PROCESS_ID | grep ' REG ' | grep -v '/tmp/par-' | grep '\.so' } ;
myprint( "Search non embeded dynamic libs with the command: $command\n" ) ;
return backtick( $command ) ;
}
sub search_dyn_lib_locale_MSWin32
{
my $command = qq{ Listdlls.exe $PROCESS_ID|findstr Strawberry } ;
# $command = qq{ Listdlls.exe $PROCESS_ID|findstr Strawberry } ;
myprint( "Search non embeded dynamic libs with the command: $command\n" ) ;
return qx( $command ) ;
}
sub remove_not_num
{
my $string = shift @ARG ;
$string =~ tr/0-9//cd ;
#myprint( "tr [$string]\n" ) ;
return( $string ) ;
}
sub tests_remove_not_num
{
note( 'Entering tests_remove_not_num()' ) ;
is( '123', remove_not_num( 123 ), 'remove_not_num( 123 )' ) ;
is( '123', remove_not_num( '123' ), q{remove_not_num( '123' )} ) ;
is( '123', remove_not_num( '12 3' ), q{remove_not_num( '12 3' )} ) ;
is( '123', remove_not_num( 'a 12 3 Ko' ), q{remove_not_num( 'a 12 3 Ko' )} ) ;
is( '123', remove_not_num( 'a 12 3 K' ), q{remove_not_num( 'a 12 3 K' )} ) ;
is( '123', remove_not_num( 'a 12,3 K' ), q{remove_not_num( 'a 12, 3 K' )} ) ;
is( '173892', remove_not_num( 'a 173,892 K' ), q{remove_not_num( 'a 173,892 K' )} ) ;
note( 'Leaving tests_remove_not_num()' ) ;
return ;
}
sub tests_remove_qq
{
note( 'Entering tests_remove_qq()' ) ;
is( undef, remove_qq( ), 'tests_remove_qq: no args => undef' ) ;
is( '', remove_qq( '' ), 'tests_remove_qq: empty => empty' ) ;
is( 'ABC', remove_qq( 'ABC' ), 'tests_remove_qq: ABC => ABC' ) ;
is( 'ABC', remove_qq( '"ABC"' ), 'tests_remove_qq: "ABC" => ABC' ) ;
is( '"ABC', remove_qq( '""ABC"' ), 'tests_remove_qq: ""ABC" => "ABC' ) ;
is( 'ABC"', remove_qq( '"ABC""' ), 'tests_remove_qq: "ABC"" => ABC"' ) ;
is( '"ABC"', remove_qq( '""ABC""' ), 'tests_remove_qq: ""ABC"" => "ABC"' ) ;
note( 'Leaving tests_remove_qq()' ) ;
return ;
}
sub remove_qq
{
my $string = shift ;
if ( ! defined $string ) { return ; }
#myprint( "$string\n" ) ;
if ( $string =~ /^"(.*)"$/xo )
{
return( $1 ) ;
}else{
return( $string ) ;
}
}
sub date_from_rcs
{
my $d = shift @ARG ;
my %num2mon = qw( 01 Jan 02 Feb 03 Mar 04 Apr 05 May 06 Jun 07 Jul 08 Aug 09 Sep 10 Oct 11 Nov 12 Dec ) ;
if ($d =~ m{(\d{4})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) {
# Handles the following format
# 2015/07/10 11:05:59 -- Generated by RCS Date tag.
#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 ) ;
}
sub tests_date_from_rcs
{
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
# outgoing format: internal date format
# 24-Aug-2010 16:00:00 +0200
my $d = shift @ARG ;
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 ;
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
# 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
# Tue, 24 Aug 1997 16.00.00 +0200 -- Periods instead of colons
# Tue, 24 Aug 1997 16:00:00 +0200 -- Extra whitespace between year and hour
# Tue, 24 Aug 1997 6:5:2 +0200 -- Single digit hour, min, or second
# Tue, 24, Aug 1997 16:00:00 +0200 -- Extra comma
#myprint( "header: [$1][$2][$3][$4][$5][$6][$7][$8]\n" ) ;
my ($day, $month, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7,$8);
$year = '19' . $year if length($year) == 2 && $year =~ m/^[789]/xo;
$year = '20' . $year if length($year) == 2;
$month = substr $month, 0, 3 if length($month) > 4;
$day = mysprintf( '%02d', $day);
$hour = mysprintf( '%02d', $hour);
$min = mysprintf( '%02d', $min);
$sec = '00' if not defined $sec ;
$sec = mysprintf( '%02d', $sec ) ;
$zone = '+0000' if not defined $zone ;
$d = "$day-$month-$year $hour:$min:$sec $zone" ;
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
# Sun Aug 20 11:55:09 2006
# Wed Jan 24 11:58:38 MST 2007
# Wed Jan 2 08:40:57 2008
#myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ;
my ($month, $day, $hour, $min, $sec, $year) = ($1,$2,$3,$4,$5,$6);
$day = mysprintf( '%02d', $day ) ;
$hour = mysprintf( '%02d', $hour ) ;
$min = mysprintf( '%02d', $min ) ;
$sec = mysprintf( '%02d', $sec ) ;
$d = "$day-$month-$year $hour:$min:$sec +0000" ;
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( "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 ;
}
if ($d =~ m{(\d{2})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) {
# Handles the following format
# 02/06/09 22:18:08 -- Generated by AVTECH TemPageR devices
#myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ;
my ($month, $day, $year, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6);
$year = '20' . $year;
$month = $num2mon{$month};
$d = "$day-$month-$year $hour:$min:$sec +0000";
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
# Saturday, December 14, 2002 05:00 PM - KBtoys.com order confirmations
my ($month, $day, $year, $hour, $min, $apm) = ($1,$2,$3,$4,$5,$6);
$hour += 12 if $apm eq 'PM' ;
$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
# 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);
$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
# 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 ;
}
# unknown or unmatch => return same string
return($d);
}
$d = qq("$d") ;
return( $d ) ;
}
sub tests_good_date
{
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');
ok('"24-Jan-2007 11:58:38 +0000"' eq good_date('Wed Jan 24 11:58:38 MST 2007'), 'good_date header status-now.com');
ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24 Aug 2010 16:00:00 +0200'), 'good_date header missing date of week');
ok('"24-Aug-2067 16:00:00 +0200"' eq good_date('Tue, 24 Aug 67 16:00:00 +0200'), 'good_date header 2digit year');
ok('"24-Aug-1977 16:00:00 +0200"' eq good_date('Tue, 24 Aug 77 16:00:00 +0200'), 'good_date header 2digit year');
ok('"24-Aug-1987 16:00:00 +0200"' eq good_date('Tue, 24 Aug 87 16:00:00 +0200'), 'good_date header 2digit year');
ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 97 16:00:00 +0200'), 'good_date header 2digit year');
ok('"24-Aug-2004 16:00:00 +0200"' eq good_date('Tue, 24 Aug 04 16:00:00 +0200'), 'good_date header 2digit year');
ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 1997 16.00.00 +0200'), 'good_date header period time sep');
ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 1997 16:00:00 +0200'), 'good_date header extra white space type1');
ok('"24-Aug-1997 05:06:02 +0200"' eq good_date('Tue, 24 Aug 1997 5:6:2 +0200'), 'good_date header 1digit time vals');
ok('"24-Aug-1997 05:06:02 +0200"' eq good_date('Tue, 24, Aug 1997 05:06:02 +0200'), 'good_date header extra commas');
ok('"01-Oct-2003 12:45:24 +0000"' eq good_date('Wednesday, 01 October 2003 12:45:24 CDT'), 'good_date header no abbrev');
ok('"11-Jan-2005 17:58:27 -0500"' eq good_date('Tue, 11 Jan 2005 17:58:27 -0500'), 'good_date extra white space');
ok('"18-Dec-2002 15:07:00 +0000"' eq good_date('Wednesday, December 18, 2002 03:07 PM'), 'good_date kbtoys.com orders');
ok('"16-Dec-2004 02:01:49 -0500"' eq good_date('Dec 16 2004 02:01:49 -0500'), 'good_date jr.com orders');
ok('"21-Jun-2001 11:11:11 +0000"' eq good_date('21-Jun-2001'), 'good_date register.com domain transfer');
ok('"18-Nov-2012 18:34:38 +0100"' eq good_date('Sun, 18 Nov 2012 18:34:38 +0100'), 'good_date pop2imap bug (Westeuropäische Normalzeit)');
ok('"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 $hash_1_ref = shift;
my $hash_2_ref = shift;
my @list;
foreach my $key ( sort keys %{ $hash_2_ref } ) {
#$sync->{ debug } and print "$key\n" ;
if ( exists $hash_1_ref->{$key} )
{
next ;
}
#$sync->{ debug } and print "list_keys_in_2_not_in_1: $key\n" ;
push @list, $key ;
}
#$sync->{ debug } and print "@list\n" ;
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 ) ;
#$sync->{ debug } and print "h2_folders_not_in_h1: @h2_folders_not_in_h1\n" ;
return( reverse @h2_folders_not_in_h1 ) ;
}
sub tests_nb_messages_in_2_not_in_1
{
note( 'Entering tests_stats_across_folders()' ) ;
is( undef, nb_messages_in_2_not_in_1( ), 'nb_messages_in_2_not_in_1: no args => undef' ) ;
my $mysync->{ h1_folders_of_md5 }->{ 'some_id_01' }->{ 'some_folder_01' } = 1 ;
is( 0, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: no messages in 2 => 0' ) ;
$mysync->{ h1_folders_of_md5 }->{ 'some_id_in_1_and_2' }->{ 'some_folder_01' } = 2 ;
$mysync->{ h2_folders_of_md5 }->{ 'some_id_in_1_and_2' }->{ 'some_folder_02' } = 4 ;
is( 0, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: a common message => 0' ) ;
$mysync->{ h2_folders_of_md5 }->{ 'some_id_in_2_not_in_1' }->{ 'some_folder_02' } = 1 ;
is( 1, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: one message in_2_not_in_1 => 1' ) ;
$mysync->{ h2_folders_of_md5 }->{ 'some_other_id_in_2_not_in_1' }->{ 'some_folder_02' } = 3 ;
is( 2, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: two messages in_2_not_in_1 => 2' ) ;
note( 'Leaving tests_stats_across_folders()' ) ;
return ;
}
sub nb_messages_in_2_not_in_1
{
my $mysync = shift @ARG ;
if ( not defined $mysync ) { return ; }
$mysync->{ nb_messages_in_2_not_in_1 } = scalar(
list_keys_in_2_not_in_1(
$mysync->{ h1_folders_of_md5 },
$mysync->{ h2_folders_of_md5 } ) ) ;
return $mysync->{ nb_messages_in_2_not_in_1 } ;
}
sub nb_messages_in_1_not_in_2
{
my $mysync = shift @ARG ;
if ( not defined $mysync ) { return ; }
$mysync->{ nb_messages_in_1_not_in_2 } = scalar(
list_keys_in_2_not_in_1(
$mysync->{ h2_folders_of_md5 },
$mysync->{ h1_folders_of_md5 } ) ) ;
return $mysync->{ nb_messages_in_1_not_in_2 } ;
}
sub comment_on_final_diff_in_1_not_in_2
{
my $mysync = shift @ARG ;
if ( not defined $mysync
or $mysync->{ justfolders }
or $mysync->{ useuid }
)
{
return ;
}
my $nb_identified_h1_messages = scalar( keys %{ $mysync->{ h1_folders_of_md5 } } ) ;
my $nb_identified_h2_messages = scalar( keys %{ $mysync->{ h2_folders_of_md5 } } ) ;
$mysync->{ debug } and myprint( "nb_keys h1_folders_of_md5 $nb_identified_h1_messages\n" ) ;
$mysync->{ debug } and myprint( "nb_keys h2_folders_of_md5 $nb_identified_h2_messages\n" ) ;
if ( 0 == $nb_identified_h1_messages ) { return ; }
# Calculate if not yet done
if ( not defined $mysync->{ nb_messages_in_1_not_in_2 } )
{
nb_messages_in_1_not_in_2( $mysync ) ;
}
if ( 0 == $mysync->{ nb_messages_in_1_not_in_2 } )
{
myprint( "The sync looks good, all ",
$nb_identified_h1_messages,
" identified messages in host1 are on host2.\n" ) ;
}
else
{
myprint( "The sync is not finished, there are ",
$mysync->{ nb_messages_in_1_not_in_2 },
" among ",
$nb_identified_h1_messages,
" identified messages in host1 that are not on host2.\n" ) ;
}
if ( 1 <= $mysync->{ h1_nb_msg_noheader } )
{
myprint( "There are ",
$mysync->{ h1_nb_msg_noheader },
" unidentified messages (usually Sent or Draft messages).",
" To sync them add option --addheader\n" ) ;
}
else
{
myprint( "There is no unidentified message on host1.\n" ) ;
}
return ;
}
sub comment_on_final_diff_in_2_not_in_1
{
my $mysync = shift @ARG ;
if ( not defined $mysync
or $mysync->{ justfolders }
or $mysync->{ useuid }
)
{
return ;
}
my $nb_identified_h2_messages = scalar( keys %{ $mysync->{ h2_folders_of_md5 } } ) ;
# Calculate if not done yet
if ( not defined $mysync->{ nb_messages_in_2_not_in_1 } )
{
nb_messages_in_2_not_in_1( $mysync ) ;
}
if ( 0 == $mysync->{ nb_messages_in_2_not_in_1 } )
{
myprint( "The sync is strict, all ",
$nb_identified_h2_messages,
" identified messages in host2 are on host1.\n" ) ;
}
else
{
myprint( "The sync is not strict, there are ",
$mysync->{ nb_messages_in_2_not_in_1 },
" among ",
$nb_identified_h2_messages,
" identified messages in host2 that are not on host1.",
" Use --delete2 and sync again to delete them and have a strict sync.\n"
) ;
}
return ;
}
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( 'lalala', match( 'lalala', 'lalala' ), 'match: lalala =~ lalala => lalala' ) ;
is( 'lalala', match( 'lalala', '^lalala' ), 'match: lalala =~ ^lalala => lalala' ) ;
is( 'lalala', match( 'lalala', 'lalala$' ), 'match: lalala =~ lalala$ => lalala' ) ;
is( 'lalala', match( 'lalala', '^lalala$' ), 'match: lalala =~ ^lalala$ => lalala' ) ;
is( '_lalala_', match( '_lalala_', 'lalala' ), 'match: _lalala_ =~ lalala => _lalala_' ) ;
is( 'lalala', match( 'lalala', '.*' ), 'match: lalala =~ .* => lalala' ) ;
is( 'lalala', match( 'lalala', '.' ), 'match: lalala =~ . => lalala' ) ;
is( '/lalala/', match( '/lalala/', '/lalala/' ), 'match: /lalala/ =~ /lalala/ => /lalala/' ) ;
is( 0, match( 'foo', 's/foo/bar/g' ), 'match: foo =~ s/foo/bar/g => 0' ) ;
is( 's/foo/bar/g', match( 's/foo/bar/g', 's/foo/bar/g' ), 'match: s/foo/bar/g =~ s/foo/bar/g => s/foo/bar/g' ) ;
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/ => 0' ) ;
is( 'LALALA', 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' ) ;
note( 'Leaving tests_match()' ) ;
return ;
}
sub match
{
my( $var, $regex ) = @ARG ;
# undef cases
if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; }
# normal cases
if ( eval { $var =~ qr{$regex} } ) {
return $var ;
}elsif ( $EVAL_ERROR ) {
myprint( "Fatal regex $regex\n" ) ;
return ;
} else {
return 0 ;
}
return ;
}
sub tests_notmatch
{
note( 'Entering tests_notmatch()' ) ;
# undef serie
is( undef, notmatch( ), 'notmatch: no args => undef' ) ;
is( undef, notmatch( 'lalala' ), 'notmatch: one args => undef' ) ;
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' ) ;
# 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 notmatch
{
my( $var, $regex ) = @ARG ;
# undef cases
if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; }
# normal cases
if ( eval { $var !~ $regex } ) {
return 1 ;
}elsif ( $EVAL_ERROR ) {
myprint( "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!
$sync->{imap2}->unsubscribe( $folder ) if ( ! $sync->{dry} ) ;
$res = $sync->{imap2}->delete( $folder ) if ( ! $sync->{dry} ) ;
if ( $res ) {
myprint( "Deleted $folder", "$sync->{dry_message}", "\n" ) ;
}else{
myprint( "Deleting $folder failed", "\n" ) ;
}
}
return ;
}
sub delete_folder
{
my ( $mysync, $imap, $folder, $Side ) = @_ ;
if ( ! $mysync ) { return ; }
if ( ! $imap ) { return ; }
if ( ! $folder ) { return ; }
$Side ||= 'HostX' ;
my $res = $mysync->{dry} ; # always success in dry mode!
if ( ! $mysync->{dry} ) {
$imap->unsubscribe( $folder ) ;
$res = $imap->delete( $folder ) ;
}
if ( $res ) {
myprint( "$Side deleted $folder", $mysync->{dry_message}, "\n" ) ;
return 1 ;
}else{
myprint( "$Side deleting $folder failed", "\n" ) ;
return ;
}
}
sub delete1emptyfolders
{
my $mysync = shift @ARG ;
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 disconnected
my %folders_kept ;
myprint( qq{Host1 deleting empty folders\n} ) ;
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" ) ;
$folders_kept{ $folder }++ ;
next ;
}
my $nb_messages_select = examine_folder_and_count( $mysync, $imap, $folder, 'Host1' ) ;
if ( ! defined $nb_messages_select ) { next ; } # Select failed => Neither continue nor keep this folder }
my $nb_messages_search = scalar( @{ $imap->messages( ) } ) ;
if ( 0 != $nb_messages_select and 0 != $nb_messages_search ) {
myprint( "Host1: folder $folder has messages: $nb_messages_search (search) $nb_messages_select (select)\n" ) ;
$folders_kept{ $folder }++ ;
next ;
}
if ( 0 != $nb_messages_select + $nb_messages_search ) {
myprint( "Host1: folder $folder odd messages count: $nb_messages_search (search) $nb_messages_select (select)\n" ) ;
$folders_kept{ $folder }++ ;
next ;
}
# Here we must have 0 messages by messages() aka "SEARCH ALL" and also "EXAMINE"
if ( uc $folder eq 'INBOX' ) {
myprint( "Host1: Not deleting $folder\n" ) ;
$folders_kept{ $folder }++ ;
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( $mysync, $imap, $folder, 'Host1' ) ) {
next ; # Deleted, good!
}else{
$folders_kept{ $folder }++ ;
next ; # Not deleted, bad!
}
}
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 ( $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 ;
}
}
@{ $mysync->{h1_folders_wanted} } = @h1_folders_wanted_last ;
return ;
}
sub examine_folder_and_count
{
my ( $mysync, $imap, $folder, $Side ) = @_ ;
$Side ||= 'HostX' ;
if ( ! examine_folder( $mysync, $imap, $folder, $Side ) ) {
return ;
}
my $nb_messages_select = count_from_select( $imap->History ) ;
return $nb_messages_select ;
}
sub tests_delete1emptyfolders
{
note( 'Entering tests_delete1emptyfolders()' ) ;
is( undef, delete1emptyfolders( ), q{delete1emptyfolders: undef} ) ;
my $syncT ;
is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef 2} ) ;
my $imapT ;
$syncT->{imap1} = $imapT ;
is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef imap} ) ;
require_ok( "Test::MockObject" ) ;
$imapT = Test::MockObject->new( ) ;
$syncT->{imap1} = $imapT ;
$imapT->set_true( 'IsUnconnected' ) ;
is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: Unconnected imap} ) ;
# Now connected tests
$imapT->set_false( 'IsUnconnected' ) ;
$imapT->mock( 'LastError', sub { q{LastError mocked} } ) ;
$syncT->{delete1emptyfolders} = 0 ;
tests_delete1emptyfolders_unit(
$syncT,
[ qw{ INBOX DELME1 DELME2 } ],
[ qw{ INBOX DELME1 DELME2 } ],
q{tests_delete1emptyfolders: --delete1emptyfolders OFF}
) ;
# All are parents => no deletion at all
$imapT->set_true( 'is_parent' ) ;
$syncT->{delete1emptyfolders} = 1 ;
tests_delete1emptyfolders_unit(
$syncT,
[ qw{ INBOX DELME1 DELME2 } ],
[ qw{ INBOX DELME1 DELME2 } ],
q{tests_delete1emptyfolders: --delete1emptyfolders ON}
) ;
# No parents but examine false for all => skip all
$imapT->set_false( 'is_parent', 'examine' ) ;
tests_delete1emptyfolders_unit(
$syncT,
[ qw{ INBOX DELME1 DELME2 } ],
[ ],
q{tests_delete1emptyfolders: EXAMINE fails}
) ;
# examine ok for all but History bad => skip all
$imapT->set_true( 'examine' ) ;
$imapT->mock( 'History', sub { ( q{History badly mocked} ) } ) ;
tests_delete1emptyfolders_unit(
$syncT,
[ qw{ INBOX DELME1 DELME2 } ],
[ ],
q{tests_delete1emptyfolders: examine ok but History badly mocked so count messages fails}
) ;
# History good but some messages EXISTS == messages() => no deletion
$imapT->mock( 'History', sub { ( q{* 2 EXISTS} ) } ) ;
$imapT->mock( 'messages', sub { [ qw{ UID_1 UID_2 } ] } ) ;
tests_delete1emptyfolders_unit(
$syncT,
[ qw{ INBOX DELME1 DELME2 } ],
[ qw{ INBOX DELME1 DELME2 } ],
q{tests_delete1emptyfolders: History EXAMINE ok, several messages}
) ;
# 0 EXISTS but != messages() => no deletion
$imapT->mock( 'History', sub { ( q{* 0 EXISTS} ) } ) ;
$imapT->mock( 'messages', sub { [ qw{ UID_1 UID_2 } ] } ) ;
tests_delete1emptyfolders_unit(
$syncT,
[ qw{ INBOX DELME1 DELME2 } ],
[ qw{ INBOX DELME1 DELME2 } ],
q{tests_delete1emptyfolders: 0 EXISTS but 2 by messages()}
) ;
# 1 EXISTS but != 0 == messages() => no deletion
$imapT->mock( 'History', sub { ( q{* 1 EXISTS} ) } ) ;
$imapT->mock( 'messages', sub { [ ] } ) ;
tests_delete1emptyfolders_unit(
$syncT,
[ qw{ INBOX DELME1 DELME2 } ],
[ qw{ INBOX DELME1 DELME2 } ],
q{tests_delete1emptyfolders: 1 EXISTS but 0 by messages()}
) ;
# 0 EXISTS and 0 == messages() => deletion except INBOX
$imapT->mock( 'History', sub { ( q{* 0 EXISTS} ) } ) ;
$imapT->mock( 'messages', sub { [ ] } ) ;
$imapT->set_true( qw{ delete close unsubscribe } ) ;
$syncT->{dry_message} = q{ (not really since in a mocked test)} ;
tests_delete1emptyfolders_unit(
$syncT,
[ qw{ INBOX DELME1 DELME2 } ],
[ qw{ INBOX } ],
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 @ARG ;
my $folders1wanted_init_ref = shift @ARG ;
my $folders1wanted_after_ref = shift @ARG ;
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 ;
}
sub extract_header
{
my $string = shift @ARG ;
my ( $header ) = split /\n\n/x, $string ;
if ( ! $header ) { return( q{} ) ; }
#myprint( "[$header]\n" ) ;
return( $header ) ;
}
sub tests_extract_header
{
note( 'Entering tests_extract_header()' ) ;
my $h = <<'EOM';
Message-Id: <[email protected]>
Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST)
From: [email protected] (Gilles LAMIRAL)
EOM
chomp $h ;
ok( $h eq extract_header(
<<'EOM'
Message-Id: <[email protected]>
Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST)
From: [email protected] (Gilles LAMIRAL)
body
lalala
EOM
), 'extract_header: 1') ;
note( 'Leaving tests_extract_header()' ) ;
return ;
}
sub decompose_header{
my $string = shift @ARG ;
# a hash, for a keyword header KEY value are list of strings [VAL1, VAL1_other, etc]
# Think of multiple "Received:" header lines.
my $header = { } ;
my ($key, $val ) ;
my @line = split /\n|\r\n/x, $string ;
foreach my $line ( @line ) {
#myprint( "DDD $line\n" ) ;
# End of header
last if ( $line =~ m{^$}xo ) ;
# Key: value
if ( $line =~ m/(^[^:]+):\s(.*)/xo ) {
$key = $1 ;
$val = $2 ;
$debugdev and myprint( "DDD KV [$key] [$val]\n" ) ;
push @{ $header->{ $key } }, $val ;
# blanc and value => value from previous line continues
}elsif( $line =~ m/^(\s+)(.*)/xo ) {
$val = $2 ;
$debugdev and myprint( "DDD V [$val]\n" ) ;
@{ $header->{ $key } }[ $LAST ] .= " $val" if $key ;
# dirty line?
}else{
next ;
}
}
#myprint( Data::Dumper->Dump( [ $header ] ) ) ;
return( $header ) ;
}
sub tests_decompose_header{
note( 'Entering tests_decompose_header()' ) ;
my $header_dec ;
$header_dec = decompose_header(
<<'EOH'
KEY_1: VAL_1
KEY_2: VAL_2
VAL_2_+
VAL_2_++
KEY_3: VAL_3
KEY_1: VAL_1_other
KEY_4: VAL_4
VAL_4_+
KEY_5 BLANC: VAL_5
KEY_6_BAD_BODY: VAL_6
EOH
) ;
ok( 'VAL_3'
eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: VAL_3' ) ;
ok( 'VAL_1'
eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: VAL_1' ) ;
ok( 'VAL_1_other'
eq $header_dec->{ 'KEY_1' }[1], 'decompose_header: VAL_1_other' ) ;
ok( 'VAL_2 VAL_2_+ VAL_2_++'
eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: VAL_2 VAL_2_+ VAL_2_++' ) ;
ok( 'VAL_4 VAL_4_+'
eq $header_dec->{ 'KEY_4' }[0], 'decompose_header: VAL_4 VAL_4_+' ) ;
ok( ' VAL_5'
eq $header_dec->{ 'KEY_5 BLANC' }[0], 'decompose_header: KEY_5 BLANC' ) ;
ok( not( defined $header_dec->{ 'KEY_6_BAD_BODY' }[0] ), 'decompose_header: KEY_6_BAD_BODY' ) ;
$header_dec = decompose_header(
<<'EOH'
Message-Id: <[email protected]>
Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST)
From: [email protected] (Gilles LAMIRAL)
EOH
) ;
ok( '<[email protected]>'
eq $header_dec->{ 'Message-Id' }[0], 'decompose_header: 1' ) ;
$header_dec = decompose_header(
<<'EOH'
Return-Path: <[email protected]>
Received: by plume.est.belle (Postfix, from userid 1000)
id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST)
Subject: test:eekahceishukohpe
EOH
) ;
ok(
'by plume.est.belle (Postfix, from userid 1000) id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST)'
eq $header_dec->{ 'Received' }[0], 'decompose_header: 2' ) ;
$header_dec = decompose_header(
<<'EOH'
Received: from plume (localhost [127.0.0.1])
by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9
for <gilles@localhost>; Mon, 26 Nov 2007 10:39:06 +0100 (CET)
Received: from plume [192.168.68.7]
by plume with POP3 (fetchmail-6.3.6)
for <gilles@localhost> (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET)
EOH
) ;
ok(
'from plume (localhost [127.0.0.1]) by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9 for <gilles@localhost>; Mon, 26 Nov 2007 10:39:06 +0100 (CET)'
eq $header_dec->{ 'Received' }[0], 'decompose_header: 3' ) ;
ok(
'from plume [192.168.68.7] by plume with POP3 (fetchmail-6.3.6) for <gilles@localhost> (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET)'
eq $header_dec->{ 'Received' }[1], 'decompose_header: 3' ) ;
# Bad header beginning with a blank character
$header_dec = decompose_header(
<<'EOH'
KEY_1: VAL_1
KEY_2: VAL_2
VAL_2_+
VAL_2_++
KEY_3: VAL_3
KEY_1: VAL_1_other
EOH
) ;
ok( 'VAL_3'
eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: Bad header VAL_3' ) ;
ok( 'VAL_1_other'
eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: Bad header VAL_1_other' ) ;
ok( 'VAL_2 VAL_2_+ VAL_2_++'
eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: Bad header VAL_2 VAL_2_+ VAL_2_++' ) ;
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' ) ;
is( '1280671200', epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ;
is( '946684800', epoch( '00-Jan-0000 00:00:00 +0000' ), '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
# outgoing format: epoch
my $d = shift @ARG ;
return(q{}) if not defined $d;
my ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) ;
my $time ;
if ( $d =~ m{(\d{1,2})-([A-Z][a-z]{2})-(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-))(\d{2})(\d{2})}xo ) {
#myprint( "internal: [$1][$2][$3][$4][$5][$6][$7][$8][$9]\n" ) ;
( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m )
= ( $1, $2, $3, $4, $5, $6, $7, $8, $9 ) ;
#myprint( "( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m )\n" ) ;
$sign = +1 if ( '+' eq $sign ) ;
$sign = $MINUS_ONE if ( '-' eq $sign ) ;
if ( 0 == $mday ) {
myprint( "buggy day in $d. Fixed to 01\n" ) ;
$mday = '01' ;
}
$time = timegm( $sec, $min, $hour, $mday, $month_abrev{$month}, $year )
- $sign * ( 3600 * $zone_h + 60 * $zone_m ) ;
#myprint( "$time ", scalar localtime($time), "\n");
}
return( $time ) ;
}
sub tests_add_header
{
note( 'Entering 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' ) ;
note( 'Leaving tests_add_header()' ) ;
return ;
}
sub add_header
{
my $header_uid = shift || 'mistake' ;
my $header_Message_Id = 'Message-Id: <' . $header_uid . '@imapsync>' ;
return( $header_Message_Id ) ;
}
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 1_000 ), 'max_line_length: 3 == 1_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 @ARG ;
my $max = 0 ;
while ( $string =~ m/([^\n]*\n?)/msxg ) {
$max = max( $max, length $1 ) ;
}
return( $max ) ;
}
sub set_checknoabletosearch
{
my $mysync = shift @ARG ;
if ( defined $mysync->{ checknoabletosearch } )
{
return ;
}
elsif ( $mysync->{ justfolders } )
{
$mysync->{ checknoabletosearch } = 0 ;
}
else
{
$mysync->{ checknoabletosearch } = 1 ;
}
return ;
}
sub tests_setlogfile
{
note( 'Entering tests_setlogfile()' ) ;
my $mysync = {} ;
$mysync->{ logdir } = 'vallogdir' ;
is( 'vallogdir/vallogfile.txt', setlogfile( $mysync, 'vallogfile.txt' ),
'setlogfile: logdir vallogdir, vallogfile.txt => vallogdir/vallogfile.txt' ) ;
SKIP: {
skip( 'Too hard to have a well known timezone on Windows', 9 ) if ( 'MSWin32' eq $OSNAME ) ;
local $ENV{TZ} = 'GMT' ;
$mysync = {
timestart => 2,
} ;
is( '1970_01_01_00_00_02_000__.txt', setlogfile( $mysync ),
'setlogfile: default is like 1970_01_01_00_00_02_000__.txt' ) ;
$mysync = {
timestart => 2,
user1 => 'user1',
user2 => 'user2',
abort => 1,
} ;
is( '1970_01_01_00_00_02_000_user1_user2_abort.txt', setlogfile( $mysync ),
'setlogfile: default abort is like 1970_01_01_00_00_02_000_user1_user2_abort.txt' ) ;
$mysync = {
timestart => 2,
user1 => 'user1',
user2 => 'user2',
} ;
is( '1970_01_01_00_00_02_000_user1_user2_remote.txt', setlogfile( $mysync, undef, '_remote' ),
'setlogfile: default with _remote is like 1970_01_01_00_00_02_000_user1_user2_remote.txt' ) ;
$mysync = {
timestart => 2,
user1 => 'user1',
user2 => 'user2',
abort => 1,
} ;
is( '1970_01_01_00_00_02_000_user1_user2_remote_abort.txt', setlogfile( $mysync, undef, '_remote' ),
'setlogfile: default abort with _remote is like 1970_01_01_00_00_02_000_user1_user2_remote_abort.txt' ) ;
$mysync = {
timestart => 2,
user1 => 'user1',
user2 => 'user2',
} ;
is( '1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ),
'setlogfile: default is like 1970_01_01_00_00_02_000_user1_user2.txt' ) ;
$mysync->{logdir} = undef ;
$mysync->{logfile} = undef ;
is( '1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ),
'setlogfile: logdir undef, 1970_01_01_00_00_02_000_user1_user2.txt' ) ;
$mysync->{logdir} = q{} ;
$mysync->{logfile} = undef ;
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( '1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt', setlogfile( $mysync ),
'setlogfile: logdir undef, 1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt' ) ;
} ;
note( 'Leaving tests_setlogfile()' ) ;
return ;
}
sub setlogfile
{
my $mysync = shift @ARG ;
my $given = shift @ARG ;
my $supplement = shift @ARG || '' ;
# When aborting another process the log file name finishes with "_abort.txt"
my $abort_suffix = ( $mysync->{ abort } ) ? '_abort' : q{} ;
my $suffix = logfilesuffix( $mysync, $supplement . $abort_suffix ) ;
my $logdir = $mysync->{ logdir } || '' ;
my $logfile ;
if ( defined $given )
{
if ( $logdir )
{
$logfile = "$logdir/$given" ;
}
else
{
$logfile = "$given" ;
}
}
else
{
$logfile = logfile( $mysync->{ timestart }, $suffix, $logdir ) ;
}
return( $logfile ) ;
}
sub tests_logfilesuffix
{
note( 'Entering tests_logfilesuffix()' ) ;
is( '_', logfilesuffix( ), 'logfilesuffix: no args => _' ) ;
my $mysync = { } ;
is( '_', logfilesuffix( $mysync ), 'logfilesuffix: undef => _' ) ;
$mysync->{ user1 } = 'valuser1' ;
$mysync->{ user2 } = 'valuser2' ;
is( 'valuser1_valuser2', logfilesuffix( $mysync ), 'logfilesuffix: valuser1 valuser2 => valuser1_valuser2' ) ;
is( 'valuser1_valuser2_suppl', logfilesuffix( $mysync, '_suppl' ), 'logfilesuffix: valuser1 valuser2 _suppl => valuser1_valuser2_suppl' ) ;
note( 'Leaving tests_logfilesuffix()' ) ;
return ;
}
sub logfilesuffix
{
my $mysync = shift @ARG ;
my $supplement = shift @ARG || '' ;
my $suffix = (
filter_forbidden_characters( slash_to_underscore( $mysync->{ user1 } ) ) || q{} )
. '_'
. ( filter_forbidden_characters( slash_to_underscore( $mysync->{ user2 } ) ) || q{} )
. $supplement ;
return $suffix ;
}
sub tests_setlogdir
{
note( 'Entering tests_setlogdir()' ) ;
is( $DEFAULT_LOGDIR, setlogdir( ), "setlogdir: no args => $DEFAULT_LOGDIR" ) ;
my $mysync = { } ;
is( $DEFAULT_LOGDIR, setlogdir( $mysync ), "setlogdir: no args => $DEFAULT_LOGDIR" ) ;
$mysync->{ logdir } = '' ;
is( '', setlogdir( $mysync ), "setlogdir: logdir empty string => empty string" ) ;
is( '', $mysync->{ logdir }, "setlogdir: logdir empty string unchanged" ) ;
$mysync->{ logdir } = 'vallogdir' ;
is( 'vallogdir', setlogdir( $mysync ), "setlogdir: logdir vallogdir => vallogdir" ) ;
is( 'vallogdir', $mysync->{ logdir }, "setlogdir: logdir vallogdir unchanged" ) ;
# Does a second call hurt?
is( 'vallogdir', setlogdir( $mysync ), "setlogdir: logdir vallogdir => vallogdir" ) ;
is( 'vallogdir', $mysync->{ logdir }, "setlogdir: logdir vallogdir unchanged" ) ;
note( 'Leaving tests_setlogdir()' ) ;
return ;
}
sub setlogdir
{
my $mysync = shift @ARG ;
my $logdir = defined $mysync->{ logdir } ? $mysync->{ logdir } : $DEFAULT_LOGDIR ;
return $logdir ;
}
sub tests_logfile
{
note( 'Entering tests_logfile()' ) ;
SKIP: {
# Too hard to have a well known timezone on Windows
skip( 'Too hard to have a well known timezone on Windows', 10 ) if ( 'MSWin32' eq $OSNAME ) ;
local $ENV{TZ} = 'GMT' ;
{
POSIX::tzset unless ('MSWin32' eq $OSNAME) ;
is( '1970_01_01_00_00_00_000.txt', logfile( ), 'logfile: no args => 1970_01_01_00_00_00_000.txt' ) ;
is( '1970_01_01_00_00_00_000.txt', logfile( 0 ), 'logfile: 0 => 1970_01_01_00_00_00_000.txt' ) ;
is( '1970_01_01_00_01_01_000.txt', logfile( 61 ), 'logfile: 0 => 1970_01_01_00_01_01_000.txt' ) ;
is( '1970_01_01_00_01_01_234.txt', logfile( 61.234 ), 'logfile: 0 => 1970_01_01_00_01_01_234.txt' ) ;
is( '2010_08_24_14_00_00_000.txt', logfile( 1_282_658_400 ), 'logfile: 1_282_658_400 => 2010_08_24_14_00_00_000.txt' ) ;
is( '2010_08_24_14_01_01_000.txt', logfile( 1_282_658_461 ), 'logfile: 1_282_658_461 => 2010_08_24_14_01_01_000.txt' ) ;
is( '2010_08_24_14_01_01_000_poupinette.txt', logfile( 1_282_658_461, 'poupinette' ), 'logfile: 1_282_658_461 poupinette => 2010_08_24_14_01_01_000_poupinette.txt' ) ;
is( '2010_08_24_14_01_01_000_removeblanks.txt', logfile( 1_282_658_461, ' remove blanks ' ), 'logfile: 1_282_658_461 remove blanks => 2010_08_24_14_01_01_000_removeblanks.txt' ) ;
is( '2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup' ),
'logfile: 1_282_658_461.2347 poup => 2010_08_24_14_01_01_234_poup.txt' ) ;
is( 'dirdir/2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup', 'dirdir' ),
'logfile: 1_282_658_461.2347 poup dirdir => dirdir/2010_08_24_14_01_01_234_poup.txt' ) ;
}
POSIX::tzset unless ('MSWin32' eq $OSNAME) ;
} ;
note( 'Leaving tests_logfile()' ) ;
return ;
}
sub logfile
{
my ( $time, $suffix, $dir ) = @_ ;
$time ||= 0 ;
$suffix ||= q{} ;
$suffix =~ tr/ //ds ;
my $sep_suffix = ( $suffix ) ? '_' : q{} ;
$dir ||= q{} ;
my $sep_dir = ( $dir ) ? '/' : q{} ;
my $date_str = year_month_day_hour_min_sec_ms( $time ) ;
my $logfile = "${dir}${sep_dir}${date_str}${sep_suffix}${suffix}.txt" ;
return( $logfile ) ;
}
sub tests_year_month_day_hour_min_sec_ms
{
note( 'Entering tests_date_year_month_day_hour_min_sec_ms()' ) ;
if ( 'MSWin32' eq $OSNAME )
{
# Can not use $ENV{TZ} nor POSIX::tzset
like( year_month_day_hour_min_sec_ms( ), qr'1970_01_01_\d\d_00_00_000', 'year_month_day_hour_min_sec_ms: no args => match 1970_01_01_\d\d_00_00_000' ) ;
like( year_month_day_hour_min_sec_ms( 0 ), qr'1970_01_01_\d\d_00_00_000', 'year_month_day_hour_min_sec_ms: 0 => match 1970_01_01_\d\d_00_00_000' ) ;
like( year_month_day_hour_min_sec_ms( 1671706800.123 ), qr'2022_12_22_\d\d_00_00_122', 'year_month_day_hour_min_sec_ms: 123456789.123 => match 2022_12_22_\d\d_00_00_122' ) ;
like( year_month_day_hour_min_sec_ms( -1 ), qr'19\d\d_\d\d_\d\d_\d\d_59_59_000', 'year_month_day_hour_min_sec_ms: -1 => 19\d\d_\d\d_\d\d_\d\d_59_59_000' ) ;
like( year_month_day_hour_min_sec_ms( -0.246 ), qr'19\d\d_\d\d_\d\d_\d\d_59_59_754', 'year_month_day_hour_min_sec_ms: -1 => 19\d\d_\d\d_\d\d_\d\d_59_59_754' ) ;
like( year_month_day_hour_min_sec_ms( -32360400.135 ), qr'1968_12_22_\d\d_59_59_864', 'year_month_day_hour_min_sec_ms: -1 => 1968_12_22_\d\d_59_59_864' ) ;
}
else
{
local $ENV{TZ} = 'GMT' ;
{
POSIX::tzset unless ('MSWin32' eq $OSNAME) ;
is( '1970_01_01_00_00_00_000', year_month_day_hour_min_sec_ms( ),
'year_month_day_hour_min_sec_ms: no args => 1970_01_01_00_00_00_000 GMT' ) ;
is( '1970_01_01_00_00_00_000', year_month_day_hour_min_sec_ms( 0 ),
'year_month_day_hour_min_sec_ms: 0 => 1970_01_01_00_00_00_000 GMT' ) ;
is( '1973_11_29_21_33_09_122', year_month_day_hour_min_sec_ms( 123456789.123 ),
'year_month_day_hour_min_sec_ms: 123456789.123 => 1973_11_29_21_33_09_122 GMT' ) ;
is( '1969_12_31_23_59_59_000', year_month_day_hour_min_sec_ms( -1 ),
'year_month_day_hour_min_sec_ms: -1 => 1969_12_31_23_59_59_000 GMT' ) ;
is( '1969_12_31_23_59_59_754', year_month_day_hour_min_sec_ms( -0.246 ),
'year_month_day_hour_min_sec_ms: -0.246 => 1969_12_31_23_59_59_754 GMT' ) ;
is( '1966_02_02_02_26_50_864', year_month_day_hour_min_sec_ms( -123456789.135 ),
'year_month_day_hour_min_sec_ms: -123456789.135 => 1966_02_02_02_26_50_864 GMT' ) ;
}
POSIX::tzset unless ('MSWin32' eq $OSNAME) ;
}
note( 'Leaving tests_year_month_day_hour_min_sec_ms()' ) ;
return ;
}
sub year_month_day_hour_min_sec_ms
{
my $time = shift @ARG || 0 ;
my $date_str = POSIX::strftime( '%Y_%m_%d_%H_%M_%S', localtime $time ) ;
# Because of ab tests or web accesses, more than one sync withing one second is possible
# so we add also milliseconds
$date_str .= sprintf "_%03d", fractional_of_floor( $time ) * 1000 ;
return $date_str ;
}
sub tests_fractional_of_floor
{
note( 'Entering tests_fractional_of_floor()' ) ;
is( 0, fractional_of_floor( ), 'fractional_of_floor: no args => 0' ) ;
is( 0, fractional_of_floor( 0 ), 'fractional_of_floor: 0 => 0' ) ;
is( 0, fractional_of_floor( '0' ), 'fractional_of_floor: 0 => 0' ) ;
is( 0, fractional_of_floor( 1 ), 'fractional_of_floor: 1 => 0' ) ;
is( 0, fractional_of_floor( '1' ), 'fractional_of_floor: 1 => 0' ) ;
is( 0, fractional_of_floor( -1 ), 'fractional_of_floor: -1 => 0' ) ;
is( 0, fractional_of_floor( '-1' ), 'fractional_of_floor: -1 => 0' ) ;
is( 0.234, fractional_of_floor( 1.234 ), 'fractional_of_floor: 1.234 => 0.234' ) ;
is( 0.234, fractional_of_floor( '1.234' ), 'fractional_of_floor: 1.234 => 0.234' ) ;
is( 0.766, fractional_of_floor( -1.234 ), 'fractional_of_floor: -1.234 => 0.766' ) ;
is( 0.766, fractional_of_floor( '-1.234' ), 'fractional_of_floor: -1.234 => 0.766' ) ;
is( 0.234, fractional_of_floor( 10.234 ), 'fractional_of_floor: 10.234 => 0.234' ) ;
is( 0.766, fractional_of_floor( -10.234 ), 'fractional_of_floor: -10.234 => 0.766' ) ;
note( 'Leaving tests_fractional_of_floor()' ) ;
return ;
}
sub fractional_of_floor
{
my $float = shift @ARG || 0 ;
if ( $float - int( $float ) >= 0 )
{
return( $float - int( $float ) ) ;
}
else
{
return( 1 - ( int( $float ) - $float ) ) ;
}
}
sub tests_localtimez
{
note( 'Entering tests_localtimez()' ) ;
note( "localtimez: " . localtimez( ) ) ;
if ( 'MSWin32' eq $OSNAME )
{
like( localtimez( 0 ), qr'1970-01-01 \d\d:\d\d:\d\d', 'localtimez: 0 => match 1970-01-01 \d\d:\d\d:\d\d' ) ;
}
else
{
local $ENV{TZ} = 'GMT' ;
like( localtimez( 0 ), qr'1970-01-01 00:00:00 \+0000 (GMT|UTC)', 'localtimez: 0 => match 1970-01-01 00:00:00 +0000 GMT or UTC' ) ;
}
is( localtimez( ), localtimez( time ), 'localtimez: undef => equals currrent' ) ;
note( 'Leaving tests_localtimez()' ) ;
return ;
}
sub localtimez
{
my $time = shift @ARG ;
$time = defined( $time ) ? $time : time ;
my $datetimestr ;
if ( 'MSWin32' eq $OSNAME )
{
$datetimestr = POSIX::strftime( '%A %d %B %Y-%m-%d %H:%M:%S %z', localtime( $time ) ) ;
}
else
{
$datetimestr = POSIX::strftime( '%A %d %B %Y-%m-%d %H:%M:%S %z %Z', localtime( $time ) ) ;
}
#myprint( "$datetimestr\n" ) ;
return $datetimestr ;
}
sub tests_slash_to_underscore
{
note( 'Entering tests_slash_to_underscore()' ) ;
is( undef, slash_to_underscore( ), 'slash_to_underscore: no parameters => undef' ) ;
is( '_', slash_to_underscore( '/' ), 'slash_to_underscore: / => _' ) ;
is( '_abc_def_', slash_to_underscore( '/abc/def/' ), 'slash_to_underscore: /abc/def/ => _abc_def_' ) ;
note( 'Leaving tests_slash_to_underscore()' ) ;
return ;
}
sub slash_to_underscore
{
my $string = shift @ARG ;
if ( ! defined $string ) { return ; }
$string =~ tr{/}{_} ;
return( $string ) ;
}
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_logfileprepa
{
note( 'Entering tests_logfileprepa()' ) ;
is( undef, logfileprepa( ), 'logfileprepa: no args => undef' ) ;
my $logfile = 'W/tmp/tests/tests_logfileprepa.txt' ;
is( 1, logfileprepa( $logfile ), 'logfileprepa: W/tmp/tests/tests_logfileprepa.txt => 1' ) ;
note( 'Leaving tests_logfileprepa()' ) ;
return ;
}
sub logfileprepa
{
my $logfile = shift @ARG ;
if ( ! defined( $logfile ) )
{
return ;
}else
{
#myprint( "[$logfile]\n" ) ;
my $dirname = dirname( $logfile ) ;
do_valid_directory( $dirname ) || return( 0 ) ;
return( 1 ) ;
}
}
sub tests_teelaunch
{
note( 'Entering tests_teelaunch()' ) ;
is( undef, teelaunch( ), 'teelaunch: no args => undef' ) ;
my $mysync = {} ;
is( undef, teelaunch( $mysync ), 'teelaunch: arg empty {} => undef' ) ;
is( undef, teelaunch( $mysync, '' ), 'teelaunch: empty string => undef' ) ;
# First time, learning IO::Tee intrasics
my $tee = teelaunch( $mysync, 'W/tmp/tests/tests_teelaunch.txt' ) ;
isa_ok( $tee, 'IO::Tee', 'teelaunch: logfile W/tmp/tests/tests_teelaunch.txt' ) ;
is( 1, print( $tee "Hi!\n" ), 'teelaunch: write Hi!') ;
is( "Hi!\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\n' ) ;
is( 1, print( $tee "Hoo\n" ), 'teelaunch: write Hoo') ;
is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\nHoo\n' ) ;
# closing file handle so tee won't be happy
($tee->handles)[0]->close ;
is( undef, print( $tee "Argh1\n" ), 'teelaunch: write Argh1') ;
is( undef, print( $tee "Argh2\n" ), 'teelaunch: write Argh2') ;
# write not done
is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is still Hi!\nHoo\n' ) ;
print join( ' ', $tee->handles ), "\n";
is( 2, scalar $tee->handles, 'teelaunch: 2 handles') ;
shift @{*{$tee}};
print join(' ', $tee->handles), "\n" ;
is( 1, scalar $tee->handles, 'teelaunch: 1 handle') ;
is( 1, print( $tee "Argh3\n" ), 'teelaunch: write Argh3 yeah') ;
shift @{*{$tee}};
# will not print anything now
is( 0, scalar $tee->handles, 'teelaunch: 0 handle') ;
is( 1, print( $tee "Argh 4\n" ), 'teelaunch: write Argh4 no') ;
# Second time, lesson learnt IO::Tee
$tee = teelaunch( $mysync, 'W/tmp/tests/tests_teelaunch2.txt' ) ;
isa_ok( $tee, 'IO::Tee' , 'teelaunch: W/tmp/tests/tests_teelaunch2.txt' ) ;
is( 1, print( $tee "Hi!\n" ), 'teelaunch: write Hi!') ;
is( "Hi!\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch2.txt is Hi!\n' ) ;
is( 1, print( $tee "Hoo\n" ), 'teelaunch: write Hoo') ;
is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch2.txt is Hi!\nHoo\n' ) ;
is( 1, teefinish( $tee ), 'teefinish: return 1') ;
is( 1, print( $tee "Argh1\n" ), 'teelaunch: write Argh1') ;
is( 1, print( $tee "Argh2\n" ), 'teelaunch: write Argh2') ;
is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch2.txt is still Hi!\nHoo\n' ) ;
is( 1, teefinish( $tee ), 'teefinish: still return 1') ;
note( 'Leaving tests_teelaunch()' ) ;
return ;
}
sub teelaunch
{
my $mysync = shift @ARG ;
my $logfile = shift @ARG ;
if ( ! defined( $mysync ) )
{
return ;
}
if ( ! $logfile )
{
return ;
}
logfileprepa( $logfile ) || croak "Error no valid directory to write log file $logfile : $OS_ERROR" ;
# To honor -T tainted mode. Could do better...
( $logfile ) = $logfile =~ m{(.*)}x ;
# This is a log file opened during the whole sync
## no critic (InputOutput::RequireBriefOpen)
if ( ! open my $logfile_handle, '>', $logfile )
{
carp( "Can not open $logfile for write: $OS_ERROR" ) ;
return ;
}
else
{
binmode $logfile_handle, ":encoding(UTF-8)" ;
my $tee = IO::Tee->new( $logfile_handle, \*STDOUT ) ;
$tee->autoflush( 1 ) ;
return $tee ;
}
}
sub teefinish
{
my $tee = shift @ARG ;
if ( ! defined( $tee ) ) { return ; }
if ( 2 == scalar $tee->handles )
{
my $handle = shift @{*{$tee}} ;
$handle->close ;
}
else
{
# nothing
}
return scalar $tee->handles ;
}
sub getpwuid_any_os
{
my $uid = shift @ARG ;
return( scalar getlogin ) if ( 'MSWin32' eq $OSNAME ) ; # Windows system
return( scalar getpwuid $uid ) ; # Unix system
}
sub abortifneeded
{
my $mysync = shift @ARG ;
if ( -e $mysync->{ abortfile } )
{
myprint( "Asked to terminate by file $mysync->{ abortfile }\n" ) ;
do_and_print_stats( $mysync ) ;
myprint( "You should resynchronize those accounts by running a sync again,\n",
"since some messages and entire folders might still be missing on host2.\n"
) ;
exit_clean( $mysync, $EXIT_BY_FILE ) ;
return ;
}
else
{
return ;
}
}
sub simulong
{
my $mysync = shift @ARG ;
my $max_seconds = $mysync->{ simulong } ;
if ( ! $max_seconds ) { return ; }
my $division = 5 ;
my $last_count = int( $division * $max_seconds ) ;
$mysync->{ debug } and myprint "last_count $last_count = int( division $division * max_seconds $max_seconds)\n" ;
foreach my $i ( 1 .. ( $last_count ) ) {
myprint( "Are you still here ETA: " . ( $last_count - $i ) . "/$last_count msgs left\n" ) ;
#this one is for testing huge page behavior
#myprint( "Are you still here ETA: " . ($last_count - $i) . "/$last_count msgs left\n" . ( "Ah" x 40 . "\n") x 4000 ) ;
sleep( 1 / $division ) ;
abortifneeded( $mysync ) ;
}
return ;
}
sub printenv
{
myprint( "Environment variables listing:\n",
( map { "$_ => $ENV{$_}\n" } sort keys %ENV),
"Environment variables listing end\n" ) ;
return ;
}
sub unittestssuite
{
my $mysync = shift @ARG ;
if ( ! ( $mysync->{ tests } or $mysync->{ testsdebug } or $mysync->{ testsunit } ) ) {
return ;
}
my $test_builder = Test::More->builder ;
tests( $mysync ) ;
testsdebug( $mysync ) ;
testunitsession( $mysync ) ;
cleanup_mess_from_tests( ) ;
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 ) ;
return $EXIT_TESTS_FAILED ;
}
return 0 ;
}
sub cleanup_mess_from_tests
{
undef @pipemess ;
undef @include ;
undef @exclude ;
undef @folderrec ;
undef @folderfirst ;
undef @folderlast ;
undef @h1_folders_all ;
undef %h1_folders_all ;
undef @h2_folders_all ;
undef %h2_folders_all ;
undef @h2_folders_from_1_wanted ;
undef %h2_folders_from_1_all ;
undef %requested_folder ;
return ;
}
sub after_get_options
{
my $mysync = shift @ARG ;
my $numopt = shift @ARG ;
# exit with --help option or no option at all
$mysync->{ debug } and myprint( "numopt:$numopt\n" ) ;
if ( $help or not $numopt ) {
myprint( usage( $mysync ) ) ;
exit ;
}
return ;
}
sub tests_remove_edging_blanks
{
note( 'Entering tests_remove_edging_blanks()' ) ;
is( undef, remove_edging_blanks( ), 'remove_edging_blanks: no args => undef' ) ;
is( 'abcd', remove_edging_blanks( 'abcd' ), 'remove_edging_blanks: abcd => abcd' ) ;
is( 'ab cd', remove_edging_blanks( ' ab cd ' ), 'remove_edging_blanks: " ab cd " => "ab cd"' ) ;
note( 'Leaving tests_remove_edging_blanks()' ) ;
return ;
}
sub remove_edging_blanks
{
my $string = shift @ARG ;
if ( ! defined $string )
{
return ;
}
$string =~ s,^ +| +$,,g ;
return $string ;
}
sub tests_sanitize
{
note( 'Entering tests_remove_edging_blanks()' ) ;
is( undef, sanitize( ), 'sanitize: no args => undef' ) ;
my $mysync = {} ;
$mysync->{ host1 } = ' example.com ' ;
$mysync->{ user1 } = ' to to ' ;
$mysync->{ password1 } = ' sex is good! ' ;
is( undef, sanitize( $mysync ), 'sanitize: => undef' ) ;
is( 'example.com', $mysync->{ host1 }, 'sanitize: host1 " example.com " => "example.com"' ) ;
is( 'to to', $mysync->{ user1 }, 'sanitize: user1 " to to " => "to to"' ) ;
is( 'sex is good!', $mysync->{ password1 }, 'sanitize: password1 " sex is good! " => "sex is good!"' ) ;
note( 'Leaving tests_remove_edging_blanks()' ) ;
return ;
}
sub sanitize
{
my $mysync = shift @ARG ;
if ( ! defined $mysync )
{
return ;
}
foreach my $parameter ( qw( host1 host2 user1 user2 password1 password2 ) )
{
$mysync->{ $parameter } = remove_edging_blanks( $mysync->{ $parameter } ) ;
}
return ;
}
sub easyany
{
my $mysync = shift @ARG ;
# Gmail
if ( $mysync->{gmail1} and $mysync->{gmail2} ) {
$mysync->{ debug } and myprint( "gmail1 gmail2\n") ;
gmail12( $mysync ) ;
return ;
}
if ( $mysync->{gmail1} ) {
$mysync->{ debug } and myprint( "gmail1\n" ) ;
gmail1( $mysync ) ;
}
if ( $mysync->{gmail2} ) {
$mysync->{ debug } and myprint( "gmail2\n" ) ;
gmail2( $mysync ) ;
}
# Office 365
if ( $mysync->{office1} ) {
office1( $mysync ) ;
}
if ( $mysync->{office2} ) {
office2( $mysync ) ;
}
# Exchange
if ( $mysync->{exchange1} ) {
exchange1( $mysync ) ;
}
if ( $mysync->{exchange2} ) {
exchange2( $mysync ) ;
}
# Domino
if ( $mysync->{domino1} ) {
domino1( $mysync ) ;
}
if ( $mysync->{domino2} ) {
domino2( $mysync ) ;
}
return ;
}
# From and for https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt
sub gmail12
{
my $mysync = shift @ARG ;
# Gmail at host1 and host2
$mysync->{host1} ||= 'imap.gmail.com' ;
$mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ;
$mysync->{host2} ||= 'imap.gmail.com' ;
$mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ;
$mysync->{maxbytespersecond} ||= 20_000 ; # should be less than 10_000 when computed from Gmail documentation
$mysync->{maxbytesafter} ||= 1_000_000_000 ; # In fact it is documented as half: 500_000_000
$mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ;
$mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ;
$mysync->{ skipcrossduplicates } = ( defined $mysync->{ skipcrossduplicates } ) ? $mysync->{ skipcrossduplicates } : 0 ;
$mysync->{ synclabels } = ( defined $mysync->{ synclabels } ) ? $mysync->{ synclabels } : 1 ;
$mysync->{ resynclabels } = ( defined $mysync->{ resynclabels } ) ? $mysync->{ resynclabels } : 1 ;
push @useheader, 'X-Gmail-Received', 'Message-Id' ;
push @exclude, '\[Gmail\]$' ;
push @folderlast, '[Gmail]/All Mail' ;
return ;
}
sub gmail1
{
my $mysync = shift @ARG ;
# Gmail at host2
$mysync->{host1} ||= 'imap.gmail.com' ;
$mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ;
$mysync->{maxbytespersecond} ||= 40_000 ; # should be 30_000 computed from by Gmail documentation
$mysync->{maxbytesafter} ||= 3_000_000_000 ; #
$mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ;
$mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ;
$mysync->{ skipcrossduplicates } = ( defined $mysync->{ skipcrossduplicates } ) ? $mysync->{ skipcrossduplicates } : 1 ;
push @useheader, 'X-Gmail-Received', 'Message-Id' ;
push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ;
push @folderlast, '[Gmail]/All Mail' ;
return ;
}
sub gmail2
{
my $mysync = shift @ARG ;
# Gmail at host2
$mysync->{ host2 } ||= 'imap.gmail.com' ;
$mysync->{ ssl2 } = ( defined $mysync->{ ssl2 } ) ? $mysync->{ ssl2 } : 1 ;
$mysync->{ maxbytespersecond } ||= 20_000 ; # should be less than 10_000 computed from by Gmail documentation
$mysync->{ maxbytesafter } ||= 1_000_000_000 ; # In fact it is documented as half: 500_000_000
$mysync->{ automap } = ( defined $mysync->{ automap } ) ? $mysync->{ automap } : 1 ;
$mysync->{ expunge1 } = ( defined $mysync->{ expunge1 } ) ? $mysync->{ expunge1 } : 1 ;
$mysync->{ addheader } = ( defined $mysync->{ addheader } ) ? $mysync->{ addheader } : 1 ;
$mysync->{ maxsleep } = ( defined $mysync->{ maxsleep } ) ? $mysync->{ maxsleep } : $MAX_SLEEP ; ;
#$mysync->{ maxsize } = ( defined $mysync->{ maxsize } ) ? $mysync->{ maxsize } : $GMAIL_MAXSIZE ;
if ( ! $mysync->{ noexclude } ) {
push @exclude, '\[Gmail\]$' ;
}
push @useheader, 'Message-Id' ;
push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ;
# push @{ $mysync->{ regextrans2 } }, 's/[ ]+/_/g' ; # is now replaced
# by the two more specific following regexes,
# they remove just the beginning and trailing blanks, not all.
push @{ $mysync->{ regextrans2 } }, 's,^ +| +$,,g' ;
push @{ $mysync->{ regextrans2 } }, 's,/ +| +/,/,g' ;
#
push @{ $mysync->{ 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 @ARG ;
output( $mysync, q{Option --office1 is like: --host1 outlook.office365.com --ssl1 --exclude "^Files$"} . "\n" ) ;
output( $mysync, "Option --office1 (cont) : unless overrided with --host1 otherhost --nossl1 --noexclude\n" ) ;
$mysync->{host1} ||= 'outlook.office365.com' ;
$mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ;
if ( ! $mysync->{noexclude} ) {
push @exclude, '^Files$' ;
}
return ;
}
sub office2
{
# Office 365 at host2
my $mysync = shift @ARG ;
output( $mysync, qq{Option --office2 is like: --host2 outlook.office365.com --ssl2 --maxsize 45_000_000 --maxmessagespersecond 4\n} ) ;
output( $mysync, qq{Option --office2 (cont) : --disarmreadreceipts --regexmess "wrap 10500" --f1f2 "Files=Files_renamed_by_imapsync"\n} ) ;
output( $mysync, qq{Option --office2 (cont) : unless overrided with --host2 otherhost --nossl2 ... --nodisarmreadreceipts --noregexmess\n} ) ;
output( $mysync, qq{Option --office2 (cont) : and --nof1f2 to avoid Files folder renamed to Files_renamed_by_imapsync\n} ) ;
$mysync->{host2} ||= 'outlook.office365.com' ;
$mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ;
$mysync->{ maxsize } ||= 45_000_000 ;
$mysync->{maxmessagespersecond} ||= 4 ;
#push @{ $mysync->{ regexflag } }, 's/\\\\Flagged//g' ; # No problem without! tested 2018_09_10
$disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ;
# I dislike double negation but here is one
if ( ! $mysync->{noregexmess} )
{
push @regexmess, 's,(.{10239}),$1\r\n,g' ;
}
# and another...
if ( ! $mysync->{nof1f2} )
{
push @{ $mysync->{f1f2} }, 'Files=Files_renamed_by_imapsync' ;
}
return ;
}
sub exchange1
{
# Exchange 2010/2013 at host1
my $mysync = shift @ARG ;
output( $mysync, "Option --exchange1 does nothing (except printing this line...)\n" ) ;
# Well nothing to do so far
return ;
}
sub exchange2
{
# Exchange 2010/2013 at host2
my $mysync = shift @ARG ;
output( $mysync, "Option --exchange2 is like: --maxsize 10_000_000 --maxmessagespersecond 4 --disarmreadreceipts\n" ) ;
output( $mysync, "Option --exchange2 (cont) : --regexflag del Flagged --regexmess wrap 10500\n" ) ;
output( $mysync, "Option --exchange2 (cont) : unless overrided with --maxsize xxx --nodisarmreadreceipts --noregexflag --noregexmess\n" ) ;
$mysync->{ maxsize } ||= 10_000_000 ;
$mysync->{maxmessagespersecond} ||= 4 ;
$disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ;
# I dislike double negation but here are two
if ( ! $mysync->{noregexflag} ) {
push @{ $mysync->{ regexflag } }, 's/\\\\Flagged//g' ;
}
if ( ! $mysync->{noregexmess} ) {
push @regexmess, 's,(.{10239}),$1\r\n,g' ;
}
return ;
}
sub domino1
{
# Domino at host1
my $mysync = shift @ARG ;
$mysync->{ sep1 } = q{\\} ;
$prefix1 = q{} ;
$messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ;
return ;
}
sub domino2
{
# Domino at host1
my $mysync = shift @ARG ;
$mysync->{ sep2 } = q{\\} ;
$prefix2 = q{} ;
$messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ;
push @{ $mysync->{ regextrans2 } }, 's,^Inbox\\\\(.*),$1,i' ;
return ;
}
sub tests_resolv
{
note( 'Entering tests_resolv()' ) ;
# is( , resolv( ), 'resolv: => ' ) ;
is( undef, resolv( ), 'resolv: no args => undef' ) ;
is( undef, resolv( q{} ), '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( '2001:41d0:2:84e0::1', resolv( 'imapsync.lamiral.info' ), 'resolv: imapsync.lamiral.info => 2001:41d0:2:84e0::1' ) ;
# ip6-localhost ( in /etc/hosts )
is( '::1', resolv( 'ip6-localhost' ), 'resolv: ip6-localhost => ::1' ) ;
is( '::1', resolv( '::1' ), 'resolv: ::1 => ::1' ) ;
# ks2ipv6 now has CNAME ks6ipv6
is( '2001:41d0:8:d8b6::1', resolv( '2001:41d0:8:d8b6::1' ), 'resolv: 2001:41d0:8:d8b6::1 => 2001:41d0:8:d8b6::1' ) ;
is( '2001:41d0:8:9951::1', resolv( 'ks6ipv6.lamiral.info' ), 'resolv: ks6ipv6.lamiral.info => 2001:41d0:8:9951::1' ) ;
# ks6
is( '2001:41d0:8:9951::1', resolv( '2001:41d0:8:9951::1' ), 'resolv: 2001:41d0:8:9951::1 => 2001:41d0:8:9951::1' ) ;
is( '2001:41d0:8:9951::1', resolv( 'ks6ipv6.lamiral.info' ), 'resolv: ks6ipv6.lamiral.info => 2001:41d0:8:9951::1' ) ;
# ks3
is( '2001:41d0:8:bebd::1', resolv( '2001:41d0:8:bebd::1' ), 'resolv: 2001:41d0:8:bebd::1 => 2001:41d0:8:bebd::1' ) ;
is( '2001:41d0:8:bebd::1', resolv( 'ks3ipv6.lamiral.info' ), 'resolv: ks3ipv6.lamiral.info => 2001:41d0:8:bebd::1' ) ;
note( 'Leaving tests_resolv()' ) ;
return ;
}
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 ;
$sync->{ debug } and myprint( "Entering resolv_with_getaddrinfo( $host )\n" ) ;
if ( ! $host ) { return ; }
my ( $err_getaddrinfo, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ;
if ( $err_getaddrinfo ) {
myprint( "Cannot getaddrinfo of $host: $err_getaddrinfo\n" ) ;
return ;
}
my @addr ;
while( my $ai = shift @res ) {
my ( $err_getnameinfo, $ipaddr ) = Socket::getnameinfo( $ai->{addr}, Socket::NI_NUMERICHOST(), Socket::NIx_NOSERV() ) ;
if ( $err_getnameinfo ) {
myprint( "Cannot getnameinfo of $host: $err_getnameinfo\n" ) ;
return ;
}else{
$sync->{ debug } and myprint( "$host => $ipaddr\n" ) ;
push @addr, $ipaddr ;
my $reverse ;
( $err_getnameinfo, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ;
$sync->{ debug } and myprint( "$host => $ipaddr => $reverse\n" ) ;
}
$sync->{ debug } and myprint( "$host => $ipaddr\n" ) ;
}
$sync->{ debug } and myprint( "Leaving resolv_with_getaddrinfo( $host => $addr[0])\n" ) ;
return $addr[0] ;
}
sub tests_resolvrev
{
note( 'Entering tests_resolvrev()' ) ;
# is( , resolvrev( ), 'resolvrev: => ' ) ;
is( undef, resolvrev( ), 'resolvrev: no args => undef' ) ;
is( undef, resolvrev( q{} ), '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( 'ks6ipv6.lamiral.info', resolvrev( '2001:41d0:8:d8b6::1' ), 'resolvrev: 2001:41d0:8:d8b6::1 => ks6ipv6.lamiral.info' ) ;
is( 'ks6ipv6.lamiral.info', resolvrev( 'ks6ipv6.lamiral.info' ), 'resolvrev: ks6ipv6.lamiral.info => ks6ipv6.lamiral.info' ) ;
# ks3
is( 'ks3ipv6.lamiral.info', resolvrev( '2001:41d0:8:bebd::1' ), 'resolvrev: 2001:41d0:8:bebd::1 => ks3ipv6.lamiral.info' ) ;
is( 'ks3ipv6.lamiral.info', resolvrev( 'ks3ipv6.lamiral.info' ), 'resolvrev: ks3ipv6.lamiral.info => ks3ipv6.lamiral.info' ) ;
note( 'Leaving tests_resolvrev()' ) ;
return ;
}
sub resolvrev
{
my $host = shift @ARG ;
if ( ! $host ) { return ; }
if ( defined &Socket::getaddrinfo ) {
my $name = resolvrev_with_getaddrinfo( $host ) ;
return( $name ) ;
}
return ;
}
sub resolvrev_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 ;
}
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 ;
}
$sync->{ debug } and myprint( "$host => $reverse\n" ) ;
push @name, $reverse ;
}
return $name[0] ;
}
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( 'ks6ipv6.lamiral.info' ), 'imapsping: ks6ipv6.lamiral.info => 1' ) ;
note( 'Leaving tests_imapsping()' ) ;
return ;
}
sub imapsping
{
my $host = shift @ARG ;
return tcpping( $host, $IMAP_SSL_PORT ) ;
}
sub tests_tcpping
{
note( 'Entering tests_tcpping()' ) ;
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' ) ;
# 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' ) ;
note( 'Leaving tests_tcpping()' ) ;
return ;
}
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 ) ;
$sync->{ debug } and myprint( "Host $host timeout $mytimeout port $port ok $ping_ok ip $ip acked in $rtt_approx s\n" ) ;
$p->close( ) ;
if( $ping_ok ) {
return 1 ;
}else{
return 0 ;
}
}
sub tests_sslcheck
{
note( 'Entering tests_sslcheck()' ) ;
my $mysync ;
is( undef, sslcheck( $mysync ), 'sslcheck: no sslcheck => undef' ) ;
$mysync = {
sslcheck => 1,
} ;
is( 0, sslcheck( $mysync ), 'sslcheck: no host => 0' ) ;
$mysync = {
sslcheck => 1,
host1 => 'test1.lamiral.info',
tls1 => 1,
} ;
is( 0, sslcheck( $mysync ), 'sslcheck: tls1 => 0' ) ;
$mysync = {
sslcheck => 1,
host1 => 'test1.lamiral.info',
} ;
is( 1, sslcheck( $mysync ), 'sslcheck: test1.lamiral.info => 1' ) ;
is( 1, $mysync->{ssl1}, 'sslcheck: test1.lamiral.info => ssl1 1' ) ;
$mysync->{sslcheck} = 0 ;
is( undef, sslcheck( $mysync ), 'sslcheck: sslcheck off => undef' ) ;
$mysync = {
sslcheck => 1,
host1 => 'test1.lamiral.info',
host2 => 'test2.lamiral.info',
} ;
is( 2, sslcheck( $mysync ), 'sslcheck: test1.lamiral.info + test2.lamiral.info => 2' ) ;
$mysync = {
sslcheck => 1,
host1 => 'test1.lamiral.info',
host2 => 'test2.lamiral.info',
tls1 => 1,
} ;
is( 1, sslcheck( $mysync ), 'sslcheck: test1.lamiral.info + test2.lamiral.info + tls1 => 1' ) ;
note( 'Leaving tests_sslcheck()' ) ;
return ;
}
sub sslcheck
{
my $mysync = shift @ARG ;
if ( ! $mysync->{sslcheck} ) {
return ;
}
my $nb_on = 0 ;
$mysync->{ debug } and myprint( "sslcheck\n" ) ;
if (
( ! defined $mysync->{port1} )
and
( ! defined $mysync->{tls1} )
and
( ! defined $mysync->{ssl1} )
and
( defined $mysync->{host1} )
) {
myprint( "Host1: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ;
if ( probe_imapssl( $mysync->{host1} ) ) {
$mysync->{ssl1} = 1 ;
myprint( "Host1: sslcheck detected open ssl port $IMAP_SSL_PORT so turning ssl on (use --nossl1 --notls1 to turn off SSL and TLS wizardry)\n" ) ;
$nb_on++ ;
}else{
myprint( "Host1: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ;
}
}
if (
( ! defined $mysync->{port2} )
and
( ! defined $mysync->{tls2} )
and
( ! defined $mysync->{ssl2} )
and
( defined $mysync->{host2} )
) {
myprint( "Host2: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ;
if ( probe_imapssl( $mysync->{host2} ) ) {
$mysync->{ssl2} = 1 ;
myprint( "Host2: sslcheck detected open ssl port $IMAP_SSL_PORT so turning ssl on (use --nossl2 --notls2 to turn off SSL and TLS wizardry)\n" ) ;
$nb_on++ ;
}else{
myprint( "Host2: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ;
}
}
return $nb_on ;
}
sub testslive_init
{
my $mysync = shift @ARG ;
$mysync->{host1} ||= 'test1.lamiral.info' ;
$mysync->{user1} ||= 'test1' ;
$mysync->{password1} ||= 'secret1' ;
$mysync->{host2} ||= 'test2.lamiral.info' ;
$mysync->{user2} ||= 'test2' ;
$mysync->{password2} ||= 'secret2' ;
return ;
}
sub testslive6_init
{
my $mysync = shift @ARG ;
$mysync->{host1} ||= 'ks6ipv6.lamiral.info' ;
$mysync->{user1} ||= 'test1' ;
$mysync->{password1} ||= 'secret1' ;
$mysync->{host2} ||= 'ks6ipv6.lamiral.info' ;
$mysync->{user2} ||= 'test2' ;
$mysync->{password2} ||= 'secret2' ;
return ;
}
sub tests_backslash_caret
{
note( 'Entering tests_backslash_caret()' ) ;
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' ) ;
note( 'Leaving tests_backslash_caret()' ) ;
return ;
}
sub backslash_caret
{
my $string = shift @ARG ;
$string =~ s{\\ $ }{^}gxms ;
return $string ;
}
sub tests_split_around_equal
{
note( 'Entering tests_split_around_equal()' ) ;
is( undef, split_around_equal( ), 'split_around_equal: no args => undef' ) ;
is_deeply( { toto => 'titi' }, { split_around_equal( 'toto=titi' ) }, 'split_around_equal: toto=titi => toto => titi' ) ;
is_deeply( { toto => undef }, { split_around_equal( 'toto' ) }, 'split_around_equal: tototiti => toto => undef' ) ;
is_deeply( { toto => '' }, { split_around_equal( 'toto=' ) }, 'split_around_equal: tototiti => toto= => empty' ) ;
is_deeply( { A => 'B', C => 'D' }, { split_around_equal( 'A=B', 'C=D' ) }, 'split_around_equal: A=B C=D => A => B, C=>D' ) ;
is_deeply( { A => 'B', C => 'D', E => 'F' }, { split_around_equal( 'A=B', 'C=D', 'E=F' ) }, 'split_around_equal: A=B C=D => A => B, C=>D' ) ;
is_deeply( { A => 'B=C' }, { split_around_equal( 'A=B=C' ) }, 'split_around_equal: A=B=C => A => B=C' ) ;
is_deeply( { A => 'B=C=D' }, { split_around_equal( 'A=B=C=D' ) }, 'split_around_equal: A=B=C=D => A => B=C=D' ) ;
note( 'Leaving tests_split_around_equal()' ) ;
return ;
}
sub split_around_equal
{
if ( ! @ARG ) { return ; } ;
return map { split( /=/mxs, $_, 2 ) } @ARG ;
}
sub tests_sig_install
{
note( 'Entering tests_sig_install()' ) ;
my $mysync ;
is( undef, sig_install( ), 'sig_install: no args => undef' ) ;
is( undef, sig_install( $mysync ), 'sig_install: arg undef => undef' ) ;
$mysync = { } ;
is( undef, sig_install( $mysync ), 'sig_install: empty hash => undef' ) ;
SKIP: {
Readonly my $SKIP_15 => 15 ;
if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests only for Unix', $SKIP_15 ) ; }
# Default to ignore USR1 USR2 in case future install fails
local $SIG{ USR1 } = local $SIG{ USR2 } = sub { } ;
kill( 'USR1', $PROCESS_ID ) ;
$mysync->{ debugsig } = 1 ;
# Assign USR1 to call sub tototo
# Surely a better value than undef should be returned when doing real signal stuff
is( undef, sig_install( $mysync, 'tototo', 'USR1' ), 'sig_install: USR1 tototo' ) ;
is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 1' ) ;
is( 1, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 1' ) ;
#return ;
# Assign USR2 to call sub tototo
is( undef, sig_install( $mysync, 'tototo', 'USR2' ), 'sig_install: USR2 tototo' ) ;
is( 1, kill( 'USR2', $PROCESS_ID ), 'sig_install: kill USR2 myself 1' ) ;
is( 2, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 2' ) ;
is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 2' ) ;
is( 3, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 3' ) ;
local $SIG{ USR1 } = local $SIG{ USR2 } = sub { } ;
is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 3' ) ;
is( 3, $mysync->{ tototo_calls }, 'sig_install: tototo call still nb 3' ) ;
# Assign USR1 + USR2 to call sub tototo
is( undef, sig_install( $mysync, 'tototo', 'USR1', 'USR2' ), 'sig_install: USR1 USR2 tototo' ) ;
is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 4' ) ;
is( 4, $mysync->{ tototo_calls }, 'sig_install: tototo call now nb 4' ) ;
is( 1, kill( 'USR2', $PROCESS_ID ), 'sig_install: kill USR1 myself 2' ) ;
is( 5, $mysync->{ tototo_calls }, 'sig_install: tototo call now nb 5' ) ;
}
note( 'Leaving tests_sig_install()' ) ;
return ;
}
#
sub sig_install
{
my $mysync = shift @ARG ;
if ( ! $mysync ) { return ; }
my $mysubname = shift @ARG ;
if ( ! $mysubname ) { return ; }
if ( ! @ARG ) { return ; }
my @signals = @ARG ;
my $mysub = \&$mysubname ;
#$mysync->{ debugsig } = 1 ;
$mysync->{ debugsig } and myprint( "In sig_install with sub $mysubname and signal @ARG\n" ) ;
my $subsignal = sub {
my $signame = shift @ARG ;
$mysync->{ debugsig } and myprint( "In subsignal with $signame and $mysubname\n" ) ;
&$mysub( $mysync, $signame ) ;
} ;
foreach my $signal ( @signals ) {
$mysync->{ debugsig } and myprint( "Installing signal $signal to call sub $mysubname\n") ;
output( $mysync, "kill -$signal $PROCESS_ID # special behavior: call to sub $mysubname\n" ) ;
## no critic (RequireLocalizedPunctuationVars)
$SIG{ $signal } = $subsignal ;
}
return ;
}
sub tototo
{
my $mysync = shift @ARG ;
myprint("In tototo with @ARG\n" ) ;
$mysync->{ tototo_calls } += 1 ;
return ;
}
sub mygetppid
{
if ( 'MSWin32' eq $OSNAME ) {
return( 'unknown under MSWin32 (too complicated)' ) ;
} else {
# Unix
return( getppid( ) ) ;
}
}
sub tests_toggle_sleep
{
note( 'Entering tests_toggle_sleep()' ) ;
is( undef, toggle_sleep( ), 'toggle_sleep: no args => undef' ) ;
my $mysync ;
is( undef, toggle_sleep( $mysync ), 'toggle_sleep: undef => undef' ) ;
$mysync = { } ;
is( undef, toggle_sleep( $mysync ), 'toggle_sleep: no maxsleep => undef' ) ;
$mysync->{maxsleep} = 3 ;
is( 0, toggle_sleep( $mysync ), 'toggle_sleep: 3 => 0' ) ;
is( $MAX_SLEEP, toggle_sleep( $mysync ), "toggle_sleep: 0 => $MAX_SLEEP" ) ;
is( 0, toggle_sleep( $mysync ), "toggle_sleep: $MAX_SLEEP => 0" ) ;
is( $MAX_SLEEP, toggle_sleep( $mysync ), "toggle_sleep: 0 => $MAX_SLEEP" ) ;
is( 0, toggle_sleep( $mysync ), "toggle_sleep: $MAX_SLEEP => 0" ) ;
SKIP: {
Readonly my $SKIP_9 => 9 ;
if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests only for Unix', $SKIP_9 ) ; }
# Default to ignore USR1 USR2 in case future install fails
local $SIG{ USR1 } = sub { } ;
kill( 'USR1', $PROCESS_ID ) ;
$mysync->{ debugsig } = 1 ;
# Assign USR1 to call sub toggle_sleep
is( undef, sig_install( $mysync, \&toggle_sleep, 'USR1' ), 'toggle_sleep: install USR1 toggle_sleep' ) ;
$mysync->{maxsleep} = 4 ;
is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself' ) ;
is( 0, $mysync->{ maxsleep }, 'toggle_sleep: toggle_sleep called => sleeps are 0s' ) ;
is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself again' ) ;
is( $MAX_SLEEP, $mysync->{ maxsleep }, "toggle_sleep: toggle_sleep called => sleeps are ${MAX_SLEEP}s" ) ;
is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself' ) ;
is( 0, $mysync->{ maxsleep }, 'toggle_sleep: toggle_sleep called => sleeps are 0s' ) ;
is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself again' ) ;
is( $MAX_SLEEP, $mysync->{ maxsleep }, "toggle_sleep: toggle_sleep called => sleeps are ${MAX_SLEEP}s" ) ;
}
note( 'Leaving tests_toggle_sleep()' ) ;
return ;
}
sub toggle_sleep
{
my $mysync = shift @ARG ;
myprint("In toggle_sleep with @ARG\n" ) ;
if ( !defined( $mysync ) ) { return ; }
if ( !defined( $mysync->{maxsleep} ) ) { return ; }
$mysync->{ maxsleep } = max( 0, $MAX_SLEEP - $mysync->{maxsleep} ) ;
myprint("Resetting maxsleep to ", $mysync->{maxsleep}, "s\n" ) ;
return $mysync->{maxsleep} ;
}
sub mypod2usage
{
my $fh_pod2usage = shift @ARG ;
pod2usage(
-exitval => 'NOEXIT',
-noperldoc => 1,
-verbose => 99,
-sections => [ qw(NAME VERSION USAGE OPTIONS) ],
-indent => 1,
-loose => 1,
-output => $fh_pod2usage,
) ;
return ;
}
sub usage
{
my $mysync = shift @ARG ;
if ( ! defined $mysync ) { return ; }
my $usage = q{} ;
my $usage_from_pod ;
my $usage_footer = usage_footer( $mysync ) ;
# pod2usage writes on a filehandle only and I want a variable
open my $fh_pod2usage, ">", \$usage_from_pod
or do { warn $OS_ERROR ; return ; } ;
mypod2usage( $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 ) ;
return( $usage ) ;
}
sub tests_usage
{
note( 'Entering tests_usage()' ) ;
my $usage ;
like( $usage = usage( $sync ), qr/Name:/, 'usage: contains Name:' ) ;
myprint( $usage ) ;
like( $usage, qr/Version:/, 'usage: contains Version:' ) ;
like( $usage, qr/Usage:/, 'usage: contains Usage:' ) ;
like( $usage, qr/imapsync/, 'usage: contains imapsync' ) ;
is( undef, usage( ), 'usage: no args => undef' ) ;
note( 'Leaving tests_usage()' ) ;
return ;
}
sub usage_footer
{
my $mysync = shift @ARG ;
my $footer = q{} ;
my $localhost_info = localhost_info( $mysync ) ;
my $rcs = $mysync->{rcs} ;
my $homepage = homepage( ) ;
my $imapsync_release = $STR_use_releasecheck ;
if ( $mysync->{releasecheck} ) {
$imapsync_release = check_last_release( ) ;
}
$footer = qq{$localhost_info
$rcs
$imapsync_release
$homepage
} ;
return( $footer ) ;
}
sub usage_complete
{
# 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.
--allowsizemismatch : allow RFC822.SIZE != fetched msg size
consider also --skipsize to avoid duplicate messages
when running syncs more than one time per mailbox
--reconnectretry1 int : reconnect to host1 if connection is lost up to
int times per imap command (default is 3)
--reconnectretry2 int : same as --reconnectretry1 but for host2
--split1 int : split the requests in several parts on host1.
int is the number of messages handled per request.
default is like --split1 100.
--split2 int : same thing on host2.
--nofixInboxINBOX : Don't fix Inbox INBOX mapping.
EOF
return( $usage ) ;
}
sub setvalfromcgikey
{
my ( $mysync, $mycgi, $key, $val ) = @ARG ;
my $badthings = 0 ;
my ( $name, $type, $struct ) ;
if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/mxs )
{
$badthings++ ;
next ; # Unknown item
}
else
{
$name = [ split '|', $1, 1 ]->[0] ; # option name ab|cd|ef => keep only ab
$type = $2 ; # = or : followed by i or s or f
$struct = $3 ; # + or ! or @ or %
}
if ( ( $struct || q{} ) eq '+' )
{
${$val} = $mycgi->param( $name ) ; # "Incremental" integer
}
elsif ( $type )
{
my @values = $mycgi->multi_param( $name ) ;
#myprint( "type[$type]values[@values]\$struct[", $struct || q{}, "]val[$val]ref(val)[", ref($val), "]\n" ) ;
if ( ( $struct || q{} ) eq '%' or ref( $val ) eq 'HASH' )
{
setvalfromhash( $val, $type, @values ) ;
}
else
{
setvalfromlist( $mysync, $val, $name, $type, $struct, @values ) ;
}
}
else
{
setvalfromcheckbox( $mysync, $mycgi, $key, $name, $val ) ;
}
return $badthings ;
}
sub setvalfromlist
{
my ( $mysync, $val, $name, $type, $struct, @values ) = @ARG ;
if ( $type =~ m/i$/mxs )
{
@values = map { q{} ne $_ ? int $_ : undef } @values ;
}
elsif ( $type =~ m/f$/mxs )
{
@values = map { 0 + $_ } @values ;
}
if ( ( $struct || q{} ) eq '@' )
{
@{ ${$val} } = @values ;
my @option = map { +( "--$name", "$_" ) } @values ;
push @{ $mysync->{ cmdcgi } }, @option ;
}
elsif ( ref( $val ) eq 'ARRAY' )
{
@{$val} = @values ;
}
elsif ( my $value = $values[0] )
{
${$val} = $value ;
push @{ $mysync->{ cmdcgi } }, "--$name", $value ;
}
else
{
}
return ;
}
sub setvalfromhash
{
my ( $val, $type, @values ) = @ARG ;
my %values = map { split /=/mxs, $_ } @values ;
if ( $type =~ m/i$/mxs )
{
foreach my $k ( keys %values )
{
$values{$k} = int $values{$k} ;
}
}
elsif ( $type =~ m/f$/mxs )
{
foreach my $k ( keys %values ) {
$values{$k} = 0 + $values{$k};
}
}
if ( 'REF' eq ref $val )
{
%{ ${$val} } = %values ;
}
else
{
%{$val} = %values ;
}
return ;
}
sub setvalfromcheckbox
{
my ( $mysync, $mycgi, $key, $name, $val ) = @ARG ;
# Checkbox
# --noname is set by name=0 or name=
my $value = $mycgi->param( $name ) ;
if ( defined $value )
{
${$val} = $value ;
if ( $value )
{
push @{ $mysync->{ cmdcgi } }, "--$name" ;
}
else
{
push @{ $mysync->{ cmdcgi } }, "--no$name" ;
}
}
else
{
${$val} = undef ;
}
return ;
}
sub myGetOptions
{
# 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.
# It also applies for the sub functions called from this one.
my $mysync = shift @ARG ;
my $arguments_ref = shift @ARG ;
my %options = @ARG ;
my $mycgi = $mysync->{cgi} ;
if ( not under_cgi_context() ) {
# Not CGI - pass upstream for normal command line handling
return Getopt::Long::GetOptionsFromArray( $arguments_ref, %options ) ;
}
# We must be in CGI context now
if ( ! defined( $mycgi ) ) { return ; }
my $badthings = 0 ;
foreach my $key ( sort keys %options ) {
my $val = $options{$key} ;
$badthings += setvalfromcgikey( $mysync, $mycgi, $key, $val ) ;
}
if ( $badthings ) {
return ; # undef or ()
}
else {
return ( 1 ) ;
}
}
sub tests_get_options_extra
{
note( 'Entering tests_get_options_extra()' ) ;
is( undef, get_options_extra( ), 'get_options_extra: no args => undef' ) ;
my $mysync = { } ;
is( undef, get_options_extra( $mysync ), 'get_options_extra: undef => undef' ) ;
my $cwd_save = getcwd( ) ;
ok( (-d 'W/tmp/tests/options_extra/' or mkpath( 'W/tmp/tests/options_extra/' )), 'get_options_extra: mkpath W/tmp/tests/options_extra/' ) ;
chdir 'W/tmp/tests/options_extra/' ;
is( '--debugimap1', string_to_file( '--debugimap1', 'options_extra.txt' ), 'get_options_extra: string_to_file filling options_extra.txt with --debugimap1' ) ;
is( '--debugimap1', file_to_string( 'options_extra.txt' ), 'get_options_extra: reading options_extra.txt is --debugimap1' ) ;
is( '', get_options_extra( $mysync ), 'get_options_extra: --debugimap1 in options_extra.txt => nothing left, empty string return' ) ;
is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_extra: --debugimap1 in options_extra.txt => ok, acc1->debugimap = 1' ) ;
is( '--tls1 proutcaca', string_to_file( '--tls1 proutcaca', 'options_extra.txt' ), 'get_options_extra: string_to_file filling options_extra.txt with --tls1 proutcaca' ) ;
is( 'proutcaca', get_options_extra( $mysync ), 'get_options_extra: --tls1 proutcaca in options_extra.txt => proutcaca left, proutcaca return' ) ;
chdir $cwd_save ;
note( 'Leaving tests_get_options_extra()' ) ;
return ;
}
sub get_options_extra
{
my $mysync = shift @ARG ;
if ( ! defined $mysync ) { return ; }
if ( -f -r 'options_extra.txt' )
{
my $cwd = getcwd( ) ;
my $string = firstline( 'options_extra.txt' ) ;
my $rest = get_options_from_string( $mysync, $string ) ;
output( $mysync, "Reading extra options from file options_extra.txt (cwd: $cwd) : $string\n" ) ;
return $rest ;
}
else
{
return ;
}
}
sub tests_get_options_from_string
{
note( 'Entering tests_get_options_from_string()' ) ;
is( undef, get_options_from_string( ), 'get_options_from_string: no args => undef' ) ;
my $mysync = { } ;
is( undef, get_options_from_string( $mysync ), 'get_options_from_string: undef => undef' ) ;
is( '', get_options_from_string( $mysync, '--debugimap1' ),
'get_options_from_string: --debugimap1 => ok, nothing left, empty string return' ) ;
is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: --debugimap1 => ok, acc1->debugimap = 1' ) ;
$mysync = { } ; # reset
is( 'caca', get_options_from_string( $mysync, '--debugimap1 caca' ),
'get_options_from_string: --debugimap1 caca => ok, caca left, caca return' ) ;
is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: --debugimap1 => ok, acc1->debugimap = 1' ) ;
is( 'popo roro', get_options_from_string( $mysync, '--debugimap2 popo roro' ),
'get_options_from_string: --debugimap1 popo roro => ok, popo roro left, popo roro return' ) ;
is( 1, $mysync->{ acc2 }->{ debugimap }, 'get_options_from_string: --debugimap2 popo roro => ok, acc2->debugimap = 1' ) ;
is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: acc1->debugimap = 1 still' ) ;
is( '', get_options_from_string( $mysync, '--nodebugimap1 --debugflags --errorsmax 2' ),
'get_options_from_string: --nodebugimap1 --debugflags --errorsmax 2 => ok, empty string return' ) ;
is( 0, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: acc1->debugimap = 0 now' ) ;
is( 1, $mysync->{ debugflags }, 'get_options_from_string: debugflags = 1 now' ) ;
is( 2, $mysync->{ errorsmax }, 'get_options_from_string: mysync->errorsmax = 2 now' ) ;
is( '', get_options_from_string( $mysync, '--folder "IN BOX" --folder JOE' ),
'get_options_from_string: --folder "IN BOX" --folder JOE => ok, empty string return' ) ;
is_deeply( [ 'IN BOX', 'JOE' ], [@{$mysync->{ folder }}], 'get_options_from_string: "IN BOX" "JOE"' ) ;
is( '', get_options_from_string( $mysync, '--debugflags --koko' ),
'get_options_from_string: --debugflags --koko => ok, empty string return, with "Unknown option: koko" on STDERR' ) ;
note( 'Leaving tests_get_options_from_string()' ) ;
return ;
}
sub get_options_from_string
{
my $mysync = shift @ARG ;
my $mystring = shift @ARG ;
if ( ! defined $mystring ) { return ; }
my ( $ret, $args ) = Getopt::Long::GetOptionsFromString( $mystring,
'debugimap!' => \$mysync->{ debugimap },
'debugimap1!' => \$mysync->{ acc1 }->{ debugimap },
'debugimap2!' => \$mysync->{ acc2 }->{ debugimap },
'debugflags!' => \$mysync->{ debugflags },
'debugsleep=f' => \$mysync->{ debugsleep },
'errorsmax=i' => \$mysync->{ errorsmax },
'folder=s@' => \$mysync->{ folder },
'timeout=f' => \$mysync->{ timeout },
'timeout1=f' => \$mysync->{ acc1 }->{ timeout },
'timeout2=f' => \$mysync->{ acc2 }->{ timeout },
'keepalive1!' => \$mysync->{ acc1 }->{ keepalive },
'keepalive2!' => \$mysync->{ acc2 }->{ keepalive },
'reconnectretry1=i' => \$mysync->{ acc1 }->{ reconnectretry },
'reconnectretry2=i' => \$mysync->{ acc2 }->{ reconnectretry },
'ssl1!' => \$mysync->{ ssl1 },
'ssl2!' => \$mysync->{ ssl2 },
'tls1!' => \$mysync->{ tls1 },
'tls2!' => \$mysync->{ tls2 },
'compress1!' => \$mysync->{ acc1 }->{ compress },
'compress2!' => \$mysync->{ acc2 }->{ compress },
) ;
my $left = join( ' ', @$args ) ;
return $left ;
}
sub tests_get_options_cgi_context
{
note( 'Entering tests_get_options_cgi_context()' ) ;
# Temporary, have to think harder about testing CGI context in command line --tests
# 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 ;
is( undef, get_options( $mysync ), 'get_options cgi context: no CGI module => undef' ) ;
# skip all next tests if the CGI module is not available
SKIP: {
if ( ! eval { require CGI ; } ) {
skip( "CGI Perl module is not installed", 19 ) ;
}
CGI->import( qw( -no_debug -utf8 ) ) ;
is( undef, get_options( $mysync ), 'get_options cgi context: no CGI param => undef' ) ;
# Testing boolean
$mysync->{cgi} = CGI->new( 'version=on&debugenv=on' ) ;
local $ENV{'QUERY_STRING'} = 'version=on&debugenv=on' ;
is( 22, get_options( $mysync ), 'get_options cgi context: QUERY_STRING => 22' ) ;
is( 'on', $mysync->{ version }, 'get_options cgi context: --version => on' ) ;
# debugenv is not allowed in cgi context
is( undef, $mysync->{debugenv}, 'get_options cgi context: $mysync->{debugenv} => undef' ) ;
# QUERY_STRING in this test is only for return value of get_options
# Have to think harder, GET/POST context, is this return value a good thing?
local $ENV{'QUERY_STRING'} = 'host1=test1.lamiral.info&user1=test1' ;
$mysync->{cgi} = CGI->new( 'host1=test1.lamiral.info&user1=test1' ) ;
is( 36, get_options( $mysync, ), 'get_options cgi context: QUERY_STRING => 36' ) ;
is( 'test1', $mysync->{user1}, 'get_options cgi context: $mysync->{user1} => test1' ) ;
#local $ENV{'QUERY_STRING'} = undef ;
# Testing s@ as ref
$mysync->{cgi} = CGI->new( 'folder=fd1' ) ;
get_options( $mysync ) ;
is_deeply( [ 'fd1' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1' ) ;
$mysync->{cgi} = CGI->new( 'folder=fd1&folder=fd2' ) ;
get_options( $mysync ) ;
is_deeply( [ 'fd1', 'fd2' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1, fd2' ) ;
# Testing %
$mysync->{cgi} = CGI->new( 'f1f2h=s1=d1&f1f2h=s2=d2&f1f2h=s3=d3' ) ;
get_options( $mysync ) ;
is_deeply( { 's1' => 'd1', 's2' => 'd2', 's3' => 'd3' },
$mysync->{f1f2h}, 'get_options cgi context: f1f2h => s1=d1 s2=d2 s3=d3' ) ;
# Testing boolean ! with --noxxx, doesnot work
$mysync->{cgi} = CGI->new( 'nodry=on' ) ;
get_options( $mysync ) ;
is( undef, $mysync->{dry}, 'get_options cgi context: --nodry => $mysync->{dry} => undef' ) ;
$mysync->{cgi} = CGI->new( 'host1=example.com' ) ;
get_options( $mysync ) ;
is( 'example.com', $mysync->{host1}, 'get_options cgi context: --host1=example.com => $mysync->{host1} => example.com' ) ;
#myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
$mysync->{cgi} = CGI->new( 'simulong=' ) ;
get_options( $mysync ) ;
is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong= => $mysync->{simulong} => undef' ) ;
$mysync->{cgi} = CGI->new( 'simulong' ) ;
get_options( $mysync ) ;
is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong => $mysync->{simulong} => undef' ) ;
$mysync->{cgi} = CGI->new( 'simulong=4' ) ;
get_options( $mysync ) ;
is( 4, $mysync->{simulong}, 'get_options cgi context: --simulong=4 => $mysync->{simulong} => 4' ) ;
is( undef, $mysync->{ folder }, 'get_options cgi context: --simulong=4 => $mysync->{ folder } => undef' ) ;
#myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
$mysync ={} ;
$mysync->{cgi} = CGI->new( 'testslive=on' ) ;
get_options( $mysync ) ;
is( 'on', $mysync->{ testslive }, 'get_options cgi context: --testslive=on => testslive => on' ) ;
#myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
$mysync ={} ;
$mysync->{cgi} = CGI->new( 'log=0' ) ;
get_options( $mysync ) ;
is( 0, $mysync->{ log }, 'get_options cgi context: --log=0 => log => 0' ) ;
#myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
# What is this fucked up indentation?
}
note( 'Leaving tests_get_options_cgi_context()' ) ;
return ;
}
sub get_options_cgi
{
# In CGI context arguments are not in @ARGV but in QUERY_STRING variable (with GET).
my $mysync = shift @ARG ;
$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->{f1f2h} = {} ;
my $opt_ret = myGetOptions(
$mysync,
\@arguments,
'abort' => \$mysync->{ abort },
'abortbyfile' => \$mysync->{ abortbyfile },
'host1=s' => \$mysync->{ host1 },
'host2=s' => \$mysync->{ host2 },
'user1=s' => \$mysync->{ user1 },
'user2=s' => \$mysync->{ user2 },
'password1=s' => \$mysync->{ password1 },
'password2=s' => \$mysync->{ password2 },
'dry!' => \$mysync->{ dry },
'dry1!' => \$mysync->{ dry1 },
'version' => \$mysync->{ version },
'ssl1!' => \$mysync->{ ssl1 },
'ssl2!' => \$mysync->{ ssl2 },
'tls1!' => \$mysync->{ tls1 },
'tls2!' => \$mysync->{ tls2 },
'compress1!' => \$mysync->{ acc1 }->{ compress },
'compress2!' => \$mysync->{ acc2 }->{ compress },
'justbanner!' => \$mysync->{ justbanner },
'justlogin!' => \$mysync->{ justlogin },
'justconnect!' => \$mysync->{ justconnect },
'addheader!' => \$mysync->{ addheader },
'automap!' => \$mysync->{ automap },
'justautomap!' => \$mysync->{ justautomap },
'gmail1' => \$mysync->{ gmail1 },
'gmail2' => \$mysync->{ gmail2 },
'office1' => \$mysync->{ office1 },
'office2' => \$mysync->{ office2 },
'exchange1' => \$mysync->{ exchange1 },
'exchange2' => \$mysync->{ exchange2 },
'domino1' => \$mysync->{ domino1 },
'domino2' => \$mysync->{ domino2 },
'f1f2=s@' => \$mysync->{ f1f2 },
'f1f2h=s%' => \$mysync->{ f1f2h },
'folder=s@' => \$mysync->{ folder },
'testslive!' => \$mysync->{ testslive },
'testslive6!' => \$mysync->{ testslive6 },
'releasecheck!' => \$mysync->{ releasecheck },
'simulong=f' => \$mysync->{ simulong },
'debugsleep=f' => \$mysync->{ debugsleep },
'subfolder1=s' => \$mysync->{ subfolder1 },
'subfolder2=s' => \$mysync->{ subfolder2 },
'justfolders!' => \$mysync->{ justfolders },
'justfoldersizes!' => \$mysync->{ justfoldersizes },
'delete1!' => \$mysync->{ delete1 },
'delete2!' => \$mysync->{ delete2 },
'delete2duplicates!' => \$mysync->{ delete2duplicates },
'tail!' => \$mysync->{ tail },
'tmphash=s' => \$mysync->{ tmphash },
'exitwhenover=i' => \$mysync->{ exitwhenover },
'exitonload!' => \$mysync->{ exitonload },
'syncduplicates!' => \$mysync->{ syncduplicates },
'skipcrossduplicates!' => \$mysync->{ skipcrossduplicates },
'debugcrossduplicates!'=> \$mysync->{ debugcrossduplicates },
'log!' => \$mysync->{ log },
'loglogfile!' => \$mysync->{ loglogfile },
'emailreportfrom=s' => \$mysync->{ email_report_from },
'emailreport1!' => \$mysync->{ emailreport1 },
'emailreport2!' => \$mysync->{ emailreport2 },
'var=s@' => \$mysync->{ var },
# f1f2h=s% could be removed but
# tests_get_options_cgi() should be split before
# with a sub tests_myGetOptions()
) ;
$mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ;
if ( ! $opt_ret ) {
return ;
}
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->{f1f2h} = {} ;
my $opt_ret = myGetOptions(
$mysync,
\@arguments,
'debug!' => \$mysync->{ debug },
'debuglist!' => \$mysync->{ debuglist },
'debugcontent!' => \$mysync->{ debugcontent },
'debugsleep=f' => \$mysync->{ debugsleep },
'debugflags!' => \$mysync->{ debugflags },
'debugimap!' => \$mysync->{ debugimap },
'debugimap1!' => \$mysync->{ acc1 }->{ debugimap },
'debugimap2!' => \$mysync->{ acc2 }->{ debugimap },
'debugdev!' => \$debugdev,
'debugmemory!' => \$mysync->{debugmemory},
'debugfolders!' => \$mysync->{debugfolders},
'debugssl=i' => \$mysync->{debugssl},
'debugcgi!' => \$debugcgi,
'debugenv!' => \$mysync->{debugenv},
'debugsig!' => \$mysync->{debugsig},
'debuglabels!' => \$mysync->{debuglabels},
'simulong=f' => \$mysync->{simulong},
'abort' => \$mysync->{abort},
'abortbyfile' => \$mysync->{abortbyfile},
'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' => \$mysync->{ acc1 }->{ domain },
'domain2=s' => \$mysync->{ acc2 }->{ domain },
'password1=s' => \$mysync->{password1},
'password2=s' => \$mysync->{password2},
'passfile1=s' => \$mysync->{ passfile1 },
'passfile2=s' => \$mysync->{ passfile2 },
'authmd5!' => \$authmd5,
'authmd51!' => \$authmd51,
'authmd52!' => \$authmd52,
'trylogin!' => \$mysync->{ trylogin },
'oauthdirect1=s' => \$mysync->{ acc1 }->{ oauthdirect },
'oauthdirect2=s' => \$mysync->{ acc2 }->{ oauthdirect },
'oauthaccesstoken1=s' => \$mysync->{ acc1 }->{ oauthaccesstoken },
'oauthaccesstoken2=s' => \$mysync->{ acc2 }->{ oauthaccesstoken },
'sep1=s' => \$mysync->{ sep1 },
'sep2=s' => \$mysync->{ sep2 },
'sanitize!' => \$mysync->{ sanitize },
'folder=s@' => \$mysync->{ folder },
'folderrec=s' => \@folderrec,
'include=s' => \@include,
'exclude=s' => \@exclude,
'noexclude' => \$mysync->{noexclude},
'folderfirst=s' => \@folderfirst,
'folderlast=s' => \@folderlast,
'prefix1=s' => \$prefix1,
'prefix2=s' => \$prefix2,
'subfolder1=s' => \$mysync->{ subfolder1 },
'subfolder2=s' => \$mysync->{ subfolder2 },
'fixslash2!' => \$mysync->{ fixslash2 },
'fixInboxINBOX!' => \$fixInboxINBOX,
'regextrans2=s@' => \$mysync->{ regextrans2 },
'mixfolders!' => \$mixfolders,
'skipemptyfolders!' => \$mysync->{ skipemptyfolders },
'regexmess=s' => \@regexmess,
'noregexmess' => \$mysync->{noregexmess},
'skipmess=s' => \@skipmess,
'pipemess=s' => \@pipemess,
'pipemesscheck!' => \$pipemesscheck,
'disarmreadreceipts!' => \$disarmreadreceipts,
'regexflag=s@' => \$mysync->{ regexflag },
'noregexflag' => \$mysync->{ noregexflag },
'filterflags!' => \$mysync->{ filterflags },
'filterbuggyflags!' => \$mysync->{ filterbuggyflags },
'flagscase!' => \$mysync->{ flagscase },
'syncflagsaftercopy!' => \$syncflagsaftercopy,
'resyncflags!' => \$mysync->{ resyncflags },
'synclabels!' => \$mysync->{ synclabels },
'resynclabels!' => \$mysync->{ resynclabels },
'delete|delete1!' => \$mysync->{ delete1 },
'delete2!' => \$mysync->{ delete2 },
'delete2duplicates!' => \$mysync->{ delete2duplicates },
'delete2folders!' => \$delete2folders,
'delete2foldersonly=s' => \$delete2foldersonly,
'delete2foldersbutnot=s' => \$delete2foldersbutnot,
'syncinternaldates!' => \$syncinternaldates,
'idatefromheader!' => \$idatefromheader,
'syncacls!' => \$mysync->{ syncacls },
'maxsize=i' => \$mysync->{ maxsize },
'appendlimit=i' => \$mysync->{ appendlimit },
'truncmess=i' => \$mysync->{ truncmess },
'minsize=i' => \$minsize,
'maxage=f' => \$maxage,
'minage=f' => \$minage,
'search=s' => \$search,
'search1=s' => \$mysync->{ search1 },
'search2=s' => \$mysync->{ search2 },
'foldersizes!' => \$mysync->{ foldersizes },
'foldersizesatend!' => \$mysync->{ foldersizesatend },
'dry!' => \$mysync->{dry},
'dry1!' => \$mysync->{dry1},
'expunge1|expunge!' => \$mysync->{ expunge1 },
'expunge2!' => \$mysync->{ expunge2 },
'uidexpunge2!' => \$mysync->{ uidexpunge2 },
'subscribed' => \$subscribed,
'subscribe!' => \$subscribe,
'subscribeall|subscribe_all!' => \$subscribeall,
'justbanner!' => \$mysync->{ justbanner },
'justfolders!'=> \$mysync->{ justfolders },
'justfoldersizes!' => \$mysync->{ justfoldersizes },
'version' => \$mysync->{version},
'help' => \$help,
'timeout=f' => \$mysync->{timeout},
'timeout1=f' => \$mysync->{ acc1 }->{timeout},
'timeout2=f' => \$mysync->{ acc2 }->{timeout},
'skipheader=s' => \$mysync->{ skipheader },
'useheader=s' => \@useheader,
'wholeheaderifneeded!' => \$wholeheaderifneeded,
'messageidnodomain!' => \$messageidnodomain,
'skipsize!' => \$skipsize,
'allowsizemismatch!' => \$allowsizemismatch,
'fastio1!' => \$mysync->{ acc1 }->{ fastio },
'fastio2!' => \$mysync->{ acc2 }->{ fastio },
'sslcheck!' => \$mysync->{sslcheck},
'ssl1!' => \$mysync->{ssl1},
'ssl2!' => \$mysync->{ssl2},
'ssl1_ssl_version=s' => \$mysync->{ acc1 }->{sslargs}->{SSL_version},
'ssl2_ssl_version=s' => \$mysync->{ acc2 }->{sslargs}->{SSL_version},
'sslargs1=s%' => \$mysync->{ acc1 }->{sslargs},
'sslargs2=s%' => \$mysync->{ acc2 }->{sslargs},
'tls1!' => \$mysync->{tls1},
'tls2!' => \$mysync->{tls2},
'uid1!' => \$uid1,
'uid2!' => \$uid2,
'authmech1=s' => \$mysync->{ acc1 }->{ authmech },
'authmech2=s' => \$mysync->{ acc2 }->{ authmech },
'authuser1=s' => \$mysync->{ acc1 }->{ authuser },
'authuser2=s' => \$mysync->{ acc2 }->{ authuser },
'proxyauth1' => \$mysync->{ acc1 }->{ proxyauth },
'proxyauth2' => \$mysync->{ acc2 }->{ proxyauth },
'compress1!' => \$mysync->{ acc1 }->{ compress },
'compress2!' => \$mysync->{ acc2 }->{ compress },
'keepalive1!' => \$mysync->{ acc1 }->{ keepalive },
'keepalive2!' => \$mysync->{ acc2 }->{ keepalive },
'split1=i' => \$split1,
'split2=i' => \$split2,
'buffersize=i' => \$buffersize,
'reconnectretry1=i' => \$mysync->{ acc1 }->{ reconnectretry },
'reconnectretry2=i' => \$mysync->{ acc2 }->{ reconnectretry },
'tests!' => \$mysync->{ tests },
'testsdebug|tests_debug!' => \$mysync->{ testsdebug },
'testsunit=s@' => \$mysync->{testsunit},
'testslive!' => \$mysync->{testslive},
'testslive6!' => \$mysync->{testslive6},
'justlogin!' => \$mysync->{justlogin},
'justconnect!' => \$mysync->{justconnect},
'tmpdir=s' => \$mysync->{ tmpdir },
'pidfile=s' => \$mysync->{pidfile},
'pidfilelocking!' => \$mysync->{pidfilelocking},
'sigexit=s@' => \$mysync->{ sigexit },
'sigreconnect=s@' => \$mysync->{ sigreconnect },
'sigignore=s@' => \$mysync->{ sigignore },
'releasecheck!' => \$mysync->{releasecheck},
'modulesversion|modules_version!' => \$modulesversion,
'usecache!' => \$mysync->{ usecache },
'cacheaftercopy!' => \$cacheaftercopy,
'debugcache!' => \$debugcache,
'useuid!' => \$useuid,
'addheader!' => \$mysync->{addheader},
'exitwhenover=i' => \$mysync->{ exitwhenover },
'exitonload!' => \$mysync->{ exitonload },
'checkselectable!' => \$mysync->{ checkselectable },
'checkfoldersexist!' => \$mysync->{ checkfoldersexist },
'checkmessageexists!' => \$checkmessageexists,
'expungeaftereach!' => \$mysync->{ expungeaftereach },
'abletosearch!' => \$mysync->{abletosearch},
'abletosearch1!' => \$mysync->{abletosearch1},
'abletosearch2!' => \$mysync->{abletosearch2},
'showpasswords!' => \$mysync->{showpasswords},
'maxlinelength=i' => \$maxlinelength,
'maxlinelengthcmd=s' => \$maxlinelengthcmd,
'minmaxlinelength=i' => \$minmaxlinelength,
'debugmaxlinelength!' => \$debugmaxlinelength,
'fixcolonbug!' => \$fixcolonbug,
'create_folder_old!' => \$create_folder_old,
'maxmessagespersecond=f' => \$mysync->{maxmessagespersecond},
'maxbytespersecond=i' => \$mysync->{maxbytespersecond},
'maxbytesafter=i' => \$mysync->{maxbytesafter},
'maxsleep=f' => \$mysync->{maxsleep},
'syncduplicates!' => \$mysync->{ syncduplicates },
'skipcrossduplicates!' => \$mysync->{ skipcrossduplicates },
'debugcrossduplicates!' => \$mysync->{ debugcrossduplicates },
'log!' => \$mysync->{log},
'tail!' => \$mysync->{tail},
'logfile=s' => \$mysync->{logfile},
'logdir=s' => \$mysync->{logdir},
'errorsmax=i' => \$mysync->{errorsmax},
'errorsdump!' => \$mysync->{ errorsdump },
'fetch_hash_set=s' => \$fetch_hash_set,
'automap!' => \$mysync->{automap},
'justautomap!' => \$mysync->{justautomap},
'id!' => \$mysync->{id},
'f1f2=s@' => \$mysync->{f1f2},
'nof1f2' => \$mysync->{nof1f2},
'f1f2h=s%' => \$mysync->{f1f2h},
'justfolderlists!' => \$mysync->{justfolderlists},
'delete1emptyfolders' => \$mysync->{delete1emptyfolders},
'checknoabletosearch!' => \$mysync->{checknoabletosearch},
'dockercontext!' => \$mysync->{ dockercontext },
'emailreportfrom=s' => \$mysync->{ email_report_from },
'emailreport1!' => \$mysync->{ emailreport1 },
'emailreport2!' => \$mysync->{ emailreport2 },
'var=s@' => \$mysync->{ var },
'memorystress!' => \$mysync->{ memorystress },
) ;
#myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
$mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ;
my $numopt_after = scalar @arguments ;
#myprint( "get options: [$opt_ret][$numopt][$numopt_after]\n" ) ;
# The $arguments[0] test is just because parallel adds "" when it is
# used with {=7=} in sync_parallel_unix.sh
if ( $numopt_after and $arguments[0] ) {
myprint(
"Found ", scalar( @arguments ), " extra arguments : [@arguments]\n",
"It usually means a quoting issue in the command line ",
"or some misspelling options.\n",
) ;
return ;
}
if ( ! $opt_ret ) {
return ;
}
return $numopt ;
}
sub tests_get_options
{
note( 'Entering tests_get_options()' ) ;
# CAVEAT: still setting global variables, be careful
# with tests, the context increases! $debug stays on for example.
# 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, $mysync->{ noexist }, 'get_options: --noexist => undef' ) ;
$mysync = { } ;
is( undef, get_options( $mysync, qw( --lalala --noexist --version ) ), 'get_options: --lalala --noexist --version => undef' ) ;
is( 1, $mysync->{ version }, 'get_options: --version => 1' ) ;
is( undef, $mysync->{ noexist }, 'get_options: --noexist => undef' ) ;
$mysync = { } ;
is( 1, get_options( $mysync, qw( --delete2 ) ), 'get_options: --delete2 => 1' ) ;
is( 1, $mysync->{ delete2 }, 'get_options: --delete2 => var delete2 = 1' ) ;
$mysync = { } ;
is( undef, get_options( $mysync, qw( --delete 2 ) ), 'get_options: --delete 2 => var undef' ) ;
is( undef, $mysync->{ delete1 }, 'get_options: --delete 2 => var still undef ; good!' ) ;
$mysync = { } ;
is( undef, get_options( $mysync, "--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( --noexist --version ) ), 'get_options: --debug --noexist --version => undef' ) ;
is( 1, get_options( $mysync, qw( --version ) ), 'get_options: --version => 1' ) ;
is( undef, get_options( $mysync, qw( extra ) ), 'get_options: extra => undef' ) ;
is( undef, get_options( $mysync, qw( extra1 --version extra2 ) ), 'get_options: extra1 --version extra2 => undef' ) ;
$mysync = { } ;
is( 2, get_options( $mysync, qw( --host1 HOST_01) ), 'get_options: --host1 HOST_01 => 1' ) ;
is( 'HOST_01', $mysync->{ host1 }, 'get_options: --host1 HOST_01 => HOST_01' ) ;
#myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
note( 'Leaving tests_get_options()' ) ;
return ;
}
sub get_options
{
my $mysync = shift @ARG ;
my @arguments = @ARG ;
#myprint( "1 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ;
my $ret ;
if ( under_cgi_context( ) ) {
# CGI context
$ret = get_options_cgi( $mysync, @arguments ) ;
}else{
# Command line context ;
$ret = get_options_cmd( $mysync, @arguments ) ;
} ;
#myprint( "2 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ;
foreach my $key ( sort keys %{ $mysync } ) {
if ( ! defined $mysync->{$key} ) {
delete $mysync->{$key} ;
next ;
}
if ( 'ARRAY' eq ref( $mysync->{$key} )
and 0 == scalar( @{ $mysync->{$key} } ) ) {
delete $mysync->{$key} ;
}
}
return $ret ;
}
sub tests_infos
{
note( 'Entering tests_infos()' ) ;
note( "OSNAME=$OSNAME" ) ;
note( "hostname=". hostname( ) ) ;
note( "cwd=" . getcwd( ) ) ;
note( "PROGRAM_NAME=$PROGRAM_NAME" ) ;
my $stat = stat( "$PROGRAM_NAME" ) ;
my $perms = sprintf( "%04o\n", $stat->mode & oct( $PERMISSION_FILTER ) ) ;
note( "permissions=$perms" ) ;
note( "PROCESS_ID=$PROCESS_ID" ) ;
note( "REAL_USER_ID=$REAL_USER_ID" ) ;
note( "EFFECTIVE_USER_ID=$EFFECTIVE_USER_ID" ) ;
note( "context: " . imapsync_context( $sync ) ) ;
note( "memory_consumption_of_myself: " . memory_consumption_of_myself( ) . " bytes aka " . bytes_display_string_dec( memory_consumption_of_myself( ) ) ) ;
note( "cpu_number: " . cpu_number( ) ) ;
note( $sync->{ rcs } ) ;
note( 'Leaving tests_infos()' ) ;
return ;
}
sub condition_to_leave_after_tests
{
my $mysync = shift @ARG ;
if ( $mysync->{ testslive } or $mysync->{ testslive6 } )
{
return 0 ;
}
if ( $mysync->{ tests }
or $mysync->{ testsdebug }
or $mysync->{ testsunit }
)
{
return 1 ;
}
}
sub testunitsession
{
my $mysync = shift @ARG ;
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 ;
}
sub tests_count_0s
{
note( 'Entering tests_count_zeros()' ) ;
is( 0, count_0s( ), 'count_0s: no parameters => 0' ) ;
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( "nb 1 - first\n", report_failures( ({'ok' => 0, name => 'first'}) ), 'report_failures: "first" failed => nb 1 - first' ) ;
is( q{}, report_failures( ( {'ok' => 1, name => 'first'} ) ), 'report_failures: "first" success =>' ) ;
is( "nb 2 - second\n", report_failures( ( {'ok' => 1, name => 'second'}, {'ok' => 0, name => 'second'} ) ), 'report_failures: "second" failed => nb 2 - second' ) ;
is( "nb 1 - first\nnb 2 - second\n", report_failures( ( {'ok' => 0, name => 'first'}, {'ok' => 0, name => 'second'} ) ), 'report_failures: both failed => nb 1 - first nb 2 - second' ) ;
note( 'Leaving tests_report_failures()' ) ;
return ;
}
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 .= "nb $counter - $name\n" ;
}
$counter += 1 ;
}
return $report ;
}
sub tests_true
{
note( 'Entering tests_true()' ) ;
is( 1, 1, 'true: 1 is 1' ) ;
is( 'A', 'A', 'true: A is A' ) ;
note( 'Leaving tests_true()' ) ;
return ;
}
sub tests_always_fail
{
note( 'Entering tests_always_fail()' ) ;
is( 0, 1, 'always_fail: 0 is 1' ) ;
isnt( 'A', 'A', 'always_fail: A is A' ) ;
note( 'Leaving tests_always_fail()' ) ;
return ;
}
sub tests_testsunit
{
note( 'Entering tests_testunit()' ) ;
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 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
{
# Now a little obsolete since there is
# imapsync ... --testsunit "anyfunction"
my $mysync = shift @ARG ;
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_check_binary_embed_all_dyn_libs( ) ;
#tests_killpid_by_parent( ) ;
#tests_killpid_by_brother( ) ;
#tests_kill_zero( ) ;
#tests_connect_socket( ) ;
#tests_probe_imapssl( ) ;
#tests_mailimapclient_connect( ) ;
#tests_always_fail( ) ;
#tests_localtimez( ) ;
#tests_year_month_day_hour_min_sec_ms( ) ;
#tests_date_rfc822( ) ;
#tests_email_report_message_id( ) ;
tests_all_pids( ) ;
tests_memory_consumption_of_myself( ) ;
tests_ram_memory_info( ) ;
tests_memory_consumption_of_all_pids( ) ;
tests_memory_consumption_all_pids_percent( ) ;
#tests_memory_stress( ) ;
tests_memory_consumption_of_pids_win32( ) ;
#tests_load_and_delay( ) ;
#tests_cpu_number( ) ;
#tests_loadavg( ) ;
#tests_load_per_cpu( ) ;
#tests_all_pids( ) ;
#tests_remove_qq( ) ;
#tests_remove_not_num( ) ;
tests_infos( ) ;
note( 'Leaving testsdebug()' ) ;
done_testing( ) ;
}
return ;
}
sub tests
{
my $mysync = shift @ARG ;
if ( ! $mysync->{ tests } ) { return ; }
SKIP: {
skip 'No test in normal run' if ( ! $mysync->{ tests } ) ;
note( 'Entering tests()' ) ;
tests_folder_routines( ) ;
tests_compare_lists( ) ;
tests_regexmess( ) ;
tests_skipmess( ) ;
tests_regexflags( );
tests_ucsecond( ) ;
tests_permanentflags();
tests_flags_filter( ) ;
tests_separator_invert( ) ;
tests_imap2_folder_name( ) ;
tests_command_line_nopassword( ) ;
tests_good_date( ) ;
tests_max( ) ;
tests_remove_not_num();
tests_memory_consumption_of_myself( ) ;
tests_is_a_release_number();
tests_imapsync_basename();
tests_list_keys_in_2_not_in_1();
tests_convert_sep_to_slash( ) ;
tests_match_a_cache_file( ) ;
tests_cache_map( ) ;
tests_get_cache( ) ;
tests_clean_cache( ) ;
tests_clean_cache_2( ) ;
tests_touch( ) ;
tests_flagscase( ) ;
tests_mkpath( ) ;
tests_extract_header( ) ;
tests_decompose_header( ) ;
tests_epoch( ) ;
tests_add_header( ) ;
tests_cache_dir_fix( ) ;
tests_cache_dir_fix_win( ) ;
tests_filter_forbidden_characters( ) ;
tests_cache_folder( ) ;
tests_time_remaining( ) ;
tests_decompose_regex( ) ;
tests_backtick( ) ;
tests_bytes_display_string_bin( ) ;
tests_bytes_display_string_dec( ) ;
tests_header_line_normalize( ) ;
tests_fix_Inbox_INBOX_mapping( ) ;
tests_max_line_length( ) ;
tests_subject( ) ;
tests_msgs_from_maxmin( ) ;
tests_tmpdir_has_colon_bug( ) ;
tests_sleep_max_messages( ) ;
tests_sleep_max_bytes( ) ;
tests_logfile( ) ;
tests_setlogfile( ) ;
tests_jux_utf8_old( ) ;
tests_jux_utf8( ) ;
tests_pipemess( ) ;
tests_jux_utf8_list( ) ;
tests_guess_prefix( ) ;
tests_guess_separator( ) ;
tests_format_for_imap_arg( ) ;
tests_imapsync_id( ) ;
tests_date_from_rcs( ) ;
tests_quota_extract_storage_limit_in_bytes( ) ;
tests_quota_extract_storage_current_in_bytes( ) ;
tests_guess_special( ) ;
tests_do_valid_directory( ) ;
tests_delete1emptyfolders( ) ;
tests_message_for_host2( ) ;
tests_length_ref( ) ;
tests_firstline( ) ;
tests_diff_or_NA( ) ;
tests_match_number( ) ;
tests_all_defined( ) ;
tests_special_from_folders_hash( ) ;
tests_notmatch( ) ;
tests_match( ) ;
tests_get_options( ) ;
tests_get_options_cgi_context( ) ;
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_slash_to_underscore( ) ;
tests_testsunit( ) ;
tests_count_0s( ) ;
tests_report_failures( ) ;
tests_min( ) ;
#tests_connect_socket( ) ;
#tests_resolvrev( ) ;
tests_usage( ) ;
tests_version_from_rcs( ) ;
tests_backslash_caret( ) ;
#tests_mailimapclient_connect_bug( ) ; # it fails with Mail-IMAPClient <= 3.39
tests_write_pidfile( ) ;
tests_remove_pidfile_not_running( ) ;
tests_match_a_pid_number( ) ;
tests_prefix_seperator_invertion( ) ;
tests_is_integer( ) ;
tests_integer_or_1( ) ;
tests_is_number( ) ;
tests_sig_install( ) ;
tests_template( ) ;
tests_split_around_equal( ) ;
tests_toggle_sleep( ) ;
tests_labels( ) ;
tests_synclabels( ) ;
tests_uidexpunge_or_expunge( ) ;
tests_appendlimit_from_capability( ) ;
tests_maxsize_setting( ) ;
tests_mock_capability( ) ;
tests_appendlimit( ) ;
tests_capability_of( ) ;
tests_search_in_array( ) ;
tests_operators_and_exclam_precedence( ) ;
tests_teelaunch( ) ;
tests_logfileprepa( ) ;
tests_useheader_suggestion( ) ;
tests_nb_messages_in_2_not_in_1( ) ;
tests_labels_add_subfolder2( ) ;
tests_labels_remove_subfolder1( ) ;
tests_resynclabels( ) ;
tests_labels_remove_special( ) ;
tests_uniq( ) ;
tests_remove_from_requested_folders( ) ;
tests_errors_log( ) ;
tests_add_subfolder1_to_folderrec( ) ;
tests_sanitize_subfolder( ) ;
tests_remove_edging_blanks( ) ;
tests_sanitize( ) ;
tests_remove_last_char_if_is( ) ;
tests_check_binary_embed_all_dyn_libs( ) ;
tests_nthline( ) ;
tests_secondline( ) ;
tests_tail( ) ;
tests_truncmess( ) ;
tests_eta( ) ;
tests_timesince( ) ;
tests_timenext( ) ;
tests_imapsync_context( ) ;
tests_abort( ) ;
tests_probe_imapssl( ) ;
tests_mailimapclient_connect( ) ;
tests_checknoabletosearch( ) ;
tests_errorsdump( ) ;
tests_errorsanalyse( ) ;
tests_most_common_error( ) ;
tests_errorclassify( ) ;
tests_error_type( ) ;
tests_sanitize_host( ) ;
tests_hmac_sha1_hex( ) ;
tests_total_bytes_max_reached( ) ;
tests_header_construct( ) ;
tests_remove_doublequotes_if_any( ) ;
tests_login_imap( ) ;
tests_login_imap_oauth( ) ;
tests_skipmess_neg( ) ;
tests_localtimez( ) ;
tests_file_to_array( ) ;
tests_cpu_time( ) ;
tests_cpu_percent( ) ;
tests_cpu_percent_global( ) ;
tests_flags_for_host2( ) ;
tests_under_docker_context( ) ;
tests_exit_value( ) ;
tests_comment_of_error_type( ) ;
tests_debugcontent( ) ;
tests_compress_ssl( ) ;
tests_compress( ) ;
tests_get_options_extra( ) ;
tests_get_options_from_string( ) ;
tests_email_report_message_id( ) ;
tests_year_month_day_hour_min_sec_ms( ) ;
tests_fractional_of_floor( ) ;
tests_date_rfc822( ) ;
tests_email_report_from( ) ;
tests_email_report_to( ) ;
tests_email_report_body_base( ) ;
tests_email_report( ) ;
tests_setlogdir( ) ;
tests_logfilesuffix( ) ;
tests_cgienvcontext( ) ;
tests_usecache_and_skipcrossduplicates( ) ;
tests_loglogfile( ) ;
tests_heavy_load_reached( ) ;
tests_heavy_load_percent_threshold( ) ;
tests_pctmem_available( ) ;
tests_filterbuggyflags( ) ;
tests_heavy_load_reached_by_memory( ) ;
tests_heavy_load_reached_by_cpu( ) ;
tests_load_per_cpu( ) ;
tests_memory_consumption_surface( ) ;
tests_add( ) ;
tests_all_pids( ) ;
tests_memory_consumption_of_all_pids( ) ;
tests_remove_qq( ) ;
tests_memory_consumption_all_pids_percent( ) ;
tests_ram_memory_info( ) ;
tests_infos( ) ;
#tests_resolv( ) ;
# Those three are for later use, when webserver will be inside imapsync
# or will be deleted them if I abandon the project.
#tests_killpid_by_parent( ) ;
#tests_killpid_by_brother( ) ;
#tests_kill_zero( ) ;
#tests_always_fail( ) ;
done_testing( 1992 ) ;
note( 'Leaving tests()' ) ;
}
return ;
}
sub tests_template
{
note( 'Entering tests_template()' ) ;
is( undef, template( ), 'tests_template: no args => undef' ) ;
my $mysync = { } ;
is( undef, template( $mysync ), 'tests_template: { } => undef' ) ;
is_deeply( {}, {}, 'tests_template: a hash is a hash' ) ;
is_deeply( [], [], 'tests_template: an array is an array' ) ;
note( 'Leaving tests_template()' ) ;
return ;
}
sub template
{
my $mysync = shift @ARG ;
return ;
}
