mirror of
https://github.com/mailcow/mailcow-dockerized.git
synced 2024-12-16 10:59:39 +02:00
9489 lines
339 KiB
Perl
Executable File
9489 lines
339 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
|
|
# $Id: imapsync,v 1.727 2016/08/19 10:30:36 gilles Exp gilles $
|
|
# structure
|
|
# pod documentation
|
|
# pragmas
|
|
# main program
|
|
# global variables initialisation
|
|
# get_options( ) ;
|
|
# default values
|
|
# folder loop
|
|
# subroutines
|
|
# sub usage {
|
|
# IMAPClient 3.xx ads
|
|
|
|
# pod documentation
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
imapsync - Email IMAP tool for syncing, copying and migrating email mailboxes.
|
|
|
|
The imapsync command synchronises mailboxes between two imap servers.
|
|
More than 69 different IMAP server softwares supported with success,
|
|
few failures.
|
|
|
|
$Revision: 1.727 $
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
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 REQUIRED ARGUMENTS
|
|
|
|
The required argmuments are the six values, three on each sides,
|
|
needed to login into the IMAP servers,
|
|
a host, a username, and a password, two times.
|
|
|
|
=head1 INSTALL
|
|
|
|
Imapsync works under any Unix with perl.
|
|
Imapsync works under Windows (2000, XP, Vista, Seven)
|
|
as a standalone binary software called imapsync.exe
|
|
Imapsync works under OS X as a standalone binary
|
|
software called imapsync_bin_Darwin.
|
|
|
|
Purchase latest imapsync at
|
|
http://imapsync.lamiral.info/
|
|
|
|
You'll receive a link to a compressed tarball called imapsync-x.xx.tgz
|
|
where x.xx is the version number. Untar the tarball where
|
|
you want (on Unix):
|
|
|
|
tar xzvf imapsync-x.xx.tgz
|
|
|
|
Go into the directory imapsync-x.xx and read the INSTALL file.
|
|
As mentioned at http://imapsync.lamiral.info/#install
|
|
the INSTALL file can also be found at
|
|
http://imapsync.lamiral.info/INSTALL
|
|
It is now split in several files for each system
|
|
http://imapsync.lamiral.info/INSTALL.d/
|
|
|
|
=head1 CONFIGURATION
|
|
|
|
There is no specific configuration file for imapsync,
|
|
everything is specified by the command line parameteres
|
|
and the default behavior.
|
|
|
|
=head1 USAGE
|
|
|
|
To get a description of each option just run imapsync
|
|
with no argument, like this:
|
|
|
|
imapsync
|
|
|
|
This description of options is also available at
|
|
http://imapsync.lamiral.info/OPTIONS and is
|
|
reproduced here:
|
|
|
|
usage: ./imapsync [options]
|
|
|
|
Several options are mandatory.
|
|
str means string
|
|
int means integer
|
|
reg means regular expression
|
|
cmd means command
|
|
|
|
--dry : Makes imapsync doing nothing, just print what would
|
|
be done without --dry.
|
|
|
|
--host1 str : Source or "from" imap server. Mandatory.
|
|
--port1 int : Port to connect on host1. Default is 143, 993 if --ssl1
|
|
--user1 str : User to login on host1. Mandatory.
|
|
--showpasswords : Shows passwords on output instead of "MASKED".
|
|
Useful to restart a complete run by just reading the log.
|
|
--password1 str : Password for the user1.
|
|
--host2 str : "destination" imap server. Mandatory.
|
|
--port2 int : Port to connect on host2. Default is 143, 993 if --ssl2
|
|
--user2 str : User to login on host2. Mandatory.
|
|
--password2 str : Password for the user2.
|
|
|
|
--passfile1 str : Password file for the user1. It must contain the
|
|
password on the first line. This option avoids to show
|
|
the password on the command line like --password1 does.
|
|
--passfile2 str : Password file for the user2. Contains the password.
|
|
|
|
--ssl1 : Use a SSL connection on host1.
|
|
--ssl2 : Use a SSL connection on host2.
|
|
--tls1 : Use a TLS connection on host1.
|
|
--tls2 : Use a TLS connection on host2.
|
|
--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
|
|
|
|
--timeout1 int : Connection timeout in seconds for host1.
|
|
Default is 120 and 0 means no timeout at all.
|
|
--timeout2 int : Connection timeout in seconds for host2.
|
|
Default is 120 and 0 means no timeout at all.
|
|
|
|
--authmech1 str : Auth mechanism to use with host1:
|
|
PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE.
|
|
--authmech2 str : Auth mechanism to use with host2. See --authmech1
|
|
|
|
--authuser1 str : User to auth with on host1 (admin user).
|
|
Avoid using --authmech1 SOMETHING with --authuser1.
|
|
--authuser2 str : User to auth with on host2 (admin user).
|
|
--proxyauth1 : Use proxyauth on host1. Requires --authuser1.
|
|
Required by Sun/iPlanet/Netscape IMAP servers to
|
|
be able to use an administrative user.
|
|
--proxyauth2 : Use proxyauth on host2. Requires --authuser2.
|
|
|
|
--authmd51 : Use MD5 authentification for host1.
|
|
--authmd52 : Use MD5 authentification for host2.
|
|
--domain1 str : Domain on host1 (NTLM authentication).
|
|
--domain2 str : Domain on host2 (NTLM authentication).
|
|
|
|
|
|
--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. --folderfirst "Work"
|
|
--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 (ex: Sent SENT sent -> Sent).
|
|
|
|
--skipemptyfolders : Empty host1 folders are not created on host2.
|
|
|
|
--f1f2 str1=str2 : Force folder str1 to be synced to str2.
|
|
--include reg : Sync folders matching this regular expression
|
|
--include reg : or this one, etc.
|
|
in case both --include --exclude options are
|
|
use, include is done before.
|
|
--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.
|
|
|
|
--subfolder2 str : Move whole host1 folders hierarchy under this
|
|
host2 folder str .
|
|
It does it by adding two --regextrans2 options before
|
|
all others. Add --debug to see what's really going on.
|
|
|
|
--regextrans2 reg : Apply the whole regex to each destination folders.
|
|
--regextrans2 reg : and this one. etc.
|
|
When you play with the --regextrans2 option, first
|
|
add also the safe options --dry --justfolders
|
|
Then, when happy, remove --dry, remove --justfolders.
|
|
Have in mind that --regextrans2 is applied after prefix
|
|
and separator inversion.
|
|
|
|
--tmpdir str : Where to store temporary files and subdirectories.
|
|
Will be created if it doesn't exist.
|
|
Default is system specific, Unix is /tmp but
|
|
it's often small and deleted at reboot.
|
|
--tmpdir /var/tmp should be better.
|
|
--pidfile str : The file where imapsync pid is written.
|
|
--pidfilelocking : Abort if pidfile already exists. Usefull to avoid
|
|
concurrent transfers on the same mailbox.
|
|
|
|
--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
|
|
|
|
--prefix1 str : Remove prefix to all destination folders
|
|
(usually INBOX. or INBOX/ or an empty string "")
|
|
you have to use --prefix1 if host1 imap server
|
|
does not have NAMESPACE capability, so imapsync
|
|
suggests to use it. All other cases are bad.
|
|
--prefix2 str : Add prefix to all host2 folders. See --prefix1
|
|
--sep1 str : Host1 separator in case NAMESPACE is not supported.
|
|
--sep2 str : Host2 separator in case NAMESPACE is not supported.
|
|
|
|
--skipmess reg : Skips messages maching the regex.
|
|
Example: 'm/[\x80-ff]/' # to avoid 8bits messages.
|
|
--skipmess is applied before --regexmess
|
|
--skipmess reg : or this one, etc.
|
|
|
|
--pipemess cmd : Apply this cmd command to each message content
|
|
before the copy.
|
|
--pipemess cmd : and this one, etc.
|
|
|
|
--disarmreadreceipts : Disarms read receipts (host2 Exchange issue)
|
|
|
|
--regexmess reg : Apply the whole regex to each message before transfer.
|
|
Example: 's/\000/ /g' # to replace null by space.
|
|
--regexmess reg : and this one, etc.
|
|
|
|
--regexflag reg : Apply the whole regex to each flags list.
|
|
Example: 's/"Junk"//g' # to remove "Junk" flag.
|
|
--regexflag reg : and this one, etc.
|
|
|
|
--delete : Deletes messages on host1 server after a successful
|
|
transfer. Option --delete has the following behavior:
|
|
it marks messages as deleted with the IMAP flag
|
|
\Deleted, then messages are really deleted with an
|
|
EXPUNGE IMAP command.
|
|
|
|
--delete2 : Delete messages in host2 that are not in
|
|
host1 server. Useful for backup or pre-sync.
|
|
--delete2duplicates : Delete messages in host2 that are duplicates.
|
|
Works only without --useuid since duplicates are
|
|
detected with an header part of each message.
|
|
|
|
--delete2folders : Delete folders in host2 that are not in host1 server.
|
|
For safety, first try it like this (it is safe):
|
|
--delete2folders --dry --justfolders --nofoldersizes
|
|
--delete2foldersonly reg : Deleted only folders matching regex.
|
|
Example: --delete2foldersonly "/^Junk$|^INBOX.Junk$/"
|
|
--delete2foldersbutnot reg : Do not delete folders matching regex.
|
|
Example: --delete2foldersbutnot "/Tasks$|Contacts$|Foo$/"
|
|
--noexpunge : Do not expunge messages on host1.
|
|
Expunge really deletes messages marked deleted.
|
|
Expunge is made at the beginning, on host1 only.
|
|
Newly transferred messages are also expunged if
|
|
option --delete is given.
|
|
No expunge is done on host2 account (unless --expunge2)
|
|
--expunge1 : Expunge messages on host1 after messages transfer.
|
|
--expunge2 : Expunge messages on host2 after messages transfer.
|
|
--uidexpunge2 : uidexpunge messages on the host2 account
|
|
that are not on the host1 account, requires --delete2
|
|
--nomixfolders : Avoid merging folders that are considered different on
|
|
host1 but the same on destination host2 because of
|
|
case sensitivities and insensitivities.
|
|
|
|
--syncinternaldates : Sets the internal dates on host2 same as host1.
|
|
Turned on by default. Internal date is the date
|
|
a message arrived on a host (mtime).
|
|
--idatefromheader : Sets the internal dates on host2 same as the
|
|
"Date:" headers.
|
|
|
|
--maxsize int : Skip messages larger (or equal) than int bytes
|
|
--minsize int : Skip messages smaller (or equal) than int bytes
|
|
--maxage int : Skip messages older than int days.
|
|
final stats (skipped) don't count older messages
|
|
see also --minage
|
|
--minage int : Skip messages newer than int days.
|
|
final stats (skipped) don't count newer messages
|
|
You can do (+ are the messages selected):
|
|
past|----maxage+++++++++++++++>now
|
|
past|+++++++++++++++minage---->now
|
|
past|----maxage+++++minage---->now (intersection)
|
|
past|++++minage-----maxage++++>now (union)
|
|
|
|
--search str : Selects only messages returned by this IMAP SEARCH
|
|
command. Applied on both sides.
|
|
--search1 str : Same as --search for selecting host1 messages only.
|
|
--search2 str : Same as --search for selecting host2 messages only.
|
|
--search CRIT equals --search1 CRIT --search2 CRIT
|
|
|
|
--exitwhenover int : Stop syncing when total bytes transferred reached.
|
|
Gmail per day allows
|
|
2500000000 = 2.5 GB downloaded from Gmail as host2
|
|
500000000 = 500 MB uploaded to Gmail as host1.
|
|
|
|
--maxlinelength int : skip messages with a line length longer than int bytes.
|
|
RFC 2822 says it must be no more than 1000 bytes.
|
|
|
|
--useheader str : Use this header to compare messages on both sides.
|
|
Ex: Message-ID or Subject or Date.
|
|
--useheader str and this one, etc.
|
|
|
|
--subscribed : Transfers subscribed folders.
|
|
--subscribe : Subscribe to the folders transferred on the
|
|
host2 that are subscribed on host1. On by default.
|
|
--subscribeall : Subscribe to the folders transferred on the
|
|
host2 even if they are not subscribed on host1.
|
|
|
|
--nofoldersizes : Do not calculate the size of each folder in bytes
|
|
and message counts. Default is to calculate them.
|
|
--nofoldersizesatend: Do not calculate the size of each folder in bytes
|
|
and message counts at the end. Default is on.
|
|
--justfoldersizes : Exit after having printed the folder sizes.
|
|
|
|
--syncacls : Synchronises acls (Access Control Lists).
|
|
--nosyncacls : Does not synchronize acls. This is the default.
|
|
Acls in IMAP are not standardized, be careful.
|
|
|
|
--usecache : Use cache to speedup.
|
|
--nousecache : Do not use cache. Caveat: --useuid --nousecache creates
|
|
duplicates on multiple runs.
|
|
--useuid : Use uid instead of header as a criterium to recognize
|
|
messages. Option --usecache is then implied unless
|
|
--nousecache is used.
|
|
|
|
--debug : Debug mode.
|
|
--debugfolders : Debug mode for the folders part only.
|
|
--debugcontent : Debug content of the messages transfered. Huge ouput.
|
|
--debugflags : Debug mode for flags.
|
|
--debugimap1 : IMAP debug mode for host1. Very verbose.
|
|
--debugimap2 : IMAP debug mode for host2. Very verbose.
|
|
--debugimap : IMAP debug mode for host1 and host2.
|
|
--debugmemory : Debug mode showing memory consumption after each copy.
|
|
|
|
--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 connexion.
|
|
|
|
--version : Print only software version.
|
|
--noreleasecheck : Do not check for new imapsync release (a http request).
|
|
--releasecheck : Check for new imapsync release (a http request).
|
|
--noid : Do not send/receive ID command to imap servers.
|
|
--justconnect : Just connect to both servers and print useful
|
|
information. Need only --host1 and --host2 options.
|
|
--justlogin : Just login to both host1 and host2 with users
|
|
credentials, then exit.
|
|
--justfolders : Do only things about folders (ignore messages).
|
|
|
|
--help : print this help.
|
|
|
|
Example:
|
|
To synchronize the source imap account
|
|
"test1" on server "test1.lamiral.info" with password "secret1"
|
|
to the destination imap account
|
|
"test2" on server "test2.lamiral.info" with password "secret2"
|
|
do:
|
|
|
|
imapsync \
|
|
--host1 test1.lamiral.info --user1 test1 --password1 secret1 \
|
|
--host2 test2.lamiral.info --user2 test2 --password2 secret2
|
|
|
|
=cut
|
|
# comment
|
|
|
|
=pod
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Imapsync command is a tool allowing incremental and
|
|
recursive imap transfers from one mailbox to another.
|
|
|
|
By default all folders are transferred, recursively, all
|
|
possible flags (\Seen \Answered \Flagged etc.) are synced too.
|
|
|
|
We sometimes need to transfer mailboxes from one imap server to
|
|
another. This is called migration.
|
|
|
|
Imapsync reduces the amount
|
|
of data transferred by not transferring a given message
|
|
if it resides already on both sides. Same specific headers
|
|
and the transfer is done only once; taken into account are by default
|
|
Message-Id and Received header lines.
|
|
All flags are
|
|
preserved, unread will stay unread, read will stay read,
|
|
deleted will stay deleted. You can stop the transfer at any
|
|
time and restart it later, imapsync works well with bad
|
|
connections and interruptions.
|
|
|
|
You can decide to delete the messages from the source mailbox
|
|
after a successful transfer, it can be a good feature when migrating
|
|
live mailboxes since messages will be only on one side.
|
|
In that case, use the --delete option. Option --delete implies
|
|
also option --expunge so all messages marked deleted on host1
|
|
will be really deleted.
|
|
(you can use --noexpunge to avoid this but I don't see any
|
|
good real world scenario for the combination --delete --noexpunge).
|
|
|
|
A different scenario is synchronizing a mailbox B from another mailbox A
|
|
in case you just want to keep a "live" copy of A in B.
|
|
In that case --delete2 has to be used, it deletes messages in host2
|
|
folder B that are not in host1 folder A. If you also need to destroy
|
|
host2 folders that are not in host1 then use --delete2folders (see also
|
|
--delete2foldersonly and --delete2foldersbutnot).
|
|
|
|
Imapsync is not adequate for maintaining two active imap accounts
|
|
in synchronization when the user plays independently on both sides.
|
|
Use offlineimap (written by John Goerzen) or mbsync (written by
|
|
Michael R. Elkins) for 2 ways synchronizations.
|
|
|
|
|
|
=head1 OPTIONS
|
|
|
|
To get a description of each option just invoke:
|
|
|
|
imapsync
|
|
|
|
or read the previous section named USAGE,
|
|
|
|
or read http://imapsync.lamiral.info/OPTIONS
|
|
|
|
=head1 HISTORY
|
|
|
|
I wrote imapsync because an enterprise (basystemes) paid me to install
|
|
a new imap server without losing huge old mailboxes located on a far
|
|
away remote imap server accessible by a low bandwidth link. The tool
|
|
imapcp (written in python) could not help me because I had to verify
|
|
every mailbox was well transferred and delete it after a good
|
|
transfer. imapsync started its life as a copy_folder.pl patch.
|
|
The tool copy_folder.pl comes from the Mail-IMAPClient-2.1.3 perl
|
|
module tarball source (in the examples/ directory of the tarball).
|
|
|
|
=head1 EXAMPLE
|
|
|
|
While working on imapsync parameters please run imapsync in
|
|
dry mode (no modification induced) with the --dry
|
|
option. Nothing bad can be done this way.
|
|
|
|
To synchronize the imap account "buddy" (with password "secret1")
|
|
on host "imap.src.fr" to the imap account "max" (with password "secret2")
|
|
on host "imap.dest.fr":
|
|
|
|
imapsync --host1 imap.src.fr --user1 buddy --password1 secret1 \
|
|
--host2 imap.dest.fr --user2 max --password2 secret2
|
|
|
|
Then you will have max's mailbox updated from buddy's
|
|
mailbox.
|
|
|
|
=head1 SECURITY
|
|
|
|
You can use --passfile1 instead of --password1 to give the
|
|
password since it is safer. With --password1 option any user
|
|
on your host can see the password by using the 'ps auxwwww'
|
|
command. Using a variable (like $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.
|
|
|
|
imasync is not totally protected against sniffers on the
|
|
network since passwords may be transferred in plain text
|
|
if CRAM-MD5 is not supported by your imap servers. Use
|
|
--ssl1 (or --tls1) and --ssl2 (or --tls2) to enable
|
|
encryption on host1 and host2.
|
|
|
|
You may authenticate as one user (typically an admin user),
|
|
but be authorized as someone else, which means you don't
|
|
need to know every user's personal password. Specify
|
|
--authuser1 "adminuser" to enable this on host1. In this
|
|
case, --authmech1 PLAIN will be used by default since it
|
|
is the only way to go for now. So don't use --authmech1 SOMETHING
|
|
with --authuser1 "adminuser", it will not work.
|
|
Same behavior with the --authuser2 option.
|
|
Authenticate with an admin account must be supported by your
|
|
imap server to work with imapsync.
|
|
|
|
When working on Sun/iPlanet/Netscape IMAP servers you must use
|
|
--proxyauth1 to enable administrative user to masquerade as another user.
|
|
Can also be used on destination server with --proxyauth2
|
|
|
|
You can authenticate with OAUTH when transfering from Google Apps.
|
|
The consumer key will be the domain part of the --user, and the
|
|
--password will be used as the consumer secret. It does not work
|
|
with Google Apps free edition.
|
|
|
|
=head1 EXIT STATUS
|
|
|
|
imapsync will exit with a 0 status (return code) if everything went good.
|
|
Otherwise, it exits with a non-zero status.
|
|
|
|
So if you have an unreliable internet connection, you can use this loop
|
|
in a Bourne shell:
|
|
|
|
while ! imapsync ...; do
|
|
echo imapsync not complete
|
|
done
|
|
|
|
=head1 LICENSE AND COPYRIGHT
|
|
|
|
imapsync is free, open, public but not always gratis software
|
|
cover by the NOLIMIT Public License.
|
|
See the LICENSE file included in the distribution or just read this
|
|
simple sentence as it is the licence text:
|
|
|
|
"No limit to do anything with this work and this license."
|
|
|
|
In case it is not long enough I repeat:
|
|
|
|
"No limit to do anything with this work and this license."
|
|
|
|
=head1 MAILING-LIST
|
|
|
|
The public mailing-list may be the best way to get free support.
|
|
|
|
To write on the mailing-list, the address is:
|
|
<imapsync@linux-france.org>
|
|
|
|
To subscribe, send any message (even empty) to:
|
|
<imapsync-subscribe@listes.linux-france.org>
|
|
then just reply to the confirmation message.
|
|
|
|
To unsubscribe, send a message to:
|
|
<imapsync-unsubscribe@listes.linux-france.org>
|
|
|
|
To contact the person in charge for the list:
|
|
<imapsync-request@listes.linux-france.org>
|
|
|
|
The list archives are available at:
|
|
http://www.linux-france.org/prj/imapsync_list/
|
|
So consider that the list is public, anyone
|
|
can see your post. Use a pseudonym or do not
|
|
post to this list if you want to stay private.
|
|
|
|
Thank you for your participation.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Feedback good or bad is very often welcome.
|
|
|
|
Gilles LAMIRAL earns his living by writing, installing,
|
|
configuring and teaching free, open and often gratis
|
|
softwares. It used to be "always gratis" but now it is
|
|
"often" because imapsync is sold by its author, a good
|
|
way to stay maintening and supporting free open public
|
|
softwares (see the license) over decades.
|
|
|
|
=head1 BUGS AND LIMITATIONS
|
|
|
|
Help me to help you: follow the following guidelines.
|
|
|
|
Report any bugs or feature requests to the public mailing-list
|
|
or to the author.
|
|
|
|
Before reporting bugs, read the FAQs, the README and the
|
|
TODO files. http://imapsync.lamiral.info/
|
|
|
|
Upgrade to last imapsync release, maybe the bug
|
|
is already fixed.
|
|
|
|
Upgrade to last Mail-IMAPClient Perl module.
|
|
http://search.cpan.org/dist/Mail-IMAPClient/
|
|
maybe the bug is already fixed there.
|
|
|
|
Make a good title with word "imapsync" in it (my spam filters won't filter it),
|
|
Try to write an email title with more words than just "imapsync" or "problem",
|
|
a good title is made of keywords summary, but not too long (one visible line).
|
|
|
|
Help us to help you: in your report, please include:
|
|
|
|
- imapsync version.
|
|
|
|
- output near the first failures, a few lines before is good to get the context
|
|
of the issue. First failures messages are often more significant than
|
|
the last ones.
|
|
|
|
- if the issue is always related to the same messages, include the output
|
|
with --debug --debugimap, near the failure point. For example,
|
|
Isolate a buggy message or two in a folder 'BUG' and use
|
|
|
|
imapsync ... --folder 'BUG' --debug --debugimap
|
|
|
|
- imap server softwares on both sides and their version number.
|
|
|
|
- imapsync with all the options you use, the full command line
|
|
you use (except the passwords of course).
|
|
|
|
- IMAPClient.pm version.
|
|
|
|
- the run context. Do you run imapsync.exe, a unix binary
|
|
or the perl script imapsync.
|
|
|
|
- operating system running imapsync.
|
|
|
|
- virtual software context (vmware, xen etc.)
|
|
|
|
- operating systems on both sides and the third side in case
|
|
you run imapsync on a foreign host from the both.
|
|
|
|
Most of those values can be found as a copy/paste at the begining of the output,
|
|
so a carbon copy of the output is a very easy and very good debug report for me.
|
|
|
|
One time in your life, read the paper
|
|
"How To Ask Questions The Smart Way"
|
|
http://www.catb.org/~esr/faqs/smart-questions.html
|
|
and then forget it.
|
|
|
|
=head1 IMAP SERVERS
|
|
|
|
See http://imapsync.lamiral.info/S/imapservers.shtml
|
|
|
|
=head1 HUGE MIGRATION
|
|
|
|
Pay special attention to options
|
|
--subscribed
|
|
--subscribe
|
|
--delete
|
|
--delete2
|
|
--delete2folders
|
|
--maxage
|
|
--minage
|
|
--maxsize
|
|
--useuid
|
|
--usecache
|
|
|
|
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 programming !
|
|
|
|
You will find already written scripts at
|
|
http://imapsync.lamiral.info/examples/
|
|
|
|
|
|
=head1 HACKING
|
|
|
|
Feel free to hack imapsync as the NOLIMIT license permits it.
|
|
|
|
=head1 LINKS
|
|
|
|
Entries for imapsync:
|
|
https://web.archive.org/web/20070202005121/http://www.imap.org/products/showall.php
|
|
|
|
=head1 SIMILAR SOFTWARES
|
|
|
|
imap_tools : http://www.athensfbc.com/imap_tools
|
|
offlineimap : https://github.com/nicolas33/offlineimap
|
|
mbsync : http://isync.sourceforge.net/
|
|
mailsync : http://mailsync.sourceforge.net/
|
|
mailutil : http://www.washington.edu/imap/
|
|
part of the UW IMAP tookit.
|
|
imaprepl : http://www.bl0rg.net/software/
|
|
http://freecode.com/projects/imap-repl/
|
|
imapcopy : http://home.arcor.de/armin.diehl/imapcopy/imapcopy.html
|
|
migrationtool : http://sourceforge.net/projects/migrationtool/
|
|
imapmigrate : http://sourceforge.net/projects/cyrus-utils/
|
|
wonko_imapsync: http://wonko.com/article/554
|
|
see also file W/tools/wonko_ruby_imapsync
|
|
exchange-away : http://exchange-away.sourceforge.net/
|
|
pop2imap : http://www.linux-france.org/prj/pop2imap/
|
|
|
|
|
|
Feedback (good or bad) will often be welcome.
|
|
|
|
$Id: imapsync,v 1.727 2016/08/19 10:30:36 gilles Exp gilles $
|
|
|
|
=cut
|
|
|
|
|
|
# pragmas
|
|
|
|
use strict ;
|
|
use warnings ;
|
|
++$| ;
|
|
|
|
use Carp ;
|
|
use Data::Dumper ;
|
|
use Digest::HMAC_SHA1 qw( hmac_sha1 ) ;
|
|
use Digest::MD5 qw( md5 md5_hex md5_base64 ) ;
|
|
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 Imapsync::Getopt::Long ;
|
|
use IO::File ;
|
|
use IO::Socket qw(:crlf SOL_SOCKET SO_KEEPALIVE) ;
|
|
#use IO::Socket::SSL ;
|
|
use IO::Tee ;
|
|
use IPC::Open3 'open3' ;
|
|
use Mail::IMAPClient 3.30 ;
|
|
use MIME::Base64 ;
|
|
use POSIX qw(uname SIGALRM) ;
|
|
use Term::ReadKey ;
|
|
use Test::More ;
|
|
use Time::HiRes qw( time sleep ) ;
|
|
use Time::Local ;
|
|
use Unicode::String ;
|
|
use Cwd ;
|
|
use Readonly ;
|
|
|
|
# constants
|
|
|
|
# Let us do like sysexits.h
|
|
# /usr/include/sysexits.h
|
|
|
|
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_BY_SIGNAL => 6 ;
|
|
Readonly my $EXIT_PID_FILE_ALREADY_EXIST => 8 ;
|
|
Readonly my $EXIT_WITH_ERRORS => 111 ;
|
|
Readonly my $EXIT_WITH_ERRORS_MAX => 112 ;
|
|
Readonly my $EXIT_UNKNOWN => 126 ;
|
|
|
|
Readonly my $ERRORS_MAX => 50 ; # exit after 50 errors.
|
|
|
|
|
|
Readonly my $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 $RELEASE_NUMBER_EXAMPLE_1 => '1.351' ;
|
|
Readonly my $RELEASE_NUMBER_EXAMPLE_2 => 42.4242 ;
|
|
|
|
|
|
Readonly my $DEFAULT_TIMEOUT => 120 ;
|
|
Readonly my $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND => 3 ;
|
|
Readonly my $DEFAULT_UIDNEXT => 999999 ;
|
|
Readonly my $DEFAULT_BUFFER_SIZE => 4096 ;
|
|
|
|
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_20_000 => 20_000 ;
|
|
|
|
Readonly my $QUOTA_PERCENT_LIMIT => 90 ;
|
|
|
|
Readonly my $NUMBER_104857600 => 104857600 ;
|
|
|
|
Readonly my $SIZE_MAX_STR => 64 ;
|
|
|
|
Readonly my $NB_SECONDS_IN_A_DAY => 86400 ;
|
|
|
|
Readonly my $STD_CHAR_PER_LINE => 80 ;
|
|
|
|
Readonly my $TRUE => 1 ;
|
|
Readonly my $FALSE => 0 ;
|
|
|
|
Readonly my $LAST_RESSORT_SEPARATOR => q{/} ;
|
|
|
|
# global variables
|
|
|
|
my(
|
|
$sync,
|
|
$rcs,
|
|
$debug, $debugimap, $debugimap1, $debugimap2, $debugcontent, $debugflags,
|
|
$debuglist, $debugdev, $debugmaxlinelength, @debugbasket, $debugcgi,
|
|
$host1, $host2, $port1, $port2,
|
|
$user1, $user2, $domain1, $domain2,
|
|
$password1, $password2, $passfile1, $passfile2,
|
|
@folder, @include, @exclude, @folderrec,
|
|
@folderfirst, @folderlast,
|
|
$prefix1, $prefix2,
|
|
$subfolder2,
|
|
@regextrans2, @regexmess, @regexflag, @skipmess, @pipemess, $pipemesscheck,
|
|
$flagscase, $filterflags, $syncflagsaftercopy,
|
|
$sep1, $sep2,
|
|
$syncinternaldates,
|
|
$idatefromheader,
|
|
$syncacls,
|
|
$fastio1, $fastio2,
|
|
$maxsize, $minsize, $maxage, $minage,
|
|
$exitwhenover,
|
|
$search, $search1, $search2,
|
|
$skipheader, @useheader,
|
|
$skipsize, $allowsizemismatch, $foldersizes, $foldersizesatend, $buffersize,
|
|
$delete, $delete2, $delete2duplicates,
|
|
$expunge, $expunge1, $expunge2, $uidexpunge2, $dry,
|
|
$justfoldersizes,
|
|
$authmd5, $authmd51, $authmd52,
|
|
$subscribed, $subscribe, $subscribeall,
|
|
$version, $help,
|
|
$justconnect, $justfolders, $justbanner,
|
|
$fast,
|
|
|
|
$total_bytes_transferred,
|
|
$total_bytes_skipped,
|
|
$total_bytes_error,
|
|
$nb_msg_transferred,
|
|
$nb_msg_skipped,
|
|
$nb_msg_skipped_dry_mode,
|
|
$h1_nb_msg_duplicate,
|
|
$h2_nb_msg_duplicate,
|
|
$h1_nb_msg_noheader,
|
|
$h2_nb_msg_noheader,
|
|
$h1_total_bytes_duplicate,
|
|
$h2_total_bytes_duplicate,
|
|
$h1_nb_msg_deleted,
|
|
$h2_nb_msg_deleted,
|
|
|
|
$h1_bytes_processed,
|
|
$h1_nb_msg_processed,
|
|
$h1_nb_msg_start, $h1_bytes_start,
|
|
$h2_nb_msg_start, $h2_bytes_start,
|
|
$h1_nb_msg_end, $h1_bytes_end,
|
|
$h2_nb_msg_end, $h2_bytes_end,
|
|
|
|
$timeout,
|
|
$timestart_int, $timeend,
|
|
$timebefore,
|
|
$ssl1, $ssl2,
|
|
$ssl1_ssl_version, $ssl2_ssl_version,
|
|
$tls1, $tls2,
|
|
$uid1, $uid2,
|
|
$authuser1, $authuser2,
|
|
$proxyauth1, $proxyauth2,
|
|
$authmech1, $authmech2,
|
|
$split1, $split2,
|
|
$reconnectretry1, $reconnectretry2,
|
|
$tests, $test_builder, $testsdebug, $testslive,
|
|
$justlogin,
|
|
$tmpdir,
|
|
$releasecheck,
|
|
$max_msg_size_in_bytes,
|
|
$modulesversion,
|
|
$delete2folders, $delete2foldersonly, $delete2foldersbutnot,
|
|
$usecache, $debugcache, $cacheaftercopy,
|
|
$wholeheaderifneeded, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess,
|
|
$addheader,
|
|
%h1, %h2,
|
|
$checkselectable, $checkmessageexists,
|
|
$expungeaftereach,
|
|
$abletosearch,
|
|
$showpasswords,
|
|
$fixslash2,
|
|
$messageidnodomain,
|
|
$fixInboxINBOX,
|
|
$maxlinelength, $maxlinelengthcmd,
|
|
$minmaxlinelength,
|
|
$uidnext_default,
|
|
$fixcolonbug,
|
|
$create_folder_old,
|
|
$maxmessagespersecond,
|
|
$maxbytespersecond,
|
|
$skipcrossduplicates, $debugcrossduplicates,
|
|
$disarmreadreceipts,
|
|
$mixfolders, $skipemptyfolders,
|
|
$fetch_hash_set,
|
|
);
|
|
|
|
# main program
|
|
|
|
# global variables initialisation
|
|
|
|
$rcs = q{$Id: imapsync,v 1.727 2016/08/19 10:30:36 gilles Exp gilles $} ;
|
|
|
|
$total_bytes_transferred = 0;
|
|
$total_bytes_skipped = 0;
|
|
$total_bytes_error = 0;
|
|
$nb_msg_transferred = 0;
|
|
$nb_msg_skipped = $nb_msg_skipped_dry_mode = 0;
|
|
$h1_nb_msg_deleted = $h2_nb_msg_deleted = 0;
|
|
$h1_nb_msg_duplicate = $h2_nb_msg_duplicate = 0;
|
|
$h1_nb_msg_noheader = $h2_nb_msg_noheader = 0;
|
|
$h1_total_bytes_duplicate = $h2_total_bytes_duplicate = 0;
|
|
|
|
|
|
$h1_nb_msg_start = $h1_bytes_start = 0 ;
|
|
$h2_nb_msg_start = $h2_bytes_start = 0 ;
|
|
$h1_nb_msg_processed = $h1_bytes_processed = 0 ;
|
|
|
|
#$h1_nb_msg_end = $h1_bytes_end = 0 ;
|
|
#$h2_nb_msg_end = $h2_bytes_end = 0 ;
|
|
|
|
$sync->{nb_errors} = 0;
|
|
$max_msg_size_in_bytes = 0;
|
|
|
|
my %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',
|
|
);
|
|
|
|
|
|
|
|
|
|
# @ARGV will be eat by get_options()
|
|
my @argv_copy = @ARGV;
|
|
|
|
my $cgi_dir = '/var/tmp/imapsync_cgi' ;
|
|
|
|
# Under CGI environment
|
|
if ( $ENV{SERVER_SOFTWARE} ) {
|
|
myprint( "\n" ) ;
|
|
myprint( "<pre>\n" ) ;
|
|
-d $cgi_dir or mkpath $cgi_dir or die "Can not create $cgi_dir: $!\n" ;
|
|
chdir $cgi_dir or die "Can not cd to $cgi_dir: $!\n" ;
|
|
}
|
|
|
|
get_options( ) ;
|
|
unsetunsafe( ) if ( $ENV{SERVER_SOFTWARE} ) ;
|
|
|
|
# Under CGI environment
|
|
if ( $ENV{SERVER_SOFTWARE} ) {
|
|
myprint( 'Current directory is ' . getcwd( ) . "\n" ) ;
|
|
myprint( 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ;
|
|
myprint( 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ;
|
|
}
|
|
|
|
local $SIG{ INT } = sub {
|
|
my $signame = shift ;
|
|
catch_reconnect( $sync, $signame ) ;
|
|
} ;
|
|
|
|
local $SIG{ QUIT } = local $SIG{ TERM } = sub {
|
|
my $signame = shift ;
|
|
catch_exit( $sync, $signame ) ;
|
|
} ;
|
|
|
|
|
|
$sync->{timestart} = $BASETIME ; # Never too let reading books and perlvar
|
|
|
|
$sync->{log} = defined $sync->{log} ? $sync->{log} : 1 ;
|
|
$sync->{errorsdump} = defined $sync->{errorsdump} ? $sync->{errorsdump} : 1 ;
|
|
$sync->{errorsmax} = defined $sync->{errorsmax} ? $sync->{errorsmax} : $ERRORS_MAX ;
|
|
|
|
$sync->{user2} = $user2 ;
|
|
|
|
if ( $sync->{log} ) {
|
|
setlogfile( $sync ) ;
|
|
teelaunch( $sync ) ;
|
|
}
|
|
|
|
$timestart_int = int( $sync->{timestart} ) ;
|
|
$timebefore = $sync->{timestart} ;
|
|
|
|
my $timestart_str = localtime( $sync->{timestart} ) ;
|
|
myprint( "Transfer started at $timestart_str\n" ) ;
|
|
myprint( "PID is $PROCESS_ID\n" ) ;
|
|
myprint( "Log file is $sync->{logfile} ( to change it, use --logfile path ; or use --nolog to turn off logging )\n" ) if ( $sync->{log} ) ;
|
|
$modulesversion = defined $modulesversion ? $modulesversion : 1 ;
|
|
|
|
# If you want releasecheck not to be done by default (like the github maintainer),
|
|
# then uncomment the first "$releasecheck =" line, the line ending with "0 ;".
|
|
# The second line (ending with "1 ;") can stay active or be commented,
|
|
# the result will be the same: no releasecheck by default.
|
|
|
|
$releasecheck = defined $releasecheck ? $releasecheck : 0 ;
|
|
#$releasecheck = defined $releasecheck ? $releasecheck : 1 ;
|
|
|
|
my $warn_release = ( $releasecheck ) ? check_last_release( ) : q{} ;
|
|
|
|
# default values
|
|
|
|
$sync->{pidfile} = defined $sync->{pidfile} ? $sync->{pidfile} : $tmpdir . '/imapsync.pid' ;
|
|
|
|
$sync->{pidfilelocking} = defined $sync->{pidfilelocking} ? $sync->{pidfilelocking} : 0 ;
|
|
|
|
$wholeheaderifneeded = defined $wholeheaderifneeded ? $wholeheaderifneeded : 1;
|
|
|
|
# turn on RFC standard flags correction like \SEEN -> \Seen
|
|
$flagscase = defined $flagscase ? $flagscase : 1 ;
|
|
|
|
# Use PERMANENTFLAGS if available
|
|
$filterflags = defined $filterflags ? $filterflags : 1 ;
|
|
|
|
# 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 ;
|
|
|
|
|
|
# Activate --usecache if --useuid is set and no --nousecache
|
|
$usecache = 1 if ( $useuid and ( ! defined $usecache ) ) ;
|
|
$cacheaftercopy = 1 if ( $usecache and ( ! defined $cacheaftercopy ) ) ;
|
|
|
|
$checkselectable = defined $checkselectable ? $checkselectable : 1 ;
|
|
$checkmessageexists = defined $checkmessageexists ? $checkmessageexists : 0 ;
|
|
$expungeaftereach = defined $expungeaftereach ? $expungeaftereach : 1 ;
|
|
$abletosearch = defined $abletosearch ? $abletosearch : 1 ;
|
|
$checkmessageexists = 0 if ( not $abletosearch ) ;
|
|
$showpasswords = defined $showpasswords ? $showpasswords : 0 ;
|
|
$fixslash2 = defined $fixslash2 ? $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 ;
|
|
|
|
$delete2duplicates = 1 if ( $delete2 and ( ! defined $delete2duplicates ) ) ;
|
|
|
|
$maxmessagespersecond = defined $maxmessagespersecond ? $maxmessagespersecond : 0 ;
|
|
$maxbytespersecond = defined $maxbytespersecond ? $maxbytespersecond : 0 ;
|
|
|
|
myprint( banner_imapsync( @argv_copy ) ) ;
|
|
|
|
myprint( "Temp directory is $tmpdir ( to change it use --tmpdir dirpath )\n") ;
|
|
|
|
is_valid_directory( $tmpdir ) || croak "Error creating tmpdir $tmpdir : $!" ;
|
|
|
|
if ( $sync->{pidfile} ) {
|
|
write_pidfile( $sync->{pidfile}, $sync->{pidfilelocking} ) ;
|
|
}
|
|
|
|
$fixcolonbug = defined $fixcolonbug ? $fixcolonbug : 1 ;
|
|
|
|
if ( $usecache and $fixcolonbug ) { tmpdir_fix_colon_bug( ) } ;
|
|
|
|
$modulesversion and myprint( "Modules version list:\n", modulesversion(), "( use --no-modulesversion to turn off printing this Perl modules list )\n" ) ;
|
|
|
|
my $DEFAULT_SSL_VERIFY ;
|
|
my %SSL_VERIFY_STR ;
|
|
|
|
if ( $ssl1 or $ssl2 or $tls1 or $tls2) {
|
|
Readonly $DEFAULT_SSL_VERIFY => IO::Socket::SSL::SSL_VERIFY_NONE( ) ;
|
|
Readonly %SSL_VERIFY_STR => (
|
|
IO::Socket::SSL::SSL_VERIFY_NONE( ) => 'SSL_VERIFY_NONE' ,
|
|
IO::Socket::SSL::SSL_VERIFY_PEER( ) => 'SSL_VERIFY_PEER' ,
|
|
) ;
|
|
$IO::Socket::SSL::DEBUG = $sync->{debugssl} || 1 ;
|
|
myprint( "SSL debug mode level is --debugssl $IO::Socket::SSL::DEBUG (can be set from 0 meaning no debug to 4 meaning max debug)\n" ) ;
|
|
}
|
|
|
|
if ( $ssl1 ) {
|
|
myprint( 'Host1: SSL default mode is like --sslargs1 SSL_verify_mode=' . $DEFAULT_SSL_VERIFY . " meaning $SSL_VERIFY_STR{$DEFAULT_SSL_VERIFY} on host1 (do not check the certificate server)\n" ) ;
|
|
myprint( 'Host1: Use --sslargs1 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " for $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} on host1\n" ) ;
|
|
}
|
|
if ( $ssl2 ) {
|
|
myprint( 'Host2: SSL default mode is like --sslargs2 SSL_verify_mode=' . $DEFAULT_SSL_VERIFY . " meaning $SSL_VERIFY_STR{$DEFAULT_SSL_VERIFY} on host2 (do not check the certificate server)\n" ) ;
|
|
myprint( 'Host2: Use --sslargs2 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " for $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} on host2\n" ) ;
|
|
}
|
|
|
|
|
|
check_lib_version( ) or
|
|
croak "imapsync needs perl lib Mail::IMAPClient release 3.30 or superior.\n";
|
|
|
|
exit_clean( $sync, $EX_OK ) if ( $justbanner ) ;
|
|
|
|
|
|
$split1 ||= $SPLIT ;
|
|
$split2 ||= $SPLIT ;
|
|
|
|
$host1 || missing_option( '--host1' ) ;
|
|
$port1 ||= ( $ssl1 ) ? $IMAP_SSL_PORT : $IMAP_PORT ;
|
|
|
|
$host2 || missing_option( '--host2' ) ;
|
|
$port2 ||= ( $ssl2 ) ? $IMAP_SSL_PORT : $IMAP_PORT ;
|
|
|
|
$debugimap1 = $debugimap2 = 1 if ( $debugimap ) ;
|
|
$debug = 1 if ( $debugimap1 or $debugimap2 ) ;
|
|
|
|
# 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;
|
|
|
|
$delete2folders = 1
|
|
if ( defined $delete2foldersbutnot or defined $delete2foldersonly ) ;
|
|
|
|
if ( $justconnect ) {
|
|
justconnect( ) ;
|
|
exit_clean( $sync, $EX_OK ) ;
|
|
}
|
|
|
|
$user1 || missing_option( '--user1' ) ;
|
|
$user2 || missing_option( '--user2' ) ;
|
|
|
|
$syncinternaldates = defined $syncinternaldates ? $syncinternaldates : 1;
|
|
|
|
# Turn on expunge if there is not explicit option --noexpunge and option
|
|
# --delete is given.
|
|
# Done because --delete --noexpunge is very dangerous on the second run:
|
|
# the Deleted flag is then synced to all previously transfered messages.
|
|
# So --delete implies --expunge is a better usability default behaviour.
|
|
if ( $delete ) {
|
|
if ( ! defined $expunge ) {
|
|
myprint( "Info: turning on --expunge1 because --delete --noexpunge1 is very dangerous on the second run.\n" ) ;
|
|
$expunge = 1 ;
|
|
}
|
|
myprint( "Info: if expunging after each message slows down too much the sync then use --noexpungeaftereach to speed up\n" ) ;
|
|
}
|
|
|
|
if ( $uidexpunge2 and not Mail::IMAPClient->can( 'uidexpunge' ) ) {
|
|
myprint( "Failure: uidexpunge not supported (IMAPClient release < 3.17), use --expunge2 instead\n" ) ;
|
|
exit_clean( $sync, $EX_SOFTWARE ) ;
|
|
}
|
|
|
|
if ( ( $delete2 or $delete2duplicates ) and not defined $uidexpunge2 ) {
|
|
if ( Mail::IMAPClient->can( 'uidexpunge' ) ) {
|
|
myprint( "Info: will act as --uidexpunge2\n" ) ;
|
|
$uidexpunge2 = 1 ;
|
|
}elsif ( not defined $expunge2 ) {
|
|
myprint( "Info: will act as --expunge2 (no uidexpunge support)\n" ) ;
|
|
$expunge2 = 1 ;
|
|
}
|
|
}
|
|
|
|
if ( $delete and $delete2 ) {
|
|
myprint( "Warning: using --delete and --delete2 together is almost always a bad idea, exiting imapsync\n" ) ;
|
|
exit_clean( $sync, $EX_USAGE ) ;
|
|
}
|
|
|
|
if ( $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 ) {
|
|
$authmech1 ||= 'CRAM-MD5';
|
|
}
|
|
else{
|
|
$authmech1 ||= $authuser1 ? 'PLAIN' : 'LOGIN';
|
|
}
|
|
|
|
if ( defined $authmd52 and $authmd52 ) {
|
|
$authmech2 ||= 'CRAM-MD5';
|
|
}
|
|
else{
|
|
$authmech2 ||= $authuser2 ? 'PLAIN' : 'LOGIN';
|
|
}
|
|
|
|
$authmech1 = uc $authmech1;
|
|
$authmech2 = uc $authmech2;
|
|
|
|
if (defined $proxyauth1 && !$authuser1) {
|
|
missing_option( 'With --proxyauth1, --authuser1' ) ;
|
|
}
|
|
|
|
if (defined $proxyauth2 && !$authuser2) {
|
|
missing_option( 'With --proxyauth2, --authuser2' ) ;
|
|
}
|
|
|
|
$authuser1 ||= $user1;
|
|
$authuser2 ||= $user2;
|
|
|
|
myprint( "Host1: will try to use $authmech1 authentication on host1\n") ;
|
|
myprint( "Host2: will try to use $authmech2 authentication on host2\n") ;
|
|
|
|
$timeout = defined $timeout ? $timeout : $DEFAULT_TIMEOUT ;
|
|
|
|
$sync->{h1}->{timeout} = defined $sync->{h1}->{timeout} ? $sync->{h1}->{timeout} : $timeout ;
|
|
myprint( "Host1: imap connexion timeout is $sync->{h1}->{timeout} seconds\n") ;
|
|
$sync->{h2}->{timeout} = defined $sync->{h2}->{timeout} ? $sync->{h2}->{timeout} : $timeout ;
|
|
myprint( "Host2: imap connexion timeout is $sync->{h2}->{timeout} seconds\n" ) ;
|
|
|
|
$syncacls = defined $syncacls ? $syncacls : 0 ;
|
|
|
|
# No folders sizes if --justfolders, unless really wanted.
|
|
if ( $justfolders and not defined $foldersizes ) { $foldersizes = 0 ; }
|
|
|
|
$foldersizes = ( defined $foldersizes ) ? $foldersizes : 1 ;
|
|
$foldersizesatend = ( defined $foldersizesatend ) ? $foldersizesatend : $foldersizes ;
|
|
|
|
$fastio1 = defined $fastio1 ? $fastio1 : 0 ;
|
|
$fastio2 = defined $fastio2 ? $fastio2 : 0 ;
|
|
|
|
$reconnectretry1 = defined $reconnectretry1 ? $reconnectretry1 : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ;
|
|
$reconnectretry2 = defined $reconnectretry2 ? $reconnectretry2 : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ;
|
|
|
|
# Since select_msgs() returns no messages when uidnext does not return something
|
|
# then $uidnext_default is never used. So I have to remove it.
|
|
$uidnext_default = $DEFAULT_UIDNEXT ;
|
|
|
|
@useheader = qw( Message-Id Received ) unless ( @useheader ) ;
|
|
|
|
my %useheader ;
|
|
|
|
# Make a hash %useheader of each --useheader 'key' in uppercase
|
|
for ( @useheader ) { $useheader{ uc $_ } = undef } ;
|
|
|
|
#myprint( Data::Dumper->Dump( [ \%useheader ] ) ) ;
|
|
#exit ;
|
|
|
|
myprint( "Host1: IMAP server [$host1] port [$port1] user [$user1]\n" ) ;
|
|
myprint( "Host2: IMAP server [$host2] port [$port2] user [$user2]\n" ) ;
|
|
|
|
$password1 || $passfile1 || 'PREAUTH' eq $authmech1 || 'EXTERNAL' eq $authmech1 || do {
|
|
myprint( << 'FIN_PASSFILE' ) ;
|
|
|
|
If you are afraid of giving password on the command line arguments, you can put the
|
|
password of user1 in a file named file1 and use "--passfile1 file1" instead of typing it.
|
|
Then give this file restrictive permissions with the command "chmod 600 file1".
|
|
FIN_PASSFILE
|
|
|
|
$password1 = ask_for_password( $authuser1 || $user1, $host1 ) ;
|
|
} ;
|
|
|
|
$password1 = ( defined $passfile1 ) ? firstline ( $passfile1 ) : $password1 ;
|
|
|
|
|
|
$password2 || $passfile2 || 'PREAUTH' eq $authmech2 || 'EXTERNAL' eq $authmech2 || do {
|
|
myprint( << 'FIN_PASSFILE' ) ;
|
|
|
|
If you are afraid of giving password on the command line arguments, you can put the
|
|
password of user2 in a file named file2 and use "--passfile2 file2" instead of typing it.
|
|
Then give this file restrictive permissions with the command "chmod 600 file2".
|
|
FIN_PASSFILE
|
|
|
|
$password2 = ask_for_password( $authuser2 || $user2, $host2 ) ;
|
|
} ;
|
|
|
|
$password2 = ( defined $passfile2 ) ? firstline ( $passfile2 ) : $password2 ;
|
|
|
|
|
|
# need clean up => write methods dry() and dry_message()
|
|
$sync->{dry} = $dry ;
|
|
my $dry_message = q{} ;
|
|
if( $sync->{dry} ) {
|
|
$dry_message = "\t(not really since --dry mode)" ;
|
|
}
|
|
$sync->{dry_message} = $dry_message ;
|
|
|
|
|
|
$search1 ||= $search if ( $search ) ;
|
|
$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 ) ) {
|
|
die_clean( "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 ) ) {
|
|
die_clean( "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 ) ) {
|
|
die_clean( 'Error: one of --regexmess option is bad, check it' ) ;
|
|
}
|
|
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 ) ) {
|
|
die_clean( 'Error: one of --skipmess option is bad, check it' ) ;
|
|
}
|
|
myprint( "Ok with each --skipmess\n" ) ;
|
|
}
|
|
|
|
if ( @regexflag ) {
|
|
myprint( "Checking each --regexflag command with an space string.\n" ) ;
|
|
my $string = flags_regex( q{ } ) ;
|
|
# string undef means one of the eval regex was bad.
|
|
if ( not ( defined $string ) ) {
|
|
die_clean( 'Error: one of --regexflag option is bad, check it' ) ;
|
|
}
|
|
myprint( "Ok with each --regexflag\n" ) ;
|
|
}
|
|
|
|
$sync->{imap1} = my $imap1 = login_imap($host1, $port1, $user1, $domain1, $password1,
|
|
$debugimap1, $sync->{h1}->{timeout}, $fastio1, $ssl1, $tls1,
|
|
$authmech1, $authuser1, $reconnectretry1,
|
|
$proxyauth1, $uid1, $split1, 'Host1', $sync->{h1} ) ;
|
|
|
|
$sync->{imap2} = my $imap2 = login_imap($host2, $port2, $user2, $domain2, $password2,
|
|
$debugimap2, $sync->{h2}->{timeout}, $fastio2, $ssl2, $tls2,
|
|
$authmech2, $authuser2, $reconnectretry2,
|
|
$proxyauth2, $uid2, $split2, 'Host2', $sync->{h2} ) ;
|
|
|
|
|
|
$debug and myprint( 'Host1 Buffer I/O: ', $imap1->Buffer(), "\n" ) ;
|
|
$debug and myprint( 'Host2 Buffer I/O: ', $imap2->Buffer(), "\n" ) ;
|
|
|
|
|
|
die_clean( 'Not authenticated on host1' ) unless $imap1->IsAuthenticated( ) ;
|
|
myprint( "Host1: state Authenticated\n" ) ;
|
|
die_clean( 'Not authenticated on host2' ) unless $imap2->IsAuthenticated( ) ;
|
|
myprint( "Host2: state Authenticated\n" ) ;
|
|
|
|
myprint( 'Host1 capability: ', join(q{ }, @{ $imap1->capability_update() || [] }), "\n" ) ;
|
|
myprint( 'Host2 capability: ', join(q{ }, @{ $imap2->capability_update() || [] }), "\n" ) ;
|
|
|
|
imap_id_stuff( $sync ) ;
|
|
|
|
#quota( $imap1, 'host1' ) ; # quota on host1 is useless and pollute host2 output.
|
|
quota( $imap2, 'host2', $sync ) ;
|
|
|
|
if ( $justlogin ) {
|
|
$imap1->logout( ) ;
|
|
$imap2->logout( ) ;
|
|
exit_clean( $sync, $EX_OK ) ;
|
|
}
|
|
|
|
|
|
#
|
|
# Folder stuff
|
|
#
|
|
|
|
my (
|
|
@h1_folders_all , %h1_folders_all , @h1_folders_wanted , %requested_folder ,
|
|
%h1_subscribed_folder , %h2_subscribed_folder ,
|
|
@h2_folders_all , %h2_folders_all , %h2_folders_all_UPPER ,
|
|
@h2_folders_from_1_wanted , %h2_folders_from_1_wanted ,
|
|
%h2_folders_from_1_several ,
|
|
%h2_folders_from_1_all ,
|
|
) ;
|
|
|
|
my $h1_folders_wanted_nb = 0 ;
|
|
my $h1_folders_wanted_ct = 0 ; # counter of folders done.
|
|
|
|
# All folders on host1 and host2
|
|
|
|
@h1_folders_all = sort $imap1->folders( ) ;
|
|
@h2_folders_all = sort $imap2->folders( ) ;
|
|
|
|
myprint( 'Host1: found ', scalar @h1_folders_all , " folders.\n" ) ;
|
|
myprint( 'Host2: found ', scalar @h2_folders_all , " folders.\n" ) ;
|
|
|
|
for ( @h1_folders_all ) { $h1_folders_all{ $_ } = 1 } ;
|
|
for ( @h2_folders_all ) {
|
|
$h2_folders_all{ $_ } = 1 ;
|
|
$h2_folders_all_UPPER{ uc $_ } = 1 ;
|
|
} ;
|
|
|
|
$sync->{h1_folders_all} = \%h1_folders_all ;
|
|
$sync->{h2_folders_all} = \%h2_folders_all ;
|
|
$sync->{h2_folders_all_UPPER} = \%h2_folders_all_UPPER ;
|
|
|
|
# Make a hash of subscribed folders in both servers.
|
|
|
|
for ( $imap1->subscribed( ) ) { $h1_subscribed_folder{ $_ } = 1 } ;
|
|
for ( $imap2->subscribed( ) ) { $h2_subscribed_folder{ $_ } = 1 } ;
|
|
|
|
|
|
if ( defined $subfolder2 ) {
|
|
unshift @regextrans2,
|
|
q's,^${h2_prefix}(.*),${h2_prefix}${subfolder2}${h2_sep}$1,',
|
|
q's,^INBOX$,${h2_prefix}${subfolder2}${h2_sep}INBOX,' ;
|
|
|
|
}
|
|
|
|
if ( $fixInboxINBOX and ( my $reg = fix_Inbox_INBOX_mapping( \%h1_folders_all, \%h2_folders_all ) ) ) {
|
|
push @regextrans2, $reg ;
|
|
}
|
|
|
|
if (scalar @folder or $subscribed or scalar @folderrec) {
|
|
# folders given by option --folder
|
|
if (scalar @folder) {
|
|
add_to_requested_folders(@folder);
|
|
}
|
|
|
|
# option --subscribed
|
|
if ( $subscribed ) {
|
|
add_to_requested_folders( keys %h1_subscribed_folder ) ;
|
|
}
|
|
|
|
# option --folderrec
|
|
if (scalar @folderrec) {
|
|
foreach my $folderrec (@folderrec) {
|
|
add_to_requested_folders($imap1->folders($folderrec));
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
# no include, no folder/subscribed/folderrec options => all folders
|
|
if (not scalar @include) {
|
|
myprint( "Including all folders found by default. Use --subscribed or --folder or --folderrec or --include to select specific folders. Use --exclude to unselect specific folders.\n" ) ;
|
|
add_to_requested_folders(@h1_folders_all);
|
|
}
|
|
}
|
|
|
|
|
|
# consider (optional) includes and excludes
|
|
if ( scalar @include ) {
|
|
foreach my $include ( @include ) {
|
|
my @included_folders = grep { /$include/ } @h1_folders_all ;
|
|
add_to_requested_folders( @included_folders ) ;
|
|
myprint( "Including folders matching pattern $include\n" . jux_utf8_list( @included_folders ) . "\n" ) ;
|
|
}
|
|
}
|
|
|
|
if ( scalar @exclude ) {
|
|
foreach my $exclude ( @exclude ) {
|
|
my @requested_folder = sort keys %requested_folder ;
|
|
my @excluded_folders = grep { /$exclude/ } @requested_folder ;
|
|
remove_from_requested_folders( @excluded_folders ) ;
|
|
myprint( "Excluding folders matching pattern $exclude\n" . jux_utf8_list( @excluded_folders ) . "\n" ) ;
|
|
}
|
|
}
|
|
|
|
|
|
# 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( ) ;
|
|
|
|
# Remove no selectable folders
|
|
|
|
|
|
my @h1_folders_wanted_exist ;
|
|
myprint( "Host1: checking all wanted folders exist.\n" ) ;
|
|
foreach my $folder ( @h1_folders_wanted ) {
|
|
( $debug or $sync->{debugfolders} ) and myprint( "Checking $folder exists on host1\n" ) ;
|
|
if ( ! exists $h1_folders_all{ $folder } ) {
|
|
myprint( "Host1: warning! ignoring folder $folder because it is not in host1 whole folders list.\n" ) ;
|
|
next ;
|
|
}else{
|
|
push @h1_folders_wanted_exist, $folder ;
|
|
}
|
|
}
|
|
|
|
@h1_folders_wanted = @h1_folders_wanted_exist ;
|
|
|
|
|
|
|
|
$checkselectable and do {
|
|
my @h1_folders_wanted_selectable ;
|
|
myprint( "Host1: checking all wanted folders are selectable. Use --nocheckselectable to avoid this check.\n" ) ;
|
|
foreach my $folder ( @h1_folders_wanted ) {
|
|
( $debug or $sync->{debugfolders} ) and myprint( "Checking $folder is selectable on host1\n" ) ;
|
|
if ( ! $imap1->selectable( $folder ) ) {
|
|
myprint( "Host1: warning! ignoring folder $folder because it is not selectable\n" ) ;
|
|
}else{
|
|
push @h1_folders_wanted_selectable, $folder ;
|
|
}
|
|
}
|
|
@h1_folders_wanted = @h1_folders_wanted_selectable ;
|
|
( $debug or $sync->{debugfolders} ) and myprint( 'Host1: checking folders took ', timenext( ), " s\n" ) ;
|
|
} ;
|
|
|
|
$sync->{h1_folders_wanted} = \@h1_folders_wanted ;
|
|
|
|
|
|
my( $h1_sep, $h2_sep ) ;
|
|
# what are the private folders separators for each server ?
|
|
|
|
( $debug or $sync->{debugfolders} ) and myprint( "Getting separators\n" ) ;
|
|
$h1_sep = get_separator( $imap1, $sep1, '--sep1', 'Host1', \@h1_folders_all ) ;
|
|
$h2_sep = get_separator( $imap2, $sep2, '--sep2', 'Host2', \@h2_folders_all ) ;
|
|
|
|
my( $h1_prefix, $h2_prefix ) ;
|
|
$sync->{ h1_prefix } = $h1_prefix = get_prefix( $imap1, $prefix1, '--prefix1', 'Host1', \@h1_folders_all ) ;
|
|
$sync->{ h2_prefix } = $h2_prefix = get_prefix( $imap2, $prefix2, '--prefix2', 'Host2', \@h2_folders_all ) ;
|
|
|
|
|
|
myprint( "Host1 separator and prefix: [$h1_sep][$h1_prefix]\n" ) ;
|
|
myprint( "Host2 separator and prefix: [$h2_sep][$h2_prefix]\n" ) ;
|
|
|
|
automap( $sync ) ;
|
|
|
|
|
|
foreach my $h1_fold ( @h1_folders_wanted ) {
|
|
my $h2_fold ;
|
|
$h2_fold = imap2_folder_name( $h1_fold ) ;
|
|
$h2_folders_from_1_wanted{ $h2_fold }++ ;
|
|
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( $h1_fold ) ;
|
|
$h2_folders_from_1_all{ $h2_fold }++ ;
|
|
}
|
|
|
|
|
|
|
|
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 uft8 output just printed for convenience, to recognize it.
|
|
|
|
END_LISTING
|
|
|
|
print
|
|
"Host1 folders list:\n",
|
|
jux_utf8_list( @h1_folders_all ),
|
|
"\n",
|
|
"Host2 folders list:\n",
|
|
jux_utf8_list( @h2_folders_all ),
|
|
"\n" ;
|
|
|
|
print
|
|
'Host1 subscribed folders list: ',
|
|
jux_utf8_list( sort keys %h1_subscribed_folder ), "\n"
|
|
if ( $subscribed ) ;
|
|
|
|
my @h2_folders_not_in_1;
|
|
@h2_folders_not_in_1 = list_folders_in_2_not_in_1( ) ;
|
|
|
|
if ( @h2_folders_not_in_1 ) {
|
|
myprint( "Folders in host2 not in host1:\n",
|
|
jux_utf8_list( @h2_folders_not_in_1 ), "\n" ) ;
|
|
}
|
|
|
|
|
|
if ( defined $sync->{f1f2auto} ) {
|
|
myprint( "Folders mapping from --automap feature (use --f1f2 to override any mapping):\n" ) ;
|
|
foreach my $h1_fold ( keys %{$sync->{f1f2auto}} ) {
|
|
my $h2_fold = $sync->{f1f2auto}{$h1_fold} ;
|
|
myprintf( "%-40s -> %-40s\n",
|
|
jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ;
|
|
}
|
|
myprint( "\n" ) ;
|
|
}
|
|
|
|
if ( defined $sync->{f1f2} ) {
|
|
myprint( "Folders mapping from --f1f2 options, it overrides --automap:\n" ) ;
|
|
foreach my $h1_fold ( keys %{$sync->{f1f2}} ) {
|
|
my $h2_fold = $sync->{f1f2}{$h1_fold} ;
|
|
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 ) if ( $sync->{justfolderlists} ) ;
|
|
exit_clean( $sync, $EX_OK ) if ( $sync->{justautomap} ) ;
|
|
|
|
debugsleep( $sync ) ;
|
|
|
|
if ( $foldersizes ) {
|
|
foldersizes_on_h1h2( ) ;
|
|
}
|
|
|
|
|
|
exit_clean( $sync, $EX_OK ) if ( $justfoldersizes ) ;
|
|
|
|
$sync->{stats} = 1 ;
|
|
|
|
if ( $sync->{'delete1emptyfolders'} ) {
|
|
delete1emptyfolders( $sync ) ;
|
|
}
|
|
|
|
delete_folders_in_2_not_in_1( ) if $delete2folders ;
|
|
|
|
# folder loop
|
|
$h1_folders_wanted_nb = scalar @h1_folders_wanted ;
|
|
|
|
myprint( "++++ Looping on each one of $h1_folders_wanted_nb folders to sync\n" ) ;
|
|
|
|
my $begin_transfer_time = time ;
|
|
|
|
my %uid_candidate_for_deletion ;
|
|
my %uid_candidate_no_deletion ;
|
|
|
|
my %h2_folders_of_md5 = ( ) ;
|
|
|
|
FOLDER: foreach my $h1_fold ( @h1_folders_wanted ) {
|
|
|
|
last FOLDER if $imap1->IsUnconnected( ) ;
|
|
last FOLDER if $imap2->IsUnconnected( ) ;
|
|
|
|
my $h2_fold = imap2_folder_name( $h1_fold ) ;
|
|
|
|
$h1_folders_wanted_ct++ ;
|
|
myprintf( "Folder %7s %-35s -> %-35s\n", "$h1_folders_wanted_ct/$h1_folders_wanted_nb",
|
|
jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ;
|
|
if ( $sync->{debugmemory} ) {
|
|
myprintf("FL: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
|
|
}
|
|
# host1 can not be fetched read only, select is needed because of expunge.
|
|
select_folder( $imap1, $h1_fold, 'Host1' ) or next FOLDER ;
|
|
|
|
debugsleep( $sync ) ;
|
|
|
|
my $h1_fold_nb_messages = count_from_select( $imap1->History ) ;
|
|
myprint( "Host1 folder [$h1_fold] has $h1_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ;
|
|
|
|
if ( $skipemptyfolders and 0 == $h1_fold_nb_messages ) {
|
|
myprint( "Skipping empty host1 folder [$h1_fold]\n" ) ;
|
|
next FOLDER ;
|
|
}
|
|
|
|
if ( ! exists $h2_folders_all{ $h2_fold } ) {
|
|
create_folder( $imap2, $h2_fold, $h1_fold ) or next FOLDER ;
|
|
}
|
|
|
|
acls_sync( $h1_fold, $h2_fold ) ;
|
|
|
|
# Sometimes the folder on host2 is listed (it exists) but is
|
|
# not selectable but becomes selectable by a create (Gmail)
|
|
select_folder( $imap2, $h2_fold, 'Host2' )
|
|
or ( create_folder( $imap2, $h2_fold, $h1_fold )
|
|
and select_folder( $imap2, $h2_fold, 'Host2' ) )
|
|
or next FOLDER ;
|
|
my @select_results = $imap2->Results( ) ;
|
|
|
|
my $h2_fold_nb_messages = count_from_select( @select_results ) ;
|
|
myprint( "Host2 folder [$h2_fold] has $h2_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ;
|
|
|
|
my $permanentflags2 = permanentflags( @select_results ) ;
|
|
( $debug or $debugflags ) and myprint( "Host2 folder [$h2_fold] permanentflags: $permanentflags2\n" ) ;
|
|
|
|
if ( $expunge or $expunge1 ){
|
|
myprint( "Host1: Expunging $h1_fold $dry_message\n" ) ;
|
|
unless( $dry ) { $imap1->expunge( ) } ;
|
|
}
|
|
|
|
if ( ( ( $subscribe and exists $h1_subscribed_folder{ $h1_fold } ) or $subscribeall )
|
|
and not exists $h2_subscribed_folder{ $h2_fold } ) {
|
|
myprint( "Host2: Subscribing to folder $h2_fold\n" ) ;
|
|
unless( $dry ) { $imap2->subscribe( $h2_fold ) } ;
|
|
}
|
|
|
|
next FOLDER if ( $justfolders ) ;
|
|
|
|
last FOLDER if $imap1->IsUnconnected( ) ;
|
|
last FOLDER if $imap2->IsUnconnected( ) ;
|
|
|
|
my $h1_msgs_all_hash_ref = { } ;
|
|
my @h1_msgs = select_msgs( $imap1, $h1_msgs_all_hash_ref, $search1, $h1_fold );
|
|
last FOLDER if $imap1->IsUnconnected( ) ;
|
|
|
|
my $h1_msgs_nb = scalar @h1_msgs ;
|
|
$h1{ $h1_fold }{ 'messages_nb' } = $h1_msgs_nb ;
|
|
|
|
myprint( "Host1 folder [$h1_fold] considering $h1_msgs_nb messages\n" ) ;
|
|
( $debug or $debuglist ) and myprint( "Host1 folder [$h1_fold] considering $h1_msgs_nb messages, LIST gives: @h1_msgs\n" ) ;
|
|
$debug and myprint( "Host1 selecting messages of folder [$h1_fold] took ", timenext(), " s\n" ) ;
|
|
|
|
my $h2_msgs_all_hash_ref = { } ;
|
|
my @h2_msgs = select_msgs( $imap2, $h2_msgs_all_hash_ref, $search2, $h2_fold ) ;
|
|
last FOLDER if $imap2->IsUnconnected( ) ;
|
|
|
|
my $h2_msgs_nb = scalar @h2_msgs ;
|
|
$h2{ $h2_fold }{ 'messages_nb' } = $h2_msgs_nb ;
|
|
|
|
myprint( "Host2 folder [$h2_fold] considering $h2_msgs_nb messages\n" ) ;
|
|
( $debug or $debuglist ) and myprint( "Host2 folder [$h2_fold] considering $h2_msgs_nb messages, LIST gives: @h2_msgs\n" ) ;
|
|
$debug and myprint( "Host2 selecting messages of folder [$h2_fold] took ", timenext(), " s\n" ) ;
|
|
|
|
my $cache_base = "$tmpdir/imapsync_cache/" ;
|
|
my $cache_dir = cache_folder( $cache_base, "$host1/$user1/$host2/$user2", $h1_fold, $h2_fold ) ;
|
|
my ( $cache_1_2_ref, $cache_2_1_ref ) = ( {}, {} ) ;
|
|
|
|
my $h1_uidvalidity = $imap1->uidvalidity( ) || q{} ;
|
|
my $h2_uidvalidity = $imap2->uidvalidity( ) || q{} ;
|
|
|
|
last FOLDER if $imap1->IsUnconnected( ) ;
|
|
last FOLDER if $imap2->IsUnconnected( ) ;
|
|
|
|
if ( $usecache ) {
|
|
myprint( "cache directory: $cache_dir\n" ) ;
|
|
mkpath( "$cache_dir" ) ;
|
|
( $cache_1_2_ref, $cache_2_1_ref )
|
|
= get_cache( $cache_dir, \@h1_msgs, \@h2_msgs, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ;
|
|
myprint( 'CACHE h1 h2: ', scalar keys %{ $cache_1_2_ref } , " files\n" ) ;
|
|
$debug and myprint( '[',
|
|
map ( { "$_->$cache_1_2_ref->{$_} " } keys %{ $cache_1_2_ref } ), " ]\n" ) ;
|
|
}
|
|
|
|
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 = 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 = keys %h1_msgs_not_in_cache ;
|
|
#myprint( "h1_msgs_not_in_cache: [@h1_msgs_not_in_cache]\n" ) ;
|
|
my @h2_msgs_not_in_cache = keys %h2_msgs_not_in_cache ;
|
|
|
|
my @h2_msgs_delete2_not_in_cache = () ;
|
|
%h1_msgs_copy_by_uid = ( ) ;
|
|
|
|
if ( $useuid ) {
|
|
# use uid so we have to avoid getting header
|
|
@h1_msgs_copy_by_uid{ @h1_msgs_not_in_cache } = ( ) ;
|
|
@h2_msgs_delete2_not_in_cache = @h2_msgs_not_in_cache if $usecache ;
|
|
@h1_msgs_not_in_cache = ( ) ;
|
|
@h2_msgs_not_in_cache = ( ) ;
|
|
|
|
#myprint( "delete2: @h2_msgs_delete2_not_in_cache\n" ) ;
|
|
}
|
|
|
|
$debug and myprint( "Host1 parsing headers of folder [$h1_fold]\n" ) ;
|
|
|
|
my ($h1_heads_ref, $h1_fir_ref) = ({}, {});
|
|
$h1_heads_ref = $imap1->parse_headers([@h1_msgs_not_in_cache], @useheader) if (@h1_msgs_not_in_cache);
|
|
$debug and myprint( "Host1 parsing headers of folder [$h1_fold] took ", timenext(), " s\n" ) ;
|
|
|
|
@{ $h1_fir_ref }{@h1_msgs} = ( undef ) ;
|
|
|
|
$debug and myprint( "Host1 getting flags idate and sizes of folder [$h1_fold]\n" ) ;
|
|
if ( $abletosearch ) {
|
|
$h1_fir_ref = $imap1->fetch_hash( \@h1_msgs, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h1_fir_ref )
|
|
if ( @h1_msgs ) ;
|
|
}else{
|
|
my $uidnext = $imap1->uidnext( $h1_fold ) || $uidnext_default ;
|
|
my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
|
|
$h1_fir_ref = $imap1->fetch_hash( $fetch_hash_uids, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h1_fir_ref )
|
|
if ( @h1_msgs ) ;
|
|
}
|
|
$debug and myprint( "Host1 getting flags idate and sizes of folder [$h1_fold] took ", timenext(), " s\n" ) ;
|
|
unless ($h1_fir_ref) {
|
|
my $error = join( q{}, "Host1 folder $h1_fold: Could not fetch_hash ",
|
|
scalar @h1_msgs, ' msgs: ', $imap1->LastError || q{}, "\n" ) ;
|
|
errors_incr( $sync, $error ) ;
|
|
next FOLDER ;
|
|
}
|
|
|
|
my @h1_msgs_duplicate;
|
|
foreach my $m (@h1_msgs_not_in_cache) {
|
|
my $rc = parse_header_msg($imap1, $m, $h1_heads_ref, $h1_fir_ref, 'Host1', \%h1_hash);
|
|
if (! defined $rc) {
|
|
my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0;
|
|
myprint( "Host1 $h1_fold/$m size $h1_size ignored (no wanted headers so we ignore this message. To solve this: use --addheader)\n" ) ;
|
|
$total_bytes_skipped += $h1_size;
|
|
$nb_msg_skipped += 1;
|
|
$h1_nb_msg_noheader +=1;
|
|
$h1_nb_msg_processed +=1 ;
|
|
} elsif(0 == $rc) {
|
|
# duplicate
|
|
push @h1_msgs_duplicate, $m;
|
|
# duplicate, same id same size?
|
|
my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0;
|
|
$nb_msg_skipped += 1;
|
|
$h1_total_bytes_duplicate += $h1_size;
|
|
$h1_nb_msg_duplicate += 1;
|
|
$h1_nb_msg_processed +=1 ;
|
|
}
|
|
}
|
|
my $h1_msgs_duplicate_nb = scalar @h1_msgs_duplicate ;
|
|
$h1{ $h1_fold }{ 'duplicates_nb' } = $h1_msgs_duplicate_nb ;
|
|
|
|
$debug and myprint( "Host1 selected: $h1_msgs_nb duplicates: $h1_msgs_duplicate_nb\n" ) ;
|
|
$debug and myprint( 'Host1 whole time parsing headers took ', timenext(), " s\n" ) ;
|
|
|
|
$debug and myprint( "Host2 parsing headers of folder [$h2_fold]\n" ) ;
|
|
|
|
my ($h2_heads_ref, $h2_fir_ref) = ( {}, {} );
|
|
$h2_heads_ref = $imap2->parse_headers([@h2_msgs_not_in_cache], @useheader) if (@h2_msgs_not_in_cache);
|
|
$debug and myprint( "Host2 parsing headers of folder [$h2_fold] took ", timenext(), " s\n" ) ;
|
|
|
|
$debug and myprint( "Host2 getting flags idate and sizes of folder [$h2_fold]\n" ) ;
|
|
@{ $h2_fir_ref }{@h2_msgs} = ( ); # fetch_hash can select by uid with last arg as ref
|
|
|
|
|
|
if ( $abletosearch ) {
|
|
$h2_fir_ref = $imap2->fetch_hash( \@h2_msgs, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h2_fir_ref)
|
|
if (@h2_msgs) ;
|
|
}else{
|
|
my $uidnext = $imap2->uidnext( $h2_fold ) || $uidnext_default ;
|
|
my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
|
|
$h2_fir_ref = $imap2->fetch_hash( $fetch_hash_uids, 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE', $h2_fir_ref )
|
|
if ( @h2_msgs ) ;
|
|
}
|
|
|
|
$debug and myprint( "Host2 getting flags idate and sizes of folder [$h2_fold] took ", timenext(), " s\n" ) ;
|
|
|
|
my @h2_msgs_duplicate;
|
|
foreach my $m (@h2_msgs_not_in_cache) {
|
|
my $rc = parse_header_msg($imap2, $m, $h2_heads_ref, $h2_fir_ref, 'Host2', \%h2_hash) ;
|
|
my $h2_size = $h2_fir_ref->{$m}->{'RFC822.SIZE'} || 0 ;
|
|
if (! defined $rc ) {
|
|
myprint( "Host2 $h2_fold/$m size $h2_size ignored (no wanted headers so we ignore this message)\n" ) ;
|
|
$h2_nb_msg_noheader += 1 ;
|
|
} elsif( 0 == $rc ) {
|
|
# duplicate
|
|
$h2_nb_msg_duplicate += 1 ;
|
|
$h2_total_bytes_duplicate += $h2_size ;
|
|
push @h2_msgs_duplicate, $m ;
|
|
}
|
|
}
|
|
|
|
# %h2_folders_of_md5
|
|
foreach my $md5 ( keys %h2_hash ) {
|
|
$h2_folders_of_md5{ $md5 }->{ $h2_fold } ++ ;
|
|
}
|
|
|
|
|
|
my $h2_msgs_duplicate_nb = scalar @h2_msgs_duplicate ;
|
|
$h2{ $h2_fold }{ 'duplicates_nb' } = $h2_msgs_duplicate_nb ;
|
|
|
|
myprint( "Host2 folder $h2_fold selected: $h2_msgs_nb messages, duplicates: $h2_msgs_duplicate_nb\n" )
|
|
if ( $debug or $delete2duplicates or $h2_msgs_duplicate_nb ) ;
|
|
$debug and myprint( 'Host2 whole time parsing headers took ', timenext( ), " s\n" ) ;
|
|
|
|
$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;
|
|
|
|
|
|
if( $delete2duplicates and not exists $h2_folders_from_1_several{ $h2_fold } ) {
|
|
my @h2_expunge ;
|
|
|
|
foreach my $h2_msg ( @h2_msgs_duplicate ) {
|
|
myprint( "msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2 $dry_message\n" ) ;
|
|
push @h2_expunge, $h2_msg if $uidexpunge2 ;
|
|
unless ( $dry ) {
|
|
$imap2->delete_message( $h2_msg ) ;
|
|
$h2_nb_msg_deleted += 1 ;
|
|
}
|
|
}
|
|
my $cnt = scalar @h2_expunge ;
|
|
if( @h2_expunge and not $expunge2 ) {
|
|
myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $dry_message\n" ) ;
|
|
$imap2->uidexpunge( \@h2_expunge ) if ! $dry ;
|
|
}
|
|
if ( $expunge2 ){
|
|
myprint( "Host2: Expunging folder $h2_fold $dry_message\n" ) ;
|
|
$imap2->expunge( ) if ! $dry ;
|
|
}
|
|
}
|
|
|
|
if( $delete2 and not exists $h2_folders_from_1_several{ $h2_fold } ) {
|
|
# No host1 folders f1a f1b ... going all to same f2 (via --regextrans2)
|
|
my @h2_expunge;
|
|
foreach my $m_id (@h2_hash_keys_sorted_by_uid) {
|
|
#myprint( "$m_id " ) ;
|
|
unless (exists $h1_hash{$m_id}) {
|
|
my $h2_msg = $h2_hash{$m_id}{'m'};
|
|
my $h2_flags = $h2_hash{$m_id}{'F'} || q{};
|
|
my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0;
|
|
myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted on host2 [$m_id] $dry_message\n" )
|
|
if ! $isdel;
|
|
push @h2_expunge, $h2_msg if $uidexpunge2;
|
|
unless ($dry or $isdel) {
|
|
$imap2->delete_message($h2_msg);
|
|
$h2_nb_msg_deleted += 1;
|
|
}
|
|
}
|
|
}
|
|
foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) {
|
|
myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2 $dry_message\n" ) ;
|
|
push @h2_expunge, $h2_msg if $uidexpunge2;
|
|
unless ($dry) {
|
|
$imap2->delete_message($h2_msg);
|
|
$h2_nb_msg_deleted += 1;
|
|
}
|
|
}
|
|
my $cnt = scalar @h2_expunge ;
|
|
|
|
if( @h2_expunge and not $expunge2 ) {
|
|
myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $dry_message\n" ) ;
|
|
$imap2->uidexpunge( \@h2_expunge ) if ! $dry ;
|
|
}
|
|
if ( $expunge2 ) {
|
|
myprint( "Host2: Expunging folder $h2_fold $dry_message\n" ) ;
|
|
$imap2->expunge( ) if ! $dry ;
|
|
}
|
|
}
|
|
|
|
if( $delete2 and exists $h2_folders_from_1_several{ $h2_fold } ) {
|
|
myprint( "Host2 folder $h2_fold $h2_folders_from_1_several{ $h2_fold } folders left to sync there\n" ) ;
|
|
my @h2_expunge;
|
|
foreach my $m_id ( @h2_hash_keys_sorted_by_uid ) {
|
|
my $h2_msg = $h2_hash{ $m_id }{ 'm' } ;
|
|
unless ( exists $h1_hash{ $m_id } ) {
|
|
my $h2_flags = $h2_hash{ $m_id }{ 'F' } || q{} ;
|
|
my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0 ;
|
|
unless ( $isdel ) {
|
|
$debug and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [$m_id]\n" ) ;
|
|
$uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ;
|
|
}
|
|
}else{
|
|
$debug and myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [$m_id]\n" ) ;
|
|
$uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
|
|
}
|
|
}
|
|
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 } } ) {
|
|
$debug and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion\n" ) ;
|
|
if ( exists $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg } ) {
|
|
$debug and myprint( "Host2: msg $h2_fold/$h2_msg canceled deletion\n" ) ;
|
|
}else{
|
|
myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted $dry_message\n" ) ;
|
|
push @h2_expunge, $h2_msg if $uidexpunge2 ;
|
|
unless ( $dry ) {
|
|
$imap2->delete_message( $h2_msg ) ;
|
|
$h2_nb_msg_deleted += 1 ;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
my $cnt = scalar @h2_expunge ;
|
|
if( @h2_expunge and not $expunge2 ) {
|
|
myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $dry_message\n" ) ;
|
|
$imap2->uidexpunge( \@h2_expunge ) if ! $dry ;
|
|
}
|
|
if ( $expunge2 ) {
|
|
myprint( "Host2: Expunging host2 folder $h2_fold $dry_message\n" ) ;
|
|
$imap2->expunge( ) if ! $dry ;
|
|
}
|
|
|
|
$h2_folders_from_1_several{ $h2_fold }-- ;
|
|
}
|
|
|
|
|
|
my $h2_uidnext = $imap2->uidnext( $h2_fold ) ;
|
|
$debug and myprint( "Host2 uidnext: $h2_uidnext\n" ) ;
|
|
$h2_uidguess = $h2_uidnext ;
|
|
MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) {
|
|
last FOLDER if $imap1->IsUnconnected( ) ;
|
|
last FOLDER if $imap2->IsUnconnected( ) ;
|
|
|
|
#myprint( "h1_nb_msg_processed: $h1_nb_msg_processed\n" ) ;
|
|
my $h1_size = $h1_hash{$m_id}{'s'};
|
|
my $h1_msg = $h1_hash{$m_id}{'m'};
|
|
my $h1_idate = $h1_hash{$m_id}{'D'};
|
|
|
|
if ( ( not exists $h2_hash{ $m_id } )
|
|
and ( not ( exists $h2_folders_of_md5{ $m_id } )
|
|
or not $skipcrossduplicates ) ) {
|
|
# copy
|
|
my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ;
|
|
$h2_folders_of_md5{ $m_id }->{ $h2_fold } ++ ;
|
|
if( $delete2 and ( exists $h2_folders_from_1_several{ $h2_fold } ) and $h2_msg ) {
|
|
myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ;
|
|
$uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
|
|
}
|
|
last FOLDER if total_bytes_max_reached( ) ;
|
|
next MESS;
|
|
}
|
|
else{
|
|
# already on host2
|
|
if ( exists $h2_hash{ $m_id } ) {
|
|
my $h2_msg = $h2_hash{$m_id}{'m'} ;
|
|
$debug and myprint( "Host1 found msg $h1_fold/$h1_msg equals Host2 $h2_fold/$h2_msg\n" ) ;
|
|
if ( $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 $h2_folders_of_md5{ $m_id } ) {
|
|
my @folders_dup = keys %{ $h2_folders_of_md5{ $m_id } } ;
|
|
( $debug or $debugcrossduplicates ) and myprint( "Host1 found msg $h1_fold/$h1_msg is also in Host2 folders @folders_dup\n" ) ;
|
|
}
|
|
$total_bytes_skipped += $h1_size ;
|
|
$nb_msg_skipped += 1 ;
|
|
$h1_nb_msg_processed +=1 ;
|
|
}
|
|
|
|
if ( exists $h2_hash{ $m_id } ) {
|
|
#$debug and myprint( "MESSAGE $m_id\n" ) ;
|
|
my $h2_msg = $h2_hash{$m_id}{'m'};
|
|
|
|
sync_flags_fir( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ;
|
|
# Good
|
|
my $h2_size = $h2_hash{$m_id}{'s'};
|
|
$debug and myprint(
|
|
"Host1 size msg $h1_fold/$h1_msg = $h1_size <> $h2_size = Host2 $h2_fold/$h2_msg\n" ) ;
|
|
}
|
|
last FOLDER if $imap2->IsUnconnected( ) ;
|
|
|
|
if ( $delete ) {
|
|
delete_message_on_host1( $h1_msg, $h1_fold ) ;
|
|
}
|
|
}
|
|
# END MESS: loop
|
|
last FOLDER if $imap1->IsUnconnected( ) ;
|
|
last FOLDER if $imap2->IsUnconnected( ) ;
|
|
MESS_IN_CACHE: foreach my $h1_msg ( @h1_msgs_in_cache ) {
|
|
my $h2_msg = $cache_1_2_ref->{ $h1_msg } ;
|
|
$debugcache and myprint( "cache messages update flags $h1_msg->$h2_msg\n" ) ;
|
|
sync_flags_fir( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ;
|
|
my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } || 0 ;
|
|
$total_bytes_skipped += $h1_size;
|
|
$nb_msg_skipped += 1;
|
|
$h1_nb_msg_processed +=1 ;
|
|
last FOLDER if $imap2->IsUnconnected( ) ;
|
|
}
|
|
|
|
#myprint( "Messages by uid: ", map { "$_ " } keys %h1_msgs_copy_by_uid, "\n" ) ;
|
|
MESS_BY_UID: foreach my $h1_msg ( sort { $a <=> $b } keys %h1_msgs_copy_by_uid ) {
|
|
#
|
|
$debug and myprint( "Copy by uid $h1_fold/$h1_msg\n" ) ;
|
|
last FOLDER if $imap1->IsUnconnected( ) ;
|
|
last FOLDER if $imap2->IsUnconnected( ) ;
|
|
my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ;
|
|
if( $delete2 and exists $h2_folders_from_1_several{ $h2_fold } and $h2_msg ) {
|
|
myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ;
|
|
$uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
|
|
}
|
|
last FOLDER if total_bytes_max_reached( ) ;
|
|
}
|
|
|
|
if ( $expunge or $expunge1 ){
|
|
myprint( "Host1: Expunging folder $h1_fold $dry_message\n" ) ;
|
|
unless( $dry ) { $imap1->expunge( ) } ;
|
|
}
|
|
if ( $expunge2 ){
|
|
myprint( "Host2: Expunging folder $h2_fold $dry_message\n" ) ;
|
|
unless( $dry ) { $imap2->expunge( ) } ;
|
|
}
|
|
$debug and myprint( 'Time: ', timenext( ), " s\n" ) ;
|
|
}
|
|
|
|
|
|
sub total_bytes_max_reached {
|
|
|
|
return( 0 ) if not $exitwhenover ;
|
|
if ( $total_bytes_transferred >= $exitwhenover ) {
|
|
myprint( "Maximum bytes transferred reached, $total_bytes_transferred >= $exitwhenover, ending sync\n" ) ;
|
|
return( 1 ) ;
|
|
}
|
|
|
|
}
|
|
|
|
myprint( "++++ End looping on each folder\n" ) ;
|
|
( $debug or $sync->{debugfolders} ) and myprint( 'Time: ', timenext( ), " s\n" ) ;
|
|
|
|
|
|
if ( $foldersizesatend ) {
|
|
myprint( << 'END_SIZE' ) ;
|
|
|
|
Folders sizes after the synchronization.
|
|
You can remove this foldersizes listing by using "--nofoldersizesatend"
|
|
END_SIZE
|
|
|
|
foldersizesatend( ) ;
|
|
}
|
|
|
|
$imap1->logout( ) unless lost_connection( $imap1, "for host1 [$host1]" ) ;
|
|
$imap2->logout( ) unless lost_connection( $imap2, "for host2 [$host2]" ) ;
|
|
|
|
stats( $sync ) ;
|
|
myprint( errorsdump( $sync->{nb_errors}, errors_log( $sync ) ) ) if ( $sync->{errorsdump} ) ;
|
|
tests_live_result( $sync->{nb_errors} ) if ( $testslive ) ;
|
|
exit_clean( $sync, $EXIT_WITH_ERRORS ) if ( $sync->{nb_errors} ) ;
|
|
exit_clean( $sync, $EX_OK ) ;
|
|
|
|
# END of main program
|
|
|
|
|
|
# subroutines
|
|
sub myprint { return print @ARG ; }
|
|
sub myprintf { return printf @ARG ; }
|
|
|
|
sub mysprintf {
|
|
my( $format, @list ) = @ARG ;
|
|
return sprintf $format, @list ;
|
|
}
|
|
|
|
sub unsetunsafe {
|
|
# Remove all content in unsafe evalued options
|
|
@regextrans2 = ( ) ;
|
|
@regexflag = ( ) ;
|
|
@regexmess = ( ) ;
|
|
@skipmess = ( ) ;
|
|
@pipemess = ( ) ;
|
|
$delete2foldersonly = undef ;
|
|
$delete2foldersbutnot = undef ;
|
|
return ;
|
|
}
|
|
|
|
sub debugsleep {
|
|
my $mysync = shift ;
|
|
if ( defined $mysync->{debugsleep} ) {
|
|
myprint( "Info: sleeping $mysync->{debugsleep}s\n" ) ;
|
|
sleep $mysync->{debugsleep} ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub foldersizes_on_h1h2 {
|
|
myprint( << 'END_SIZE' ) ;
|
|
|
|
Folders sizes before the synchronization.
|
|
You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend"
|
|
but then you will also loose the ETA (Estimation Time of Arrival) given after each message copy.
|
|
END_SIZE
|
|
|
|
( $h1_nb_msg_start, $h1_bytes_start ) = foldersizes( 'Host1', $imap1, $search1, @h1_folders_wanted ) ;
|
|
( $h2_nb_msg_start, $h2_bytes_start ) = foldersizes( 'Host2', $imap2, $search2, @h2_folders_from_1_wanted ) ;
|
|
|
|
if ( not all_defined( $h1_nb_msg_start, $h1_bytes_start, $h2_nb_msg_start, $h2_bytes_start ) ) {
|
|
my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
$foldersizes = 0 ;
|
|
$foldersizesatend = 0 ;
|
|
return ;
|
|
}
|
|
|
|
my $h2_bytes_limit = $sync->{host2}->{quota_limit_bytes} || 0 ;
|
|
if ( $h2_bytes_limit and ( $h2_bytes_limit < $h1_bytes_start ) ) {
|
|
my $quota_percent = mysprintf( '%.0f', $h1_bytes_start/$h2_bytes_limit ) ;
|
|
my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $h1_bytes_start bytes / $h2_bytes_limit bytes )\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub all_defined {
|
|
if ( not @ARG ) {
|
|
return 0 ;
|
|
}
|
|
foreach my $elem ( @ARG ) {
|
|
if ( not defined $elem ) {
|
|
return 0 ;
|
|
}
|
|
}
|
|
return 1 ;
|
|
}
|
|
|
|
sub tests_all_defined {
|
|
is( 0, all_defined( ), 'all_defined: no param => 0' ) ;
|
|
is( 0, all_defined( () ), 'all_defined: void list => 0' ) ;
|
|
is( 0, all_defined( undef ), 'all_defined: undef => 0' ) ;
|
|
is( 0, all_defined( undef, undef ), 'all_defined: undef => 0' ) ;
|
|
is( 0, all_defined( 1, undef ), 'all_defined: 1 undef => 0' ) ;
|
|
is( 0, all_defined( undef, 1 ), 'all_defined: undef 1 => 0' ) ;
|
|
is( 1, all_defined( 1, 1 ), 'all_defined: 1 1 => 1' ) ;
|
|
is( 1, all_defined( (1, 1) ), 'all_defined: (1 1) => 1' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub imap_id_stuff {
|
|
my $sync = shift ;
|
|
|
|
if ( not $sync->{id} ) { return ; } ;
|
|
|
|
$sync->{h1_imap_id} = imap_id( $sync->{imap1}, 'Host1' ) ;
|
|
#myprint( 'Host1: ' . $sync->{h1_imap_id} ) ;
|
|
$sync->{h2_imap_id} = imap_id( $sync->{imap2}, 'Host2' ) ;
|
|
#myprint( 'Host2: ' . $sync->{h2_imap_id} ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub imap_id {
|
|
my ( $imap, $Side ) = @_ ;
|
|
|
|
$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( { side => lc $Side } ) ;
|
|
myprint( "\n$Side: found ID capability. Sending/receiving ID, presented in raw IMAP for now.\n"
|
|
. "In order to avoid sending/receiving ID, use option --noid\n" ) ;
|
|
my $debug_before = $imap->Debug( ) ;
|
|
$imap->Debug( 1 ) ;
|
|
my $id_out = $imap->tag_and_run( 'ID ' . $id_inp ) ;
|
|
#my $id_out = $imap->tag_and_run( 'ID NIL' ) ;
|
|
myprint( "\n" ) ;
|
|
$imap->Debug( $debug_before ) ;
|
|
#$imap_id_response = Data::Dumper->Dump( [ $id_out ], [ 'IMAP_ID' ] ) ;
|
|
}
|
|
return( $imap_id_response ) ;
|
|
}
|
|
|
|
sub imapsync_id {
|
|
my $overhashref = shift ;
|
|
# See http://tools.ietf.org/html/rfc2971.html
|
|
|
|
my $imapsync_id = { } ;
|
|
|
|
my $imapsync_id_lamiral = {
|
|
name => 'imapsync',
|
|
version => imapsync_version( ),
|
|
os => $OSNAME,
|
|
vendor => 'Gilles LAMIRAL',
|
|
'support-url' => 'http://imapsync.lamiral.info/',
|
|
# Example of date-time: 19-Sep-2015 08:56:07
|
|
date => date_from_rcs( q{$Date: 2016/08/19 10:30:36 $ } ),
|
|
} ;
|
|
|
|
my $imapsync_id_github = {
|
|
name => 'imapsync',
|
|
version => imapsync_version( ),
|
|
os => $OSNAME,
|
|
vendor => 'github',
|
|
'support-url' => 'https://github.com/imapsync/imapsync',
|
|
date => date_from_rcs( q{$Date: 2016/08/19 10:30:36 $ } ),
|
|
} ;
|
|
|
|
$imapsync_id = $imapsync_id_lamiral ;
|
|
#$imapsync_id = $imapsync_id_github ;
|
|
my %mix = ( %{ $imapsync_id }, %{ $overhashref } ) ;
|
|
my $imapsync_id_str = format_for_imap_arg( \%mix ) ;
|
|
#myprint( "$imapsync_id_str\n" ) ;
|
|
return( $imapsync_id_str ) ;
|
|
}
|
|
|
|
sub tests_imapsync_id {
|
|
ok( '("name" "imapsync" "version" "111" "os" "beurk" "vendor" "Gilles LAMIRAL" "support-url" "http://imapsync.lamiral.info/" "date" "22-12-1968" "side" "host1")'
|
|
eq imapsync_id( {
|
|
version => 111,
|
|
os => 'beurk',
|
|
date => '22-12-1968',
|
|
side => 'host1' } ),
|
|
'tests_imapsync_id override' ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub format_for_imap_arg {
|
|
my $ref = shift ;
|
|
|
|
my $string = q{} ;
|
|
my %terms = %{ $ref } ;
|
|
my @terms = ( ) ;
|
|
if ( not ( %terms ) ) { return( 'NIL' ) } ;
|
|
# sort like in RFC then add extra key/values
|
|
foreach my $key ( qw( name version os os-version vendor support-url address date command arguments environment) ) {
|
|
if ( $terms{ $key } ) {
|
|
push @terms, $key, $terms{ $key } ;
|
|
delete $terms{ $key } ;
|
|
}
|
|
}
|
|
push @terms, %terms ;
|
|
$string = '(' . ( join q{ }, map { '"' . $_ . '"' } @terms ) . ')' ;
|
|
return( $string ) ;
|
|
}
|
|
|
|
|
|
|
|
sub tests_format_for_imap_arg {
|
|
ok( 'NIL' eq format_for_imap_arg( { } ), 'format_for_imap_arg empty hash ref' ) ;
|
|
ok( '("name" "toto")' eq format_for_imap_arg( { name => 'toto' } ), 'format_for_imap_arg { name => toto }' ) ;
|
|
ok( '("name" "toto" "key" "val")' eq format_for_imap_arg( { name => 'toto', key => 'val' } ), 'format_for_imap_arg 2 x key val' ) ;
|
|
return ;
|
|
}
|
|
|
|
sub quota {
|
|
my ( $imap, $side, $sync ) = @_ ;
|
|
|
|
my $Side = ucfirst $side ;
|
|
my $debug_before = $imap->Debug( ) ;
|
|
$imap->Debug( 1 ) ;
|
|
if ( not $imap->has_capability( 'QUOTA' ) ) {
|
|
$imap->Debug( $debug_before ) ;
|
|
return ;
|
|
} ;
|
|
myprint( "\n$Side: found quota, presented in raw IMAP\n" ) ;
|
|
my $getquotaroot = $imap->getquotaroot( 'INBOX' ) ;
|
|
# Gmail INBOX quotaroot is "" but with it Mail::IMAPClient does a literal GETQUOTA {2} \n ""
|
|
#$imap->quota( 'ROOT' ) ;
|
|
#$imap->quota( '""' ) ;
|
|
myprint( "\n" ) ;
|
|
$imap->Debug( $debug_before ) ;
|
|
my $quota_limit_bytes = quota_extract_storage_limit_in_bytes( $getquotaroot ) ;
|
|
my $quota_current_bytes = quota_extract_storage_current_in_bytes( $getquotaroot ) ;
|
|
$sync->{$side}->{quota_limit_bytes} = $quota_limit_bytes ;
|
|
$sync->{$side}->{quota_current_bytes} = $quota_current_bytes ;
|
|
my $quota_percent ;
|
|
if ( $quota_limit_bytes > 0 ) {
|
|
$quota_percent = mysprintf( '%.2f', $NUMBER_100 * $quota_current_bytes / $quota_limit_bytes ) ;
|
|
}else{
|
|
$quota_percent = 0 ;
|
|
}
|
|
myprint( "$Side: Quota current storage is $quota_current_bytes bytes. Limit is $quota_limit_bytes bytes. So $quota_percent % full\n" ) ;
|
|
if ( $QUOTA_PERCENT_LIMIT < $quota_percent ) {
|
|
my $error = "$Side: $quota_percent % full: it is time to find a bigger place! ( $quota_current_bytes bytes / $quota_limit_bytes bytes )\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub tests_quota_extract_storage_limit_in_bytes {
|
|
my $imap_output = [
|
|
'* QUOTAROOT "INBOX" "Storage quota" "Messages quota"',
|
|
'* QUOTA "Storage quota" (STORAGE 1 104857600)',
|
|
'* QUOTA "Messages quota" (MESSAGE 2 100000)',
|
|
'5 OK Getquotaroot completed.'
|
|
] ;
|
|
ok( $NUMBER_104857600 * $KIBI == quota_extract_storage_limit_in_bytes( $imap_output ), 'quota_extract_storage_limit_in_bytes ') ;
|
|
return ;
|
|
}
|
|
|
|
sub quota_extract_storage_limit_in_bytes {
|
|
my $imap_output = shift ;
|
|
|
|
my $limit_kb ;
|
|
$limit_kb = ( map { /.*\(\s*STORAGE\s+\d+\s+(\d+)\s*\)/ ? $1 : () } @{ $imap_output } )[0] ;
|
|
$limit_kb ||= 0 ;
|
|
$debug and myprint( "storage_limit_kb = $limit_kb\n" ) ;
|
|
return( $KIBI * $limit_kb ) ;
|
|
}
|
|
|
|
|
|
sub tests_quota_extract_storage_current_in_bytes {
|
|
my $imap_output = [
|
|
'* QUOTAROOT "INBOX" "Storage quota" "Messages quota"',
|
|
'* QUOTA "Storage quota" (STORAGE 1 104857600)',
|
|
'* QUOTA "Messages quota" (MESSAGE 2 100000)',
|
|
'5 OK Getquotaroot completed.'
|
|
] ;
|
|
ok( 1*$KIBI == quota_extract_storage_current_in_bytes( $imap_output ), 'quota_extract_storage_current_in_bytes: 1 => 1024 ') ;
|
|
return ;
|
|
}
|
|
|
|
sub quota_extract_storage_current_in_bytes {
|
|
my $imap_output = shift ;
|
|
|
|
my $current_kb ;
|
|
$current_kb = ( map { /.*\(\s*STORAGE\s+(\d+)\s+\d+\s*\)/ ? $1 : () } @{ $imap_output } )[0] ;
|
|
$current_kb ||= 0 ;
|
|
$debug and myprint( "storage_current_kb = $current_kb\n" ) ;
|
|
return( $KIBI * $current_kb ) ;
|
|
|
|
}
|
|
|
|
|
|
sub automap {
|
|
my ( $sync ) = @_ ;
|
|
|
|
if ( $sync->{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 ;
|
|
}
|
|
|
|
$sync->{h1_special} = special_from_folders_hash( $sync->{imap1}, 'Host1' ) ;
|
|
$sync->{h2_special} = special_from_folders_hash( $sync->{imap2}, 'Host2' ) ;
|
|
|
|
build_possible_special( $sync ) ;
|
|
build_guess_special( $sync ) ;
|
|
build_automap( $sync ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
|
|
sub build_guess_special {
|
|
my ( $sync ) = shift ;
|
|
|
|
foreach my $h1_fold ( sort keys %{ $sync->{h1_folders_all} } ) {
|
|
my $special = guess_special( $h1_fold, $sync->{possible_special}, $sync->{h1_prefix} ) ;
|
|
if ( $special ) {
|
|
$sync->{h1_special_guessed}{$h1_fold} = $special ;
|
|
my $already_guessed = $sync->{h1_special_guessed}{$special} ;
|
|
if ( $already_guessed ) {
|
|
myprint( "Host1: $h1_fold not $special because set to $already_guessed\n" ) ;
|
|
}else{
|
|
$sync->{h1_special_guessed}{$special} = $h1_fold ;
|
|
}
|
|
}
|
|
}
|
|
foreach my $h2_fold ( sort keys %{ $sync->{h2_folders_all} } ) {
|
|
my $special = guess_special( $h2_fold, $sync->{possible_special}, $sync->{h2_prefix} ) ;
|
|
if ( $special ) {
|
|
$sync->{h2_special_guessed}{$h2_fold} = $special ;
|
|
my $already_guessed = $sync->{h2_special_guessed}{$special} ;
|
|
if ( $already_guessed ) {
|
|
myprint( "Host2: $h2_fold not $special because set to $already_guessed\n" ) ;
|
|
}else{
|
|
$sync->{h2_special_guessed}{$special} = $h2_fold ;
|
|
}
|
|
}
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub guess_special {
|
|
my( $folder, $possible_special_ref, $prefix ) = @_ ;
|
|
|
|
my $folder_no_prefix = $folder ;
|
|
$folder_no_prefix =~ s/${prefix}// ;
|
|
#$debug and myprint( "folder_no_prefix: $folder_no_prefix\n" ) ;
|
|
|
|
my $guess_special = $possible_special_ref->{ $folder }
|
|
|| $possible_special_ref->{ $folder_no_prefix }
|
|
|| q{} ;
|
|
|
|
return( $guess_special ) ;
|
|
}
|
|
|
|
sub tests_guess_special {
|
|
my $possible_special_ref = build_possible_special( my $sync ) ;
|
|
ok( '\Sent' eq guess_special( 'Sent', $possible_special_ref, q{} ) ,'guess_special: Sent => \Sent' ) ;
|
|
ok( q{} eq guess_special( 'Blabla', $possible_special_ref, q{} ) ,'guess_special: Blabla => q{}' ) ;
|
|
ok( '\Sent' eq guess_special( 'INBOX.Sent', $possible_special_ref, 'INBOX.' ) ,'guess_special: INBOX.Sent => \Sent' ) ;
|
|
return ;
|
|
}
|
|
|
|
sub build_automap {
|
|
my ( $sync ) = @_ ;
|
|
|
|
foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) {
|
|
my $h2_fold ;
|
|
my $h1_special = $sync->{h1_special}{$h1_fold} ;
|
|
my $h1_special_guessed = $sync->{h1_special_guessed}{$h1_fold} ;
|
|
|
|
# Case 1: special on both sides.
|
|
if ( $h1_special
|
|
and exists $sync->{h2_special}{$h1_special} ) {
|
|
$h2_fold = $sync->{h2_special}{$h1_special} ;
|
|
$sync->{f1f2auto}{ $h1_fold } = $h2_fold ;
|
|
next ;
|
|
}
|
|
# Case 2: special on host1, not on host2
|
|
if ( $h1_special
|
|
and ( not exists $sync->{h2_special}{$h1_special} )
|
|
and ( exists $sync->{h2_special_guessed}{$h1_special} )
|
|
) {
|
|
# special_guessed on host2
|
|
$h2_fold = $sync->{h2_special_guessed}{$h1_special} ;
|
|
$sync->{f1f2auto}{ $h1_fold } = $h2_fold ;
|
|
next ;
|
|
}
|
|
# Case 3: no special on host1, special on host2
|
|
if ( ( not $h1_special )
|
|
and ( $h1_special_guessed )
|
|
and ( exists $sync->{h2_special}{$h1_special_guessed} )
|
|
) {
|
|
$h2_fold = $sync->{h2_special}{$h1_special_guessed} ;
|
|
$sync->{f1f2auto}{ $h1_fold } = $h2_fold ;
|
|
next ;
|
|
}
|
|
# Case 4: no special on both sides.
|
|
if ( ( not $h1_special )
|
|
and ( $h1_special_guessed )
|
|
and ( not exists $sync->{h2_special}{$h1_special_guessed} )
|
|
and ( exists $sync->{h2_special_guessed}{$h1_special_guessed} )
|
|
) {
|
|
$h2_fold = $sync->{h2_special_guessed}{$h1_special_guessed} ;
|
|
$sync->{f1f2auto}{ $h1_fold } = $h2_fold ;
|
|
next ;
|
|
}
|
|
}
|
|
return( $sync->{f1f2auto} ) ;
|
|
}
|
|
|
|
# I willll probably add what there is at:
|
|
# http://stackoverflow.com/questions/2185391/localized-gmail-imap-folders/2185548#2185548
|
|
sub build_possible_special {
|
|
my $sync = shift ;
|
|
my $possible_special = { } ;
|
|
# All|Archive|Drafts|Flagged|Junk|Sent|Trash
|
|
|
|
$possible_special->{'\All'} = [ 'All', 'All Messages', '&BBIEQQQ1-' ] ;
|
|
$possible_special->{'\Archive'} = [ 'Archive', 'Archives', '&BBAEQARFBDgEMg-' ] ;
|
|
$possible_special->{'\Drafts'} = [ 'Drafts', '&BCcENQRABD0EPgQyBDgEOgQ4-' ] ;
|
|
$possible_special->{'\Flagged'} = [ 'Flagged', 'Starred', '&BB8EPgQ8BDUERwQ1BD0EPQRLBDU-' ] ;
|
|
$possible_special->{'\Junk'} = [ 'Junk', 'Spam', '&BCEEPwQwBDw-' ] ;
|
|
$possible_special->{'\Sent'} = [ 'Sent', 'Sent Messages', 'Sent Items',
|
|
'Gesendete Elemente', 'Gesendete Objekte',
|
|
'&AMk-l&AOk-ments envoy&AOk-s', 'Envoy&AOk-',
|
|
'Elementos enviados',
|
|
'&kAFP4W4IMH8wojCkMMYw4A-',
|
|
'&BB4EQgQ,BEAEMAQyBDsENQQ9BD0ESwQ1-'] ;
|
|
$possible_special->{'\Trash'} = [ 'Trash', '&BCMENAQwBDsENQQ9BD0ESwQ1-', '&BBoEPgRABDcEOAQ9BDA-' ] ;
|
|
|
|
foreach my $special ( qw( \All \Archive \Drafts \Flagged \Junk \Sent \Trash ) ){
|
|
foreach my $possible_folder ( @{ $possible_special->{$special} } ) {
|
|
$possible_special->{ $possible_folder } = $special ;
|
|
} ;
|
|
}
|
|
$sync->{possible_special} = $possible_special ;
|
|
$debug and myprint( Data::Dumper->Dump( [ $possible_special ], [ 'possible_special' ] ) ) ;
|
|
return( $possible_special ) ;
|
|
}
|
|
|
|
sub special_from_folders_hash {
|
|
my ( $imap, $side ) = @_ ;
|
|
my %special = ( ) ;
|
|
if ( not( Mail::IMAPClient->can( 'folders_hash' ) ) ) {
|
|
my $error = "$side: To have automagic rfc6154 folder mapping, upgrade Mail::IMAPClient >= 3.34\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
return( \%special ) ; # empty hash ref
|
|
}
|
|
my $folders_hash = $imap->folders_hash( ) ;
|
|
foreach my $fhash (@{ $folders_hash } ) {
|
|
my @special = grep { /\\(?:All|Archive|Drafts|Flagged|Junk|Sent|Trash)/ } @{ $fhash->{attrs} } ;
|
|
if ( @special ) {
|
|
my $special = $special[0] ; # keep first one. Could be not very good.
|
|
if ( exists $special{ $special } ) {
|
|
myprintf( "%s: special %-20s = %s already asigned to %s\n",
|
|
$side, $fhash->{name}, join( q{ }, @special ), $special{ $special } ) ;
|
|
}else{
|
|
myprintf( "%s: special %-20s = %s\n",
|
|
$side, $fhash->{name}, join( q{ }, @special ) ) ;
|
|
$special{ $special } = $fhash->{name} ;
|
|
$special{ $fhash->{name} } = $special ; # double entry value => key
|
|
}
|
|
}
|
|
}
|
|
myprint( "\n" ) if ( %special ) ;
|
|
return( \%special ) ;
|
|
}
|
|
|
|
sub errors_incr {
|
|
my ( $mysync, @error ) = @ARG ;
|
|
$sync->{nb_errors}++ ;
|
|
|
|
if ( @error ) {
|
|
errors_log( $mysync, @error ) ;
|
|
myprint( @error ) ;
|
|
}
|
|
|
|
$mysync->{errorsmax} ||= $ERRORS_MAX ;
|
|
if ( $sync->{nb_errors} >= $mysync->{errorsmax} ) {
|
|
myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to 100 with --errorsmax 100 ). Exiting.\n" ) ;
|
|
if ( $mysync->{errorsdump} ) {
|
|
myprint( errorsdump( $sync->{nb_errors}, errors_log( $mysync ) ) ) ;
|
|
# again since errorsdump( ) can be very verbose and masq previous warning
|
|
myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to 100 with --errorsmax 100 ). Exiting.\n" ) ;
|
|
}
|
|
exit_clean( $mysync, $EXIT_WITH_ERRORS_MAX ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub errors_log {
|
|
my ( $mysync, @error ) = @ARG ;
|
|
|
|
if ( ! $mysync->{errors_log} ) {
|
|
$mysync->{errors_log} = [] ;
|
|
}
|
|
|
|
if ( @error ) {
|
|
push @{ $mysync->{errors_log} }, join( q{}, @error ) ;
|
|
}
|
|
if ( @{ $mysync->{errors_log} } ) {
|
|
return @{ $mysync->{errors_log} } ;
|
|
}
|
|
else {
|
|
return ;
|
|
}
|
|
}
|
|
|
|
sub tests_errors_log {
|
|
|
|
|
|
}
|
|
|
|
|
|
sub errorsdump {
|
|
my( $nb_errors, @errors_log ) = @ARG ;
|
|
my $error_num = 0 ;
|
|
my $errors_list = q{} ;
|
|
if ( @errors_log ) {
|
|
$errors_list = "++++ Listing $nb_errors errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n" ;
|
|
foreach my $error ( @errors_log ) {
|
|
$error_num++ ;
|
|
$errors_list .= "Err $error_num/$nb_errors: $error" ;
|
|
}
|
|
}
|
|
return( $errors_list ) ;
|
|
}
|
|
|
|
|
|
sub tests_live_result {
|
|
my $nb_errors = shift ;
|
|
if ( $nb_errors ) {
|
|
myprint( "Live tests failed with $nb_errors errors\n" ) ;
|
|
} else {
|
|
myprint( "Live tests ended successfully\n" ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub foldersizesatend {
|
|
timenext( ) ;
|
|
return if ( $imap1->IsUnconnected( ) ) ;
|
|
return if ( $imap2->IsUnconnected( ) ) ;
|
|
# Get all folders on host2 again since new were created
|
|
@h2_folders_all = sort $imap2->folders();
|
|
for ( @h2_folders_all ) {
|
|
$h2_folders_all{ $_ } = 1 ;
|
|
$h2_folders_all_UPPER{ uc $_ } = 1 ;
|
|
} ;
|
|
( $h1_nb_msg_end, $h1_bytes_end ) = foldersizes( 'Host1', $imap1, $search1, @h1_folders_wanted ) ;
|
|
( $h2_nb_msg_end, $h2_bytes_end ) = foldersizes( 'Host2', $imap2, $search2, @h2_folders_from_1_wanted ) ;
|
|
if ( not all_defined( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) ) {
|
|
my $error = "Failure getting foldersizes, final differences will not be calculated\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub size_filtered_flag {
|
|
my $h1_size = shift ;
|
|
|
|
if (defined $maxsize and $h1_size >= $maxsize) {
|
|
return( 1 ) ;
|
|
}
|
|
if (defined $minsize and $h1_size <= $minsize) {
|
|
return( 1 ) ;
|
|
}
|
|
return( 0 ) ;
|
|
}
|
|
|
|
sub sync_flags_fir {
|
|
my ( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ;
|
|
|
|
if ( not defined $h1_msg ) { return } ;
|
|
if ( not defined $h2_msg ) { return } ;
|
|
|
|
my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} ;
|
|
return if size_filtered_flag( $h1_size ) ;
|
|
|
|
# used cached flag values for efficiency
|
|
my $h1_flags = $h1_fir_ref->{ $h1_msg }->{ 'FLAGS' } || q{} ;
|
|
my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ 'FLAGS' } || q{} ;
|
|
|
|
sync_flags( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub sync_flags_after_copy {
|
|
my( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $permanentflags2 ) = @_ ;
|
|
|
|
my @h2_flags = $imap2->flags( $h2_msg ) ;
|
|
my $h2_flags = "@h2_flags" ;
|
|
( $debug or $debugflags ) and myprint( "Host2 flags before resync by STORE on msg $h2_msg: $h2_flags\n" ) ;
|
|
sync_flags( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ;
|
|
return ;
|
|
}
|
|
|
|
sub sync_flags {
|
|
my( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) = @_ ;
|
|
|
|
( $debug or $debugflags ) and
|
|
myprint( "Host1: flags init msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 $h2_fold/$h2_msg flags( $h2_flags )\n" ) ;
|
|
|
|
$h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ;
|
|
|
|
$h2_flags = flagscase( $h2_flags ) ;
|
|
|
|
( $debug or $debugflags ) and
|
|
myprint( "Host1 flags filt msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 $h2_fold/$h2_msg flags( $h2_flags )\n" ) ;
|
|
|
|
|
|
# compare flags - set flags if there a difference
|
|
my @h1_flags = sort split(q{ }, $h1_flags );
|
|
my @h2_flags = sort split(q{ }, $h2_flags );
|
|
my $diff = compare_lists( \@h1_flags, \@h2_flags );
|
|
|
|
$diff and ( $debug or $debugflags )
|
|
and myprint( "Host2 flags msg $h2_fold/$h2_msg replacing h2 flags( $h2_flags ) with h1 flags( $h1_flags )\n" ) ;
|
|
# This sets flags so flags can be removed with this
|
|
# When you remove a \Seen flag on host1 you want to it
|
|
# to be removed on host2. Just add flags is not what
|
|
# we need most of the time.
|
|
|
|
if ( not $dry and $diff and not $imap2->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) {
|
|
my $error_msg = join q{}, "Host2 flags msg $h2_fold/$h2_msg could not add flags [@h1_flags]: ",
|
|
$imap2->LastError || q{}, "\n" ;
|
|
errors_incr( $sync, $error_msg ) ;
|
|
}
|
|
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub _filter {
|
|
my $str = shift or return q{} ;
|
|
my $sz = $SIZE_MAX_STR ;
|
|
my $len = length $str ;
|
|
if ( not $debug and $len > $sz*2 ) {
|
|
my $beg = substr $str, 0, $sz ;
|
|
my $end = substr $str, -$sz, $sz ;
|
|
$str = $beg . '...' . $end ;
|
|
}
|
|
$str =~ s/\012?\015$//x ;
|
|
return "(len=$len) " . $str ;
|
|
}
|
|
|
|
|
|
|
|
sub lost_connection {
|
|
my( $imap, $error_message ) = @_;
|
|
if ( $imap->IsUnconnected( ) ) {
|
|
$sync->{nb_errors}++ ;
|
|
my $lcomm = $imap->LastIMAPCommand || q{} ;
|
|
my $einfo = $imap->LastError || @{$imap->History}[$LAST] || q{} ;
|
|
|
|
# if string is long try reduce to a more reasonable size
|
|
$lcomm = _filter( $lcomm ) ;
|
|
$einfo = _filter( $einfo ) ;
|
|
myprint( "Failure: last command: $lcomm\n") if ($debug && $lcomm) ;
|
|
myprint( "Failure: lost connection $error_message: ", $einfo, "\n") ;
|
|
return( 1 ) ;
|
|
}
|
|
else{
|
|
return( 0 ) ;
|
|
}
|
|
}
|
|
|
|
sub max {
|
|
my @list = @_ ;
|
|
return( undef ) if ( 0 == scalar @list ) ;
|
|
my @sorted = sort { $a <=> $b } @list ;
|
|
return( pop @sorted ) ;
|
|
}
|
|
|
|
sub tests_max {
|
|
ok( 0 == max( 0 ), 'max 0' ) ;
|
|
ok( 1 == max( 1 ), 'max 1' ) ;
|
|
ok( $MINUS_ONE == max( $MINUS_ONE ), 'max -1') ;
|
|
ok( not ( defined max( ) ), 'max no arg' ) ;
|
|
ok( $NUMBER_100 == max( 1, $NUMBER_100 ), 'max 1 100' ) ;
|
|
ok( $NUMBER_100 == max( $NUMBER_100, 1 ), 'max 100 1' ) ;
|
|
ok( $NUMBER_100 == max( $NUMBER_100, $NUMBER_42, 1 ), 'max 100 42 1' ) ;
|
|
ok( $NUMBER_100 == max( $NUMBER_100, '42', 1 ), 'max 100 42 1' ) ;
|
|
ok( $NUMBER_100 == max( '100', '42', 1 ), 'max 100 42 1' ) ;
|
|
#ok( 100 == max( 100, 'haha', 1 ), 'max 100 42 1') ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub check_lib_version {
|
|
$debug and myprint( "IMAPClient $Mail::IMAPClient::VERSION\n" ) ;
|
|
if ( '2.2.9' eq $Mail::IMAPClient::VERSION ) {
|
|
myprint( "imapsync no longer supports Mail::IMAPClient 2.2.9, upgrade it\n" ) ;
|
|
return 0 ;
|
|
}
|
|
else{
|
|
# 3.x.x is no longer buggy with imapsync.
|
|
# 3.30 or currently superior is imposed in the Perl "use Mail::IMAPClient line".
|
|
return 1 ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub module_version_str {
|
|
my( $module_name, $module_version ) = @_ ;
|
|
my $str = mysprintf( "%-20s %s\n", $module_name, $module_version ) ;
|
|
return( $str ) ;
|
|
}
|
|
|
|
sub modulesversion {
|
|
|
|
my @list_version;
|
|
|
|
my $v ;
|
|
eval { require Mail::IMAPClient; $v = $Mail::IMAPClient::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Mail::IMAPClient', $v ) ;
|
|
|
|
eval { require IO::Socket; $v = $IO::Socket::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'IO::Socket', $v ) ;
|
|
|
|
eval { require IO::Socket::INET; $v = $IO::Socket::INET::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'IO::Socket::INET', $v ) ;
|
|
|
|
eval { require IO::Socket::INET6; $v = $IO::Socket::INET6::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'IO::Socket::INET6', $v ) ;
|
|
|
|
eval { require IO::Socket::SSL ; $v = $IO::Socket::SSL::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'IO::Socket::SSL ', $v ) ;
|
|
|
|
eval { require Net::SSLeay ; $v = $Net::SSLeay::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Net::SSLeay ', $v ) ;
|
|
|
|
eval { require Compress::Zlib; $v = $Compress::Zlib::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Compress::Zlib', $v ) ;
|
|
|
|
eval { require Digest::MD5; $v = $Digest::MD5::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Digest::MD5', $v ) ;
|
|
|
|
eval { require Digest::HMAC_MD5; $v = $Digest::HMAC_MD5::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Digest::HMAC_MD5', $v ) ;
|
|
|
|
eval { require Digest::HMAC_SHA1; $v = $Digest::HMAC_SHA1::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Digest::HMAC_SHA1', $v ) ;
|
|
|
|
eval { require Term::ReadKey; $v = $Term::ReadKey::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Term::ReadKey', $v ) ;
|
|
|
|
eval { require File::Spec; $v = $File::Spec::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'File::Spec', $v ) ;
|
|
|
|
eval { require Time::HiRes; $v = $Time::HiRes::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Time::HiRes', $v ) ;
|
|
|
|
eval { require Unicode::String; $v = $Unicode::String::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Unicode::String', $v ) ;
|
|
|
|
eval { require IO::Tee; $v = $IO::Tee::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'IO::Tee', $v ) ;
|
|
|
|
eval { require File::Copy::Recursive; $v = $File::Copy::Recursive::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'File::Copy::Recursive', $v ) ;
|
|
|
|
eval { require Authen::NTLM; $v = $Authen::NTLM::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Authen::NTLM', $v ) ;
|
|
|
|
eval { require URI::Escape; $v = $URI::Escape::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'URI::Escape', $v ) ;
|
|
|
|
eval { require Data::Uniqid; $v = $Data::Uniqid::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Data::Uniqid', $v ) ;
|
|
|
|
eval { require JSON; $v = $JSON::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'JSON', $v ) ;
|
|
|
|
eval { require JSON::WebToken; $v = $JSON::WebToken::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'JSON::WebToken', $v ) ;
|
|
|
|
eval { require Crypt::OpenSSL::RSA; $v = $Crypt::OpenSSL::RSA::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Crypt::OpenSSL::RSA', $v ) ;
|
|
|
|
eval { require LWP; $v = $LWP::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'LWP', $v ) ;
|
|
|
|
eval { require HTML::Entities; $v = $HTML::Entities::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'HTML::Entities', $v ) ;
|
|
|
|
#eval { require Filesys::DfPortable; $v = $Filesys::DfPortable::VERSION } or $v = q{?} ;
|
|
#push @list_version, module_version_str( 'Filesys::DfPortable', $v ) ;
|
|
|
|
eval { require Getopt::Long; $v = $Getopt::Long::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Getopt::Long', $v ) ;
|
|
|
|
eval { require Test::MockObject; $v = $Test::MockObject::VERSION } or $v = q{?} ;
|
|
push @list_version, module_version_str( 'Test::MockObject', $v ) ;
|
|
|
|
return( @list_version ) ;
|
|
}
|
|
|
|
|
|
# Construct a command line copy with passwords replaced by MASKED.
|
|
sub command_line_nopassword {
|
|
my @argv = @_ ;
|
|
my @argv_nopassword ;
|
|
|
|
return( "@argv" ) if $showpasswords ;
|
|
while ( @argv ) {
|
|
my $arg = shift @argv ; # option name or value
|
|
if ( $arg =~ m/-password[12]/x ) {
|
|
shift @argv ; # password value
|
|
push @argv_nopassword, $arg, 'MASKED' ; # option name and fake value
|
|
}else{
|
|
push @argv_nopassword, $arg ; # same option or value
|
|
}
|
|
}
|
|
return("@argv_nopassword") ;
|
|
}
|
|
|
|
sub tests_command_line_nopassword {
|
|
|
|
ok(q{} eq command_line_nopassword(), 'command_line_nopassword void');
|
|
ok('--blabla' eq command_line_nopassword('--blabla'), 'command_line_nopassword --blabla');
|
|
#myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ;
|
|
ok('--password1 MASKED' eq command_line_nopassword(qw{ --password1 secret1}), 'command_line_nopassword --password1');
|
|
ok('--blabla --password1 MASKED --blibli'
|
|
eq command_line_nopassword(qw{ --blabla --password1 secret1 --blibli }), 'command_line_nopassword --password1 --blibli');
|
|
$showpasswords = 1 ;
|
|
ok(q{} eq command_line_nopassword(), 'command_line_nopassword void');
|
|
ok('--blabla' eq command_line_nopassword('--blabla'), 'command_line_nopassword --blabla');
|
|
#myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ;
|
|
ok('--password1 secret1' eq command_line_nopassword(qw{ --password1 secret1}), 'command_line_nopassword --password1');
|
|
ok('--blabla --password1 secret1 --blibli'
|
|
eq command_line_nopassword(qw{ --blabla --password1 secret1 --blibli }), 'command_line_nopassword --password1 --blibli');
|
|
return ;
|
|
}
|
|
|
|
sub ask_for_password {
|
|
my ( $user, $host ) = @_ ;
|
|
myprint( "What's the password for $user" . '@' . "$host? (not visible while you type, then enter RETURN) " ) ;
|
|
Term::ReadKey::ReadMode( 2 ) ;
|
|
my $password = <> ;
|
|
chomp $password ;
|
|
myprint( "\nGot it\n" ) ;
|
|
Term::ReadKey::ReadMode( 0 ) ;
|
|
return $password ;
|
|
}
|
|
|
|
sub catch_exit {
|
|
my $mysync = shift ;
|
|
my $signame = shift ;
|
|
if ( $signame ) {
|
|
myprint( "\nGot a signal $signame\n" ) ;
|
|
}
|
|
stats( $mysync ) ;
|
|
myprint( "Ended by a signal\n" ) ;
|
|
exit_clean( $mysync, $EXIT_BY_SIGNAL ) ;
|
|
return ;
|
|
}
|
|
|
|
sub catch_reconnect {
|
|
my $mysync = shift ;
|
|
my $signame = shift ;
|
|
myprint( "\nGot a signal $signame\n",
|
|
"Hit 2 ctr-c within 2 seconds to exit the program\n",
|
|
"Hit only 1 ctr-c to reconnect to both imap servers\n",
|
|
) ;
|
|
if ( here_twice( $mysync ) ) {
|
|
myprint( "Got two signals $signame within $INTERVAL_TO_EXIT seconds. Exiting...\n" ) ;
|
|
catch_exit( $mysync ) ;
|
|
}
|
|
else{
|
|
myprint( "For now only one signal $signame within $INTERVAL_TO_EXIT seconds.\n" ) ;
|
|
}
|
|
|
|
if ( ! defined $mysync->{imap1} ) { return ; }
|
|
if ( ! defined $mysync->{imap2} ) { return ; }
|
|
|
|
|
|
myprint( "Info: reconnecting to host1 imap server\n" ) ;
|
|
$mysync->{imap1}->State( Mail::IMAPClient::Unconnected ) ;
|
|
$mysync->{imap1}->reconnect( ) ;
|
|
myprint( "Info: reconnecting to host2 imap server\n" ) ;
|
|
$mysync->{imap2}->State( Mail::IMAPClient::Unconnected ) ;
|
|
$mysync->{imap2}->reconnect( ) ;
|
|
myprint( "Info: reconnected to both imap servers\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
sub here_twice {
|
|
my $mysync = shift ;
|
|
my $now = time ;
|
|
my $previous = $mysync->{lastcatch} || 0 ;
|
|
$mysync->{lastcatch} = $now ;
|
|
|
|
if ( $INTERVAL_TO_EXIT >= $now - $previous ) {
|
|
return $TRUE ;
|
|
}else{
|
|
return $FALSE ;
|
|
}
|
|
}
|
|
|
|
|
|
|
|
|
|
sub justconnect {
|
|
|
|
$imap1 = connect_imap( $host1, $port1, $debugimap1, $ssl1, $tls1, 'Host1', $sync->{h1}->{timeout}, $sync->{h1} ) ;
|
|
myprint( 'Host1 banner: ', $imap1->Banner( ) ) ;
|
|
myprint( 'Host1 capability: ', join(q{ }, $imap1->capability( ) ), "\n" ) ;
|
|
$imap2 = connect_imap( $host2, $port2, $debugimap2, $ssl2, $tls2, 'Host2', $sync->{h2}->{timeout}, $sync->{h2} ) ;
|
|
myprint( 'Host2 banner: ', $imap2->Banner( ) ) ;
|
|
myprint( 'Host2 capability: ', join(q{ }, $imap2->capability( ) ), "\n" ) ;
|
|
$imap1->logout( ) ;
|
|
$imap2->logout( ) ;
|
|
return ;
|
|
}
|
|
|
|
sub connect_imap {
|
|
my( $host, $port, $mydebugimap, $ssl, $tls, $Side, $mytimeout, $h ) = @_ ;
|
|
my $imap = Mail::IMAPClient->new() ;
|
|
if ( $ssl ) { set_ssl( $imap, $h ) }
|
|
if ( $tls ) { $imap->Tls( 1 ) }
|
|
$imap->Server( $host ) ;
|
|
$imap->Port( $port ) ;
|
|
$imap->Debug( $mydebugimap ) ;
|
|
$imap->Timeout( $mytimeout ) ;
|
|
$imap->connect( )
|
|
or die_clean( "$Side: Can not open imap connection on [$host]: $@\n" ) ;
|
|
|
|
my $banner = $imap->Results()->[0] ;
|
|
$imap->Banner( $banner ) ;
|
|
|
|
if ( $imap->Tls( ) ) {
|
|
set_tls( $imap, $h ) ;
|
|
$imap->starttls( )
|
|
or die_clean("$Side: Can not go to tls encryption on [$host]:", $imap->LastError, "\n" ) ;
|
|
myprint( "$Side: Socket successfuly converted to SSL\n" ) ;
|
|
}
|
|
return( $imap ) ;
|
|
}
|
|
|
|
|
|
sub login_imap {
|
|
|
|
my @allargs = @_ ;
|
|
my(
|
|
$host, $port, $user, $domain, $password,
|
|
$mydebugimap, $mytimeout, $fastio,
|
|
$ssl, $tls, $authmech, $authuser, $reconnectretry,
|
|
$proxyauth, $uid, $split, $Side, $h ) = @allargs ;
|
|
|
|
my $side = lc $Side ;
|
|
myprint( "$Side: connecting and login on $side [$host] port [$port] with user [$user]\n" ) ;
|
|
|
|
my $imap = init_imap( @allargs ) ;
|
|
|
|
$imap->connect()
|
|
or die_clean("$Side failure: can not open imap connection on $side [$host] with user [$user]: $@\n") ;
|
|
|
|
my $banner = $imap->Results()->[0] ;
|
|
$imap->Banner( $banner ) ;
|
|
myprint( "$Side banner: $banner" ) ;
|
|
|
|
if ( $authmech eq 'PREAUTH' ) {
|
|
if ( $imap->IsAuthenticated( ) ) {
|
|
$imap->Socket ;
|
|
myprintf("%s: Assuming PREAUTH for %s\n", $Side, $imap->Server ) ;
|
|
}else{
|
|
die_clean( "$Side failure: error login on $side [$host] with user [$user] auth [PREAUTH]" ) ;
|
|
}
|
|
}
|
|
|
|
if ( $imap->Tls( ) ) {
|
|
set_tls( $imap, $h ) ;
|
|
$imap->starttls( )
|
|
or die_clean("$Side failure: Can not go to tls encryption on $side [$host]:", $imap->LastError, "\n" ) ;
|
|
myprint( "$Side: Socket successfuly converted to SSL\n" ) ;
|
|
}
|
|
|
|
authenticate_imap( $imap, @allargs ) ;
|
|
|
|
myprint( "$Side: success login on [$host] with user [$user] auth [$authmech]\n" ) ;
|
|
return( $imap ) ;
|
|
}
|
|
|
|
|
|
sub authenticate_imap {
|
|
|
|
my($imap,
|
|
$host, $port, $user, $domain, $password,
|
|
$mydebugimap, $mytimeout, $fastio,
|
|
$ssl, $tls, $authmech, $authuser, $reconnectretry,
|
|
$proxyauth, $uid, $split, $Side, $h ) = @_ ;
|
|
|
|
check_capability( $imap, $authmech, $Side ) ;
|
|
|
|
if ( $proxyauth ) {
|
|
$imap->Authmechanism(q{}) ;
|
|
$imap->User($authuser) ;
|
|
} else {
|
|
$imap->Authmechanism( $authmech ) unless ( $authmech eq 'LOGIN' or $authmech eq 'PREAUTH' ) ;
|
|
$imap->User($user) ;
|
|
}
|
|
|
|
$imap->Authcallback(\&xoauth) if ( 'XOAUTH' eq $authmech ) ;
|
|
$imap->Authcallback(\&xoauth2) if ( 'XOAUTH2' eq $authmech ) ;
|
|
$imap->Authcallback(\&plainauth) if ( ( 'PLAIN' eq $authmech ) or ( 'EXTERNAL' eq $authmech ) ) ;
|
|
|
|
$imap->Domain($domain) if (defined $domain) ;
|
|
$imap->Authuser($authuser) ;
|
|
$imap->Password($password) ;
|
|
|
|
unless ( $authmech eq 'PREAUTH' or $imap->login( ) ) {
|
|
my $info = "$Side failure: Error login on [$host] with user [$user] auth" ;
|
|
my $einfo = $imap->LastError || @{$imap->History}[$LAST] ;
|
|
chomp $einfo ;
|
|
my $error = "$info [$authmech]: $einfo\n" ;
|
|
if ( $authmech eq 'LOGIN' or $imap->IsUnconnected( ) or $authuser ) {
|
|
die_clean( $error ) ;
|
|
}else{
|
|
myprint( $error ) ;
|
|
}
|
|
myprint( "$Side info: trying LOGIN Auth mechanism on [$host] with user [$user]\n" ) ;
|
|
$imap->Authmechanism(q{}) ;
|
|
$imap->login() or
|
|
die_clean("$info [LOGIN]: ", $imap->LastError, "\n") ;
|
|
}
|
|
|
|
if ( $proxyauth ) {
|
|
if ( ! $imap->proxyauth( $user ) ) {
|
|
my $info = "$Side failure: Error doing proxyauth as user [$user] on [$host] using proxy-login as [$authuser]" ;
|
|
my $einfo = $imap->LastError || @{$imap->History}[$LAST] ;
|
|
chomp $einfo ;
|
|
die_clean( "$info: $einfo\n" ) ;
|
|
}
|
|
}
|
|
|
|
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);
|
|
}
|
|
else {
|
|
myprintf("%s: %s says it has NO CAPABILITY for AUTHENTICATE %s\n",
|
|
$Side, $imap->Server, $authmech);
|
|
if ($authmech eq 'PLAIN') {
|
|
myprint( "$Side: frequently PLAIN is only supported with SSL, ",
|
|
"try --ssl or --tls options\n" ) ;
|
|
}
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub set_ssl {
|
|
my ( $imap, $h ) = @_ ;
|
|
# SSL_version can be
|
|
# SSLv3 SSLv2 SSLv23 SSLv23:!SSLv2 (last one is the default in IO-Socket-SSL-1.953)
|
|
#
|
|
|
|
my $sslargs_hash = $h->{sslargs} ;
|
|
|
|
my $sslargs_default = {
|
|
SSL_verify_mode => $DEFAULT_SSL_VERIFY,
|
|
SSL_verifycn_scheme => 'imap',
|
|
} ;
|
|
|
|
# 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, $h ) = @_ ;
|
|
|
|
my $sslargs_hash = $h->{sslargs} ;
|
|
|
|
my $sslargs_default = {
|
|
SSL_verify_mode => $DEFAULT_SSL_VERIFY,
|
|
} ;
|
|
|
|
# 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 init_imap {
|
|
my(
|
|
$host, $port, $user, $domain, $password,
|
|
$mydebugimap, $mytimeout, $fastio,
|
|
$ssl, $tls, $authmech, $authuser, $reconnectretry,
|
|
$proxyauth, $uid, $split, $Side, $h ) = @_ ;
|
|
|
|
my ( $imap ) ;
|
|
|
|
$imap = Mail::IMAPClient->new() ;
|
|
|
|
if ( $ssl ) { set_ssl( $imap, $h ) }
|
|
if ( $tls ) { $imap->Tls( 1 ) } # can not do set_tls() here because connect() will directly do a STARTTLS
|
|
$imap->Clear(1);
|
|
$imap->Server($host);
|
|
$imap->Port($port);
|
|
$imap->Fast_io($fastio);
|
|
$imap->Buffer($buffersize || $DEFAULT_BUFFER_SIZE);
|
|
$imap->Uid($uid);
|
|
|
|
$imap->Peek(1);
|
|
$imap->Debug($mydebugimap);
|
|
defined $mytimeout and $imap->Timeout( $mytimeout ) ;
|
|
|
|
$imap->Reconnectretry( $reconnectretry ) if ( $reconnectretry ) ;
|
|
$imap->Ignoresizeerrors( $allowsizemismatch ) ;
|
|
$split and $imap->Maxcommandlength( $SPLIT_FACTOR * $split ) ;
|
|
|
|
|
|
return( $imap ) ;
|
|
|
|
}
|
|
|
|
sub plainauth {
|
|
my $code = shift;
|
|
my $imap = shift;
|
|
|
|
my $string = mysprintf("%s\x00%s\x00%s", $imap->User,
|
|
$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)$/ ) {
|
|
my $json = JSON->new( ) ;
|
|
my $filename = $1;
|
|
$debug and myprint( "XOAUTH2 json file: $filename\n" ) ;
|
|
open( my $FILE, '<', $filename ) or die_clean( "error [$filename]: $! " ) ;
|
|
my $jsonfile = $json->decode( join q{}, <$FILE> ) ;
|
|
close $FILE ;
|
|
|
|
$iss = $jsonfile->{client_id};
|
|
$key = $jsonfile->{private_key};
|
|
$debug and myprint( "Service account: $iss\n");
|
|
$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 \_\-\.\/]+);?(.*)?/ ;
|
|
|
|
# Assume key password is google default if not provided
|
|
$keypass = 'notasecret' if not $keypass;
|
|
|
|
$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`;
|
|
|
|
$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( ) ) {
|
|
die_clean( $response->code, "\n", $response->content, "\n" ) ;
|
|
}else{
|
|
$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{} ) ;
|
|
|
|
$debug and myprint( "XOAUTH2 String: $xoauth2_string\n");
|
|
return($xoauth2_string);
|
|
}
|
|
|
|
|
|
|
|
|
|
# xoauth() thanks to Eduardo Bortoluzzi Junior
|
|
sub xoauth {
|
|
require URI::Escape ;
|
|
require Data::Uniqid ;
|
|
|
|
my $code = shift;
|
|
my $imap = shift;
|
|
|
|
# The base information needed to construct the OAUTH authentication
|
|
my $method = 'GET' ;
|
|
my $url = mysprintf( 'https://mail.google.com/mail/b/%s/imap/', $imap->User ) ;
|
|
my $urlparm = mysprintf( 'xoauth_requestor_id=%s', URI::Escape::uri_escape( $imap->User ) ) ;
|
|
|
|
# For Google Apps, the consumer key is the primary domain
|
|
# TODO: create a command line argument to define the consumer key
|
|
my @user_parts = split /@/x, $imap->User ;
|
|
$debug and myprint( "XOAUTH: consumer key: $user_parts[1]\n" ) ;
|
|
|
|
# All the parameters needed to be signed on the XOAUTH
|
|
my %hash = ();
|
|
$hash { 'xoauth_requestor_id' } = URI::Escape::uri_escape($imap->User);
|
|
$hash { 'oauth_consumer_key' } = $user_parts[1];
|
|
$hash { 'oauth_nonce' } = md5_hex(Data::Uniqid::uniqid(rand(), 1==1));
|
|
$hash { 'oauth_signature_method' } = 'HMAC-SHA1';
|
|
$hash { 'oauth_timestamp' } = time ;
|
|
$hash { 'oauth_version' } = '1.0';
|
|
|
|
# Base will hold the string to be signed
|
|
my $base = "$method&" . URI::Escape::uri_escape( $url ) . q{&} ;
|
|
|
|
# The parameters must be in dictionary order before signing
|
|
my $baseparms = q{} ;
|
|
foreach my $key ( sort keys %hash ) {
|
|
if ( length( $baseparms ) > 0 ) {
|
|
$baseparms .= q{&} ;
|
|
}
|
|
|
|
$baseparms .= "$key=$hash{$key}" ;
|
|
}
|
|
|
|
$base .= URI::Escape::uri_escape($baseparms);
|
|
$debug and myprint( "XOAUTH: base request to sign: $base\n" ) ;
|
|
# Sign it with the consumer secret, informed on the command line (password)
|
|
my $digest = hmac_sha1( $base, URI::Escape::uri_escape( $imap->Password ) . q{&} ) ;
|
|
|
|
# The parameters signed become a parameter and...
|
|
$hash { 'oauth_signature' } = URI::Escape::uri_escape( substr encode_base64( $digest ), 0, $MINUS_ONE ) ;
|
|
|
|
# ... we don't need the requestor_id anymore.
|
|
delete $hash{'xoauth_requestor_id'} ;
|
|
|
|
# Create the final authentication string
|
|
my $string = $method . q{ } . $url . q{?} . $urlparm .q{ } ;
|
|
|
|
# All the parameters must be sorted
|
|
$baseparms = q{};
|
|
foreach my $key (sort keys %hash) {
|
|
if(length($baseparms)>0) {
|
|
$baseparms .= q{,} ;
|
|
}
|
|
|
|
$baseparms .= "$key=\"$hash{$key}\"";
|
|
}
|
|
|
|
$string .= $baseparms;
|
|
|
|
$debug and myprint( "XOAUTH: authentication string: $string\n" ) ;
|
|
|
|
# It must be base64 encoded
|
|
return encode_base64("$string", q{});
|
|
}
|
|
|
|
sub server_banner {
|
|
my $imap = shift;
|
|
my $banner = $imap->Banner() || "No banner\n";
|
|
return $banner;
|
|
}
|
|
|
|
|
|
sub banner_imapsync {
|
|
|
|
my @argv = @_ ;
|
|
|
|
my $banner_imapsync = join q{},
|
|
q{$RCSfile: imapsync,v $ },
|
|
q{$Revision: 1.727 $ },
|
|
q{$Date: 2016/08/19 10:30:36 $ },
|
|
"\n", localhost_info(), "\n",
|
|
"Command line used:\n",
|
|
"$0 ", command_line_nopassword( @argv ), "\n" ;
|
|
|
|
return( $banner_imapsync ) ;
|
|
}
|
|
|
|
sub is_valid_directory {
|
|
my $dir = shift;
|
|
|
|
# all good => return ok.
|
|
return( 1 ) if ( -d $dir and -r _ and -w _ ) ;
|
|
|
|
# exist but bad
|
|
if ( -e $dir and not -d _ ) {
|
|
myprint( "Error: $dir exists but is not a directory\n" ) ;
|
|
return( 0 ) ;
|
|
}
|
|
if ( -e $dir and not -w _ ) {
|
|
my $sb = stat $dir ;
|
|
myprintf( "Error: directory %s is not writable for user %s, permissions are %04o and owner is %s ( uid %s )\n",
|
|
$dir, getpwuid_any_os( $EFFECTIVE_USER_ID ), ($sb->mode & oct($PERMISSION_FILTER) ), getpwuid_any_os( $sb->uid ), $sb->uid( ) ) ;
|
|
return( 0 ) ;
|
|
}
|
|
# Trying to create it
|
|
myprint( "Creating directory $dir\n" ) ;
|
|
eval { mkpath( $dir ) } ;
|
|
myprint( "$@" ) if ( $@ ) ;
|
|
return( 1 ) if ( -d $dir and -r _ and -w _ ) ;
|
|
return( 0 ) ;
|
|
}
|
|
|
|
sub tests_is_valid_directory {
|
|
Readonly my $NB_UNIX_tests_is_valid_directory => 4 ;
|
|
SKIP: {
|
|
skip( 'Tests only for Unix', $NB_UNIX_tests_is_valid_directory ) if ( 'MSWin32' eq $OSNAME ) ;
|
|
ok( 1 == is_valid_directory( '.'), 'is_valid_directory: . good' ) ;
|
|
ok( 1 == is_valid_directory( './tmp/tests/valid/sub'), 'is_valid_directory: ./tmp/tests/valid/sub good' ) ;
|
|
diag( 'Error / not writable is on purpose' ) ;
|
|
ok( 0 == is_valid_directory( '/'), 'is_valid_directory: / bad' ) ;
|
|
diag( 'Error permission denied on /noway is on purpose' ) ;
|
|
ok( 0 == is_valid_directory( '/noway'), 'is_valid_directory: /noway bad' ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub write_pidfile {
|
|
my $pid_filename = shift ;
|
|
my $lock = shift ;
|
|
|
|
myprint( "PID file is $pid_filename ( to change it use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ;
|
|
if ( -e $pid_filename and $lock ) {
|
|
myprint( "$pid_filename already exists, another imapsync may be curently running. Aborting imapsync.\n" ) ;
|
|
exit $EXIT_PID_FILE_ALREADY_EXIST ;
|
|
}
|
|
if ( -e $pid_filename ) {
|
|
myprint( "$pid_filename already exists, overwriting it ( use --pidfilelocking to avoid concurrent runs )\n" ) ;
|
|
}
|
|
|
|
open my $FILE_HANDLE, '>', $pid_filename
|
|
or do {
|
|
myprint( "Could not open $pid_filename for writing. Check permissions or disk space." ) ;
|
|
return ;
|
|
} ;
|
|
myprint( "Wrinting my PID $PROCESS_ID in $pid_filename\n" ) ;
|
|
print $FILE_HANDLE $PROCESS_ID ;
|
|
close $FILE_HANDLE ;
|
|
|
|
return( $PROCESS_ID ) ;
|
|
}
|
|
|
|
sub remove_tmp_files {
|
|
my $mysync = shift ;
|
|
unlink $mysync->{pidfile} ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub exit_clean {
|
|
my $mysync = shift ;
|
|
my $status = shift ;
|
|
$status = defined $status ? $status : $EXIT_UNKNOWN ;
|
|
remove_tmp_files( $mysync ) ;
|
|
myprint( "Exiting with return value $status\n" ) ;
|
|
if ( $mysync->{log} ) {
|
|
myprint( "Log file is $mysync->{logfile} ( to change it, use --logfile filepath ; or use --nolog to turn off logging )\n" ) ;
|
|
close $mysync->{logfile_handle} ;
|
|
}
|
|
exit $status ;
|
|
}
|
|
|
|
sub die_clean {
|
|
my @messages = @_ ;
|
|
remove_tmp_files( $sync ) ;
|
|
die @messages ;
|
|
}
|
|
|
|
sub missing_option {
|
|
my ( $option ) = @_ ;
|
|
die_clean( "$option option is mandatory, for help run $0 --help\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub fix_Inbox_INBOX_mapping {
|
|
my( $h1_all, $h2_all ) = @_ ;
|
|
|
|
my $regex = q{} ;
|
|
SWITCH: {
|
|
if ( exists $h1_all->{INBOX} and exists $h2_all->{INBOX} ) { $regex = q{} ; last SWITCH ; } ;
|
|
if ( exists $h1_all->{Inbox} and exists $h2_all->{Inbox} ) { $regex = q{} ; last SWITCH ; } ;
|
|
if ( exists $h1_all->{INBOX} and exists $h2_all->{Inbox} ) { $regex = q{s/^INBOX$/Inbox/x} ; last SWITCH ; } ;
|
|
if ( exists $h1_all->{Inbox} and exists $h2_all->{INBOX} ) { $regex = q{s/^Inbox$/INBOX/x} ; last SWITCH ; } ;
|
|
} ;
|
|
return( $regex ) ;
|
|
}
|
|
|
|
sub 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' ) ;
|
|
|
|
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 {
|
|
ok( q{} eq jux_utf8_list( ), 'jux_utf8_list: void' ) ;
|
|
ok( "[]\n" eq jux_utf8_list( q{} ), 'jux_utf8_list: empty string' ) ;
|
|
ok( "[INBOX]\n" eq jux_utf8_list( 'INBOX' ), 'jux_utf8_list: INBOX' ) ;
|
|
ok( "[&ANY-] = [Ö]\n" eq jux_utf8_list( '&ANY-' ), 'jux_utf8_list: &ANY-' ) ;
|
|
return( 0 ) ;
|
|
}
|
|
|
|
sub jux_utf8 {
|
|
# juxtapose utf8 at the right if different
|
|
my ( $s_utf7 ) = shift ;
|
|
my ( $s_utf8 ) = imap_utf7_decode( $s_utf7 ) ;
|
|
|
|
if ( $s_utf7 eq $s_utf8 ) {
|
|
#myprint( "[$s_utf7]\n" ) ;
|
|
return( "[$s_utf7]" ) ;
|
|
}else{
|
|
#myprint( "[$s_utf7] = [$s_utf8]\n" ) ;
|
|
return( "[$s_utf7] = [$s_utf8]" ) ;
|
|
}
|
|
}
|
|
|
|
# editing utf8 can be tricky without an utf8 editor
|
|
sub tests_jux_utf8 {
|
|
ok( '[INBOX]' eq jux_utf8( 'INBOX'), 'jux_utf8: INBOX => [INBOX]' ) ;
|
|
ok( '[&ZTZO9nux-] = [收件箱]' eq jux_utf8( '&ZTZO9nux-'), 'jux_utf8: => [&ZTZO9nux-] = [收件箱]' ) ;
|
|
ok( '[&ANY-] = [Ö]' eq jux_utf8( '&ANY-'), 'jux_utf8: &ANY- => [&ANY-] = [Ö]' ) ;
|
|
ok( '[]' eq jux_utf8( q{} ), 'jux_utf8: void => []' ) ;
|
|
ok( '[+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' eq jux_utf8( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8: => [+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' ) ;
|
|
ok( '[&BB8EQAQ+BDUEOgRC-] = [Проект]' eq jux_utf8( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ;
|
|
|
|
return( 0 ) ;
|
|
}
|
|
|
|
# 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 {
|
|
my ( $s ) = shift ;
|
|
|
|
# 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\-/g ;
|
|
$s =~ s/&(?!\-)/\+/g ;
|
|
$s =~ s/&\-/&/g ;
|
|
return( Unicode::String::utf7( $s )->utf8 ) ;
|
|
}
|
|
|
|
sub imap_utf7_encode {
|
|
my ( $s ) = @_ ;
|
|
|
|
$s = Unicode::String::utf8( $s )->utf7 ;
|
|
|
|
$s =~ s/\+([^\/&\-]*)\/([^\/\-&]*)\-/\+$1,$2\-/g ;
|
|
$s =~ s/&/&\-/g ;
|
|
$s =~ s/\+([^+\-]+)?\-/&$1\-/g ;
|
|
return( $s ) ;
|
|
}
|
|
|
|
|
|
|
|
|
|
sub select_folder {
|
|
my ( $imap, $folder, $hostside ) = @_ ;
|
|
if ( ! $imap->select( $folder ) ) {
|
|
my $error = join q{},
|
|
"$hostside folder $folder: Could not select: ",
|
|
$imap->LastError, "\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
return( 0 ) ;
|
|
}else{
|
|
# ok select succeeded
|
|
return( 1 ) ;
|
|
}
|
|
}
|
|
|
|
sub examine_folder {
|
|
my ( $imap, $folder, $hostside ) = @_ ;
|
|
if ( ! $imap->examine( $folder ) ) {
|
|
my $error = join q{},
|
|
"$hostside folder $folder: Could not examine: ",
|
|
$imap->LastError, "\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
return( 0 ) ;
|
|
}else{
|
|
# ok select succeeded
|
|
return( 1 ) ;
|
|
}
|
|
}
|
|
|
|
|
|
|
|
|
|
sub count_from_select {
|
|
my @lines = @_ ;
|
|
my $count ;
|
|
foreach my $line ( @lines ) {
|
|
#myprint( "line = [$line]\n" ) ;
|
|
if ( $line =~ m/^\*\s+(\d+)\s+EXISTS/ ) {
|
|
$count = $1 ;
|
|
return( $count ) ;
|
|
}
|
|
}
|
|
return( undef ) ;
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
sub create_folder_old {
|
|
my( $imap, $h2_fold, $h1_fold ) = @_ ;
|
|
|
|
myprint( "Creating (old way) folder [$h2_fold] on host2\n" ) ;
|
|
if ( ( 'INBOX' eq uc $h2_fold )
|
|
and ( $imap->exists( $h2_fold ) ) ) {
|
|
myprint( "Folder [$h2_fold] already exists\n" ) ;
|
|
return( 1 ) ;
|
|
}
|
|
if ( ! $dry ){
|
|
if ( ! $imap->create( $h2_fold ) ) {
|
|
my $error = join q{},
|
|
"Could not create folder [$h2_fold] from [$h1_fold]: ",
|
|
$imap->LastError( ), "\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
# 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 $dry_message\n" ) ;
|
|
return( 0 ) ;
|
|
}
|
|
}
|
|
|
|
|
|
sub create_folder {
|
|
my( $imap2 , $h2_fold , $h1_fold ) = @_ ;
|
|
my( @parts , $parent ) ;
|
|
|
|
if ( $imap2->IsUnconnected( ) ) {
|
|
myprint( "Host2: Unconnected state\n" ) ;
|
|
return( 0 ) ;
|
|
}
|
|
|
|
if ( $create_folder_old ) {
|
|
return( create_folder_old( $imap2 , $h2_fold , $h1_fold ) ) ;
|
|
}
|
|
myprint( "Creating folder [$h2_fold] on host2\n" ) ;
|
|
if ( ( 'INBOX' eq uc $h2_fold )
|
|
and ( $imap2->exists( $h2_fold ) ) ) {
|
|
myprint( "Folder [$h2_fold] already exists\n" ) ;
|
|
return( 1 ) ;
|
|
}
|
|
|
|
if ( $mixfolders and $imap2->exists( $h2_fold ) ) {
|
|
myprint( "Folder [$h2_fold] already exists (--nomixfolders is not set)\n" ) ;
|
|
return( 1 ) ;
|
|
}
|
|
|
|
|
|
if ( ( not $mixfolders ) and ( $imap2->exists( $h2_fold ) ) ) {
|
|
myprint( "Folder [$h2_fold] already exists and --nomixfolders is set\n" ) ;
|
|
return( 0 ) ;
|
|
}
|
|
|
|
@parts = split /\Q$h2_sep\E/, $h2_fold ;
|
|
pop @parts ;
|
|
$parent = join $h2_sep, @parts ;
|
|
$parent =~ s/^\s+|\s+$//g ;
|
|
if ( ( $parent ne q{} ) and ( ! $imap2->exists( $parent ) ) ) {
|
|
create_folder( $imap2 , $parent , $h1_fold ) ;
|
|
}
|
|
|
|
if ( ! $dry ) {
|
|
if ( ! $imap2->create( $h2_fold ) ) {
|
|
my $error = join q{},
|
|
"Could not create folder [$h2_fold] from [$h1_fold]: " ,
|
|
$imap2->LastError( ), "\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
# success if folder exists ("already exists" error)
|
|
return( 1 ) if $imap2->exists( $h2_fold ) ;
|
|
# failure since create failed
|
|
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 $dry_message\n" ) ;
|
|
if ( ! $justfolders ) {
|
|
myprint( "Since --dry mode is on and folder [$h2_fold] on host2 does not exist yet, syncing messages will not be simulated.\n"
|
|
. "To simulate message syncing, use --justfolders without --dry to first create the missing folders then rerun the --dry sync.\n" ) ;
|
|
}
|
|
return( 0 ) ;
|
|
}
|
|
}
|
|
|
|
|
|
|
|
sub tests_folder_routines {
|
|
ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 1' );
|
|
ok( add_to_requested_folders('folder_foo'), 'add_to_requested_folders folder_foo' );
|
|
ok( is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 2' );
|
|
ok( !is_requested_folder('folder_NO_EXIST'), 'is_requested_folder folder_NO_EXIST' );
|
|
ok( !remove_from_requested_folders('folder_foo'), 'removed folder_foo' );
|
|
ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 3' );
|
|
my @f ;
|
|
ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f" );
|
|
ok( is_requested_folder('folder_bar'), 'is_requested_folder 4' );
|
|
ok( is_requested_folder('folder_toto'), 'is_requested_folder 5' );
|
|
ok( remove_from_requested_folders('folder_toto'), 'remove_from_requested_folders: ' );
|
|
ok( !is_requested_folder('folder_toto'), 'is_requested_folder 6' );
|
|
ok( !remove_from_requested_folders('folder_bar'), 'remove_from_requested_folders: empty' ) ;
|
|
|
|
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [] ), 'sort_requested_folders: all empty' ) ;
|
|
ok( add_to_requested_folders('M_55'), 'add_to_requested_folders M_55' );
|
|
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'M_55' ] ), 'sort_requested_folders: middle' ) ;
|
|
@folderfirst = ( 'Z_11' ) ;
|
|
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_55' ] ), 'sort_requested_folders: first+middle' ) ;
|
|
@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' ) ;
|
|
@folderfirst = qw( Z_22 Z_11 ) ;
|
|
@folderlast = qw( A_99 A_88 ) ;
|
|
ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_22', 'Z_11', 'M_44', 'M_55', 'A_99', 'A_88' ] ), 'sort_requested_folders: first+middle+last 3' ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
|
|
sub sort_requested_folders {
|
|
my @requested_folders_sorted = () ;
|
|
|
|
foreach my $folder ( @folderfirst ) {
|
|
remove_from_requested_folders( $folder ) ;
|
|
}
|
|
|
|
foreach my $folder ( @folderlast ) {
|
|
remove_from_requested_folders( $folder ) ;
|
|
}
|
|
|
|
my @middle = sort keys %requested_folder ;
|
|
|
|
@requested_folders_sorted = ( @folderfirst, @middle, @folderlast ) ;
|
|
|
|
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 remove_from_requested_folders {
|
|
my @wanted_folders = @_ ;
|
|
|
|
foreach my $folder ( @wanted_folders ) {
|
|
delete $requested_folder{ $folder } ;
|
|
}
|
|
return( keys %requested_folder ) ;
|
|
}
|
|
|
|
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 {
|
|
|
|
|
|
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') ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub guess_prefix {
|
|
my @foldernames = @_ ;
|
|
|
|
return( undef ) unless ( @foldernames ) ;
|
|
|
|
my $prefix_guessed = q{} ;
|
|
foreach my $folder ( @foldernames ) {
|
|
next if ( $folder =~ m{^INBOX$}i ) ; # no guessing from INBOX
|
|
if ( $folder !~ m{^INBOX}i ) {
|
|
$prefix_guessed = q{} ; # prefix empty guessed
|
|
last ;
|
|
}
|
|
if ( $folder =~ m{^(INBOX(?:\.|\/))}i ) {
|
|
$prefix_guessed = $1 ; # prefix Inbox/ or INBOX. guessed
|
|
}
|
|
}
|
|
return( $prefix_guessed ) ;
|
|
}
|
|
|
|
sub tests_guess_prefix {
|
|
|
|
ok( not( defined guess_prefix( ) ), 'guess_prefix: no args' ) ;
|
|
ok( q{} eq guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ;
|
|
ok( q{} eq guess_prefix( 'Inbox' ), 'guess_prefix: Inbox alone' ) ;
|
|
ok( q{} eq guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ;
|
|
ok( 'INBOX/' eq guess_prefix( 'INBOX', 'INBOX/Junk' ), 'guess_prefix: INBOX INBOX/Junk' ) ;
|
|
ok( 'INBOX.' eq guess_prefix( 'INBOX', 'INBOX.Junk' ), 'guess_prefix: INBOX INBOX.Junk' ) ;
|
|
ok( 'Inbox/' eq guess_prefix( 'Inbox', 'Inbox/Junk' ), 'guess_prefix: Inbox Inbox/Junk' ) ;
|
|
ok( 'Inbox.' eq guess_prefix( 'Inbox', 'Inbox.Junk' ), 'guess_prefix: Inbox Inbox.Junk' ) ;
|
|
ok( 'INBOX/' eq guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr' ) ;
|
|
ok( q{} eq guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr', 'zzz' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr zzz' ) ;
|
|
ok( q{} eq guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ;
|
|
ok( q{} eq guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub get_prefix {
|
|
my( $imap, $prefix_in, $prefix_opt, $Side, $folders_ref ) = @_ ;
|
|
my( $prefix_out, $prefix_guessed ) ;
|
|
|
|
( $debug or $sync->{debugfolders} ) and myprint( "$Side: Getting prefix\n" ) ;
|
|
$prefix_guessed = guess_prefix( @{ $folders_ref } ) ;
|
|
myprint( "$Side: guessing prefix from folder listing: [$prefix_guessed]\n" ) ;
|
|
( $debug or $sync->{debugfolders} ) and myprint( "$Side: Calling namespace capability\n" ) ;
|
|
if ( $imap->has_capability( 'namespace' ) ) {
|
|
my $r_namespace = $imap->namespace( ) ;
|
|
$prefix_out = $r_namespace->[0][0][0] ;
|
|
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{/}g ) ; # count /
|
|
$counter{'.'}++ while ( $folder =~ m{\.}g ) ; # count .
|
|
$counter{'\\\\'}++ while ( $folder =~ m{(\\){2}}g ) ; # count \\
|
|
}
|
|
my @race_sorted = sort { $counter{ $b } <=> $counter{ $a } } keys %counter ;
|
|
#myprint( "@race_sorted\n" ) ;
|
|
$sep_guessed = shift @race_sorted || $LAST_RESSORT_SEPARATOR ; # / when nothing found.
|
|
return( $sep_guessed ) ;
|
|
}
|
|
|
|
sub tests_guess_separator {
|
|
ok( '/' eq guess_separator( ), 'guess_separator: no args' ) ;
|
|
ok( '/' eq guess_separator( 'abcd' ), 'guess_separator: abcd' ) ;
|
|
ok( '/' eq guess_separator( 'a/b/c.d' ), 'guess_separator: a/b/c.d' ) ;
|
|
ok( '.' eq guess_separator( 'a.b/c.d' ), 'guess_separator: a.b/c.d' ) ;
|
|
ok( '\\\\' eq guess_separator( 'a\\\\b\\\\c.c\\\\d/e/f' ), 'guess_separator: a\\\\b\\\\c.c\\\\d/e/f' ) ;
|
|
return ;
|
|
}
|
|
|
|
sub get_separator {
|
|
my( $imap, $sep_in, $sep_opt, $Side, $folders_ref ) = @_ ;
|
|
my( $sep_out, $sep_guessed ) ;
|
|
|
|
( $debug or $sync->{debugfolders} ) and myprint( "$Side: Getting separator\n" ) ;
|
|
$sep_guessed = guess_separator( @{ $folders_ref } ) ;
|
|
myprint( "$Side: guessing separator from folder listing: [$sep_guessed]\n" ) ;
|
|
|
|
( $debug or $sync->{debugfolders} ) and myprint( "$Side: calling namespace capability\n" ) ;
|
|
if ( $imap->has_capability( 'namespace' ) ) {
|
|
$sep_out = $imap->separator( ) ;
|
|
if ( defined $sep_out ) {
|
|
myprint( "$Side: separator given by NAMESPACE: [$sep_out]\n" ) ;
|
|
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) = @_ ;
|
|
|
|
my @folders = $imap->folders ;
|
|
my $listing = join q{}, map { "[$_]\n" } @folders ;
|
|
return( $listing ) ;
|
|
}
|
|
|
|
|
|
sub tests_separator_invert {
|
|
$fixslash2 = 0 ;
|
|
ok( not( defined separator_invert( ) ), 'separator_invert: no args' ) ;
|
|
ok( not( defined separator_invert( q{} ) ), 'separator_invert: not enough args' ) ;
|
|
ok( not( defined separator_invert( q{}, q{} ) ), 'separator_invert: not enough args' ) ;
|
|
|
|
ok( q{} eq separator_invert( q{}, q{}, q{} ), 'separator_invert: 3 empty strings' ) ;
|
|
ok( 'lalala' eq separator_invert( 'lalala', q{}, q{} ), 'separator_invert: empty separator' ) ;
|
|
ok( 'lalala' eq separator_invert( 'lalala', '/', '/' ), 'separator_invert: same separator /' ) ;
|
|
ok( 'lal/ala' eq separator_invert( 'lal/ala', '/', '/' ), 'separator_invert: same separator / 2' ) ;
|
|
ok( 'lal.ala' eq separator_invert( 'lal/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
|
|
ok( 'lal/ala' eq separator_invert( 'lal.ala', '.', '/' ), 'separator_invert: separators ./' ) ;
|
|
ok( 'la.l/ala' eq separator_invert( 'la/l.ala', '.', '/' ), 'separator_invert: separators ./' ) ;
|
|
|
|
ok( 'l/al.ala' eq separator_invert( 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
|
|
$fixslash2 = 1 ;
|
|
ok( 'l_al.ala' eq separator_invert( 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub separator_invert {
|
|
my( $h1_fold, $h1_separator, $h2_separator ) = @_ ;
|
|
|
|
return( undef ) if ( not defined $h1_fold or not defined $h1_separator or not defined $h2_separator ) ;
|
|
# The separator we hope we'll never encounter: 00000000 == 0x00
|
|
my $o_sep = "\000" ;
|
|
|
|
my $h2_fold = $h1_fold ;
|
|
$h2_fold =~ s,\Q$h2_separator,$o_sep,xg ;
|
|
$h2_fold =~ s,\Q$h1_separator,$h2_separator,xg ;
|
|
$h2_fold =~ s,\Q$o_sep,$h1_separator,xg ;
|
|
$h2_fold =~ s,/,_,xg if( $fixslash2 and '/' ne $h2_separator and '/' eq $h1_separator ) ;
|
|
return( $h2_fold ) ;
|
|
}
|
|
|
|
|
|
sub tests_imap2_folder_name {
|
|
|
|
$h1_prefix = $h2_prefix = q{};
|
|
$h1_sep = '/';
|
|
$h2_sep = '.';
|
|
|
|
$debug and myprint( <<"EOS"
|
|
prefix1: [$h1_prefix]
|
|
prefix2: [$h2_prefix]
|
|
sep1:[$h1_sep]
|
|
sep2:[$h2_sep]
|
|
EOS
|
|
) ;
|
|
|
|
$fixslash2 = 0 ;
|
|
ok(q{} eq imap2_folder_name(q{}), 'imap2_folder_name: empty string');
|
|
ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla');
|
|
ok('spam.spam' eq imap2_folder_name('spam/spam'), 'imap2_folder_name: spam/spam');
|
|
ok('spam/spam' eq imap2_folder_name('spam.spam'), 'imap2_folder_name: spam.spam');
|
|
ok('spam.spam/spam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam');
|
|
ok('s pam.spam/sp am' eq imap2_folder_name('s pam/spam.sp am'), 'imap2_folder_name: s pam/spam.sp am');
|
|
|
|
$sync->{f1f2}{ 'auto' } = 'moto' ;
|
|
ok( 'moto' eq imap2_folder_name( 'auto' ), 'imap2_folder_name: auto' ) ;
|
|
$sync->{f1f2}{ 'auto/auto' } = 'moto x 2' ;
|
|
ok( 'moto x 2' eq imap2_folder_name( 'auto/auto' ), 'imap2_folder_name: auto/auto' ) ;
|
|
|
|
@regextrans2 = ('s,/,X,g');
|
|
ok(q{} eq imap2_folder_name(q{}), 'imap2_folder_name: empty string [s,/,X,g]');
|
|
ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla [s,/,X,g]');
|
|
ok('spam.spam' eq imap2_folder_name('spam/spam'), 'imap2_folder_name: spam/spam [s,/,X,g]');
|
|
ok('spamXspam' eq imap2_folder_name('spam.spam'), 'imap2_folder_name: spam.spam [s,/,X,g]');
|
|
ok('spam.spamXspam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam [s,/,X,g]');
|
|
|
|
@regextrans2 = ( 's, ,_,g' ) ;
|
|
ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla [s, ,_,g]');
|
|
ok('bla_bla' eq imap2_folder_name('bla bla'), 'imap2_folder_name: blabla [s, ,_,g]');
|
|
|
|
@regextrans2 = ( q{s,(.*),\U$1,} ) ;
|
|
ok( 'BLABLA' eq imap2_folder_name( 'blabla' ), q{imap2_folder_name: blabla [s,\U(.*)\E,$1,]} ) ;
|
|
|
|
$fixslash2 = 1 ;
|
|
@regextrans2 = ( ) ;
|
|
ok(q{} eq imap2_folder_name(q{}), 'imap2_folder_name: empty string');
|
|
ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla');
|
|
ok('spam.spam' eq imap2_folder_name('spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam');
|
|
ok('spam_spam' eq imap2_folder_name('spam.spam'), 'imap2_folder_name: spam.spam -> spam_spam');
|
|
ok('spam.spam_spam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam_spam');
|
|
ok('s pam.spam_spa m' eq imap2_folder_name('s pam/spam.spa m'), 'imap2_folder_name: s pam/spam.spa m -> s pam.spam_spa m');
|
|
|
|
$h1_sep = '.';
|
|
$h2_sep = '/';
|
|
ok(q{} eq imap2_folder_name(q{}), 'imap2_folder_name: empty string');
|
|
ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla');
|
|
ok('spam.spam' eq imap2_folder_name('spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam');
|
|
ok('spam/spam' eq imap2_folder_name('spam.spam'), 'imap2_folder_name: spam.spam -> spam/spam');
|
|
ok('spam.spam/spam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam');
|
|
|
|
|
|
|
|
$fixslash2 = 0 ;
|
|
$h1_prefix = q{ };
|
|
|
|
ok('spam.spam/spam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam');
|
|
ok('spam.spam/spam' eq imap2_folder_name(' spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam');
|
|
|
|
$h1_sep = '.' ;
|
|
$h2_sep = '/' ;
|
|
$h1_prefix = 'INBOX.' ;
|
|
$h2_prefix = q{} ;
|
|
@regextrans2 = ( q{s,(.*),\U$1,} ) ;
|
|
ok( 'BLABLA' eq imap2_folder_name( 'blabla' ), 'imap2_folder_name: blabla' ) ;
|
|
ok( 'TEST/TEST/TEST/TEST' eq imap2_folder_name( 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ;
|
|
@regextrans2 = ( q{s,(.*),\L$1,} ) ;
|
|
ok( 'test/test/test/test' eq imap2_folder_name( 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ;
|
|
|
|
|
|
return ;
|
|
|
|
}
|
|
|
|
sub imap2_folder_name {
|
|
my ( $h1_fold ) = @_ ;
|
|
my ( $h2_fold ) ;
|
|
if ( $sync->{f1f2}{ $h1_fold } ) {
|
|
$h2_fold = $sync->{f1f2}{ $h1_fold } ;
|
|
( $debug or $sync->{debugfolders} ) and myprint( "f1f2 [$h1_fold] -> [$h2_fold]\n" ) ;
|
|
return( $h2_fold ) ;
|
|
}
|
|
if ( $sync->{f1f2auto}{ $h1_fold } ) {
|
|
$h2_fold = $sync->{f1f2auto}{ $h1_fold } ;
|
|
( $debug or $sync->{debugfolders} ) and myprint( "automap [$h1_fold] -> [$h2_fold]\n" ) ;
|
|
return( $h2_fold ) ;
|
|
}
|
|
|
|
$h2_fold = prefix_seperator_invertion( $h1_fold ) ;
|
|
$h2_fold = regextrans2( $h2_fold ) ;
|
|
return( $h2_fold ) ;
|
|
}
|
|
|
|
sub prefix_seperator_invertion {
|
|
my ( $h1_fold ) = @_ ;
|
|
my ( $h2_fold ) ;
|
|
|
|
# first we remove the prefix
|
|
$h1_fold =~ s/^\Q$h1_prefix\E//x ;
|
|
( $debug or $sync->{debugfolders} ) and myprint( "removed host1 prefix: [$h1_fold]\n" ) ;
|
|
$h2_fold = separator_invert( $h1_fold, $h1_sep, $h2_sep ) ;
|
|
( $debug or $sync->{debugfolders} ) and myprint( "inverted separators: [$h2_fold]\n" ) ;
|
|
# Adding the prefix supplied by namespace or the --prefix2 option
|
|
$h2_fold = $h2_prefix . $h2_fold
|
|
unless( ( $h2_prefix eq 'INBOX' . $h2_sep ) and ( $h2_fold =~ m/^INBOX$/xi ) ) ;
|
|
( $debug or $sync->{debugfolders} ) and myprint( "added host2 prefix: [$h2_fold]\n" ) ;
|
|
return( $h2_fold ) ;
|
|
}
|
|
|
|
sub regextrans2 {
|
|
my( $h2_fold ) = @_ ;
|
|
# Transforming the folder name by the --regextrans2 option(s)
|
|
foreach my $regextrans2 ( @regextrans2 ) {
|
|
my $h2_fold_before = $h2_fold ;
|
|
my $ret = eval "\$h2_fold =~ $regextrans2 ; 1 " ;
|
|
( $debug or $sync->{debugfolders} ) and myprint( "[$h2_fold_before] -> [$h2_fold] using regextrans2 [$regextrans2]\n" ) ;
|
|
if ( not ( defined $ret ) or $@ ) {
|
|
die_clean( "error: eval regextrans2 '$regextrans2': $@\n" ) ;
|
|
}
|
|
}
|
|
return( $h2_fold ) ;
|
|
}
|
|
|
|
|
|
sub tests_decompose_regex {
|
|
ok( 1, 'decompose_regex 1' ) ;
|
|
ok( 0 == compare_lists( [ q{}, q{} ], [ decompose_regex( q{} ) ] ), 'decompose_regex empty string' ) ;
|
|
ok( 0 == compare_lists( [ '.*', 'lala' ], [ decompose_regex( 's/.*/lala/' ) ] ), 'decompose_regex s/.*/lala/' ) ;
|
|
return ;
|
|
}
|
|
|
|
sub decompose_regex {
|
|
my $regex = shift ;
|
|
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 foldersizes {
|
|
|
|
my ( $side, $imap, $search_cmd, @folders ) = @_ ;
|
|
my $total_size = 0 ;
|
|
my $total_nb = 0 ;
|
|
my $biggest_in_all = 0 ;
|
|
|
|
my $nb_folders = scalar @folders ;
|
|
my $ct_folders = 0 ; # folder counter.
|
|
myprint( "++++ Calculating sizes of $nb_folders folders on $side\n" ) ;
|
|
foreach my $folder ( @folders ) {
|
|
my $stot = 0 ;
|
|
my $nb_msgs = 0 ;
|
|
$ct_folders++ ;
|
|
myprintf( "$side folder %7s %-35s", "$ct_folders/$nb_folders", jux_utf8( $folder ) ) ;
|
|
if ( 'Host2' eq $side and not exists $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( ) ;
|
|
# FTGate is RFC buggy with EXAMINE it does not act as SELECT
|
|
#unless ( $imap->examine( $folder ) ) {
|
|
unless ( $imap->select( $folder ) ) {
|
|
my $error = join q{},
|
|
"$side Folder $folder: Could not select: ",
|
|
$imap->LastError, "\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
next ;
|
|
}
|
|
last if $imap->IsUnconnected( ) ;
|
|
|
|
my $hash_ref = { } ;
|
|
my @msgs = select_msgs( $imap, undef, $search_cmd, $folder ) ;
|
|
$nb_msgs = scalar @msgs ;
|
|
my $biggest_in_folder = 0 ;
|
|
@{ $hash_ref }{ @msgs } = ( undef ) if @msgs ;
|
|
|
|
last if $imap->IsUnconnected( ) ;
|
|
if ( $nb_msgs > 0 and @msgs ) {
|
|
if ( $abletosearch ) {
|
|
if ( ! $imap->fetch_hash( \@msgs, 'RFC822.SIZE', $hash_ref) ) {
|
|
my $error = "$side failure with fetch_hash: $@" ;
|
|
errors_incr( $sync, $error ) ;
|
|
return ;
|
|
}
|
|
}else{
|
|
my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ;
|
|
my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
|
|
if ( ! $imap->fetch_hash( $fetch_hash_uids, 'RFC822.SIZE', $hash_ref ) ) {
|
|
my $error = "$side failure with fetch_hash: $@" ;
|
|
errors_incr( $sync, $error ) ;
|
|
return ;
|
|
}
|
|
}
|
|
for ( keys %{ $hash_ref } ) {
|
|
my $size = $hash_ref->{ $_ }->{ 'RFC822.SIZE' } ;
|
|
$stot += $size ;
|
|
$biggest_in_folder = max( $biggest_in_folder, $size ) ;
|
|
}
|
|
}
|
|
|
|
myprintf( ' Size: %9s', $stot ) ;
|
|
myprintf( ' Messages: %5s', $nb_msgs ) ;
|
|
myprintf( " Biggest: %9s\n", $biggest_in_folder ) ;
|
|
$total_size += $stot ;
|
|
$total_nb += $nb_msgs ;
|
|
$biggest_in_all = max( $biggest_in_all, $biggest_in_folder ) ;
|
|
}
|
|
myprintf( "%s Nb folders: %11s folders\n", $side, $nb_folders ) ;
|
|
myprintf( "%s Nb messages: %11s messages\n", $side, $total_nb ) ;
|
|
myprintf( "%s Total size: %11s bytes (%s)\n", $side, $total_size, bytes_display_string( $total_size ) ) ;
|
|
myprintf( "%s Biggest message: %11s bytes (%s)\n", $side, $biggest_in_all, bytes_display_string( $biggest_in_all ) ) ;
|
|
myprintf( "%s Time spent: %11.1f seconds\n", $side, timenext( ) ) ;
|
|
return( $total_nb, $total_size ) ;
|
|
}
|
|
|
|
sub timenext {
|
|
my ( $timenow, $timediff ) ;
|
|
# $timebefore is global, beurk !
|
|
$timenow = time ;
|
|
$timediff = $timenow - $timebefore ;
|
|
$timebefore = $timenow ;
|
|
return( $timediff ) ;
|
|
}
|
|
|
|
sub timesince {
|
|
my $timeinit = shift ;
|
|
my ( $timenow, $timediff ) ;
|
|
$timenow = time ;
|
|
$timediff = $timenow - $timeinit ;
|
|
return( $timediff ) ;
|
|
}
|
|
|
|
|
|
|
|
|
|
sub tests_flags_regex {
|
|
|
|
ok( q{} eq flags_regex(q{} ), 'flags_regex, null string q{}' ) ;
|
|
ok( q'\Seen NonJunk $Spam' eq flags_regex( q'\Seen NonJunk $Spam' ), 'flags_regex, nothing to do');
|
|
|
|
@regexflag = ('I am BAD' ) ;
|
|
ok( not ( defined flags_regex( q{} ) ), 'flags_regex, bad regex' ) ;
|
|
|
|
@regexflag = ( 's/NonJunk//g' ) ;
|
|
ok( q'\Seen $Spam' eq flags_regex( q'\Seen NonJunk $Spam' ), q{flags_regex, remove NonJunk: 's/NonJunk//g'} ) ;
|
|
@regexflag = ( q's/\$Spam//g' ) ;
|
|
ok( '\Seen NonJunk ' eq flags_regex( q'\Seen NonJunk $Spam' ), q{flags_regex, remove $Spam: 's/\$Spam//g'} ) ;
|
|
|
|
@regexflag = ( 's/\\\\Seen//g' ) ;
|
|
|
|
ok( q' NonJunk $Spam' eq flags_regex( q'\Seen NonJunk $Spam' ), q{flags_regex, remove \Seen: 's/\\\\\\\\Seen//g'} ) ;
|
|
|
|
@regexflag = ( 's/(\s|^)[^\\\\]\w+//g' ) ;
|
|
ok( '\Seen \Middle \End' eq flags_regex( q'\Seen NonJunk \Middle $Spam \End' ), q{flags_regex: only \word among \Seen NonJunk \Middle $Spam \End} ) ;
|
|
ok( ' \Seen \Middle \End1' eq flags_regex( q'Begin \Seen NonJunk \Middle $Spam \End1 End' ),
|
|
q'flags_regex: only \word among Begin \Seen NonJunk \Middle $Spam \End1 End' ) ;
|
|
|
|
@regexflag = ( q's/.*?(Keep1|Keep2|Keep3)/$1 /g' ) ;
|
|
ok('Keep1 Keep2 ReB' eq flags_regex('ReA Keep1 REM Keep2 ReB'), 'Keep only regex' ) ;
|
|
|
|
ok('Keep1 Keep2 ' eq flags_regex( 'REM REM Keep1 Keep2'), 'Keep only regex' ) ;
|
|
ok('Keep1 Keep2 ' eq flags_regex( 'Keep1 REM REM Keep2'), 'Keep only regex' ) ;
|
|
ok('Keep1 Keep2 ' eq flags_regex( 'REM Keep1 REM REM Keep2'), 'Keep only regex' ) ;
|
|
ok('Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2'), 'Keep only regex' ) ;
|
|
ok('Keep1 ' eq flags_regex( 'REM Keep1'), 'Keep only regex' ) ;
|
|
|
|
@regexflag = ( q's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g' ) ;
|
|
ok('Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 ReB'), 'Keep only regex' ) ;
|
|
ok('Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 REM REM REM'), 'Keep only regex' ) ;
|
|
ok('Keep2 ' eq flags_regex('Keep2 REM REM REM'), 'Keep only regex' ) ;
|
|
|
|
|
|
@regexflag = ( q's/.*?(Keep1|Keep2|Keep3)/$1 /g',
|
|
's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g');
|
|
ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), 'Keep only regex');
|
|
ok('Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), 'Keep only regex');
|
|
ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), 'Keep only regex');
|
|
ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), 'Keep only regex');
|
|
ok('Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), 'Keep only regex');
|
|
ok('Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), 'Keep only regex');
|
|
ok('Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), 'Keep only regex');
|
|
|
|
@regexflag = ('s/(.*)/$1 jrdH8u/');
|
|
ok('REM REM REM REM REM jrdH8u' eq flags_regex('REM REM REM REM REM'), q{Keep only regex 's/(.*)/\$1 jrdH8u/'} ) ;
|
|
@regexflag = ('s/jrdH8u *//');
|
|
ok('REM REM REM REM REM ' eq flags_regex('REM REM REM REM REM jrdH8u'), q{Keep only regex s/jrdH8u *//} ) ;
|
|
|
|
@regexflag = (
|
|
's/(.*)/$1 jrdH8u/',
|
|
's/.*?(Keep1|Keep2|Keep3|jrdH8u)/$1 /g',
|
|
's/(Keep1|Keep2|Keep3|jrdH8u) (?!(Keep1|Keep2|Keep3|jrdH8u)).*/$1 /g',
|
|
's/jrdH8u *//'
|
|
);
|
|
|
|
ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), q{Keep only regex 'REM Keep1 REM Keep2 REM'} ) ;
|
|
ok('Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), 'Keep only regex');
|
|
ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), 'Keep only regex');
|
|
ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), 'Keep only regex');
|
|
ok('Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), 'Keep only regex');
|
|
ok('Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), 'Keep only regex');
|
|
ok('Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), 'Keep only regex');
|
|
ok(q{} eq flags_regex('REM REM REM REM REM'), 'Keep only regex');
|
|
|
|
@regexflag = (
|
|
's/(.*)/$1 jrdH8u/',
|
|
's/.*?(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u)/$1 /g',
|
|
's/(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u) (?!(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u)).*/$1 /g',
|
|
's/jrdH8u *//'
|
|
);
|
|
|
|
ok('\\Deleted \\Answered '
|
|
eq flags_regex('Blabla $Junk \\Deleted machin \\Answered truc'), 'Keep only regex: Exchange case' ) ;
|
|
ok( q{} eq flags_regex( q{} ), 'Keep only regex: Exchange case, null string' ) ;
|
|
ok( q{}
|
|
eq flags_regex('Blabla $Junk machin truc'), 'Keep only regex: Exchange case, no accepted flags' ) ;
|
|
ok( '\\Deleted \\Answered \\Draft \\Flagged '
|
|
eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), 'Keep only regex: Exchange case' ) ;
|
|
|
|
|
|
@regexflag = (
|
|
's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg'
|
|
);
|
|
|
|
ok( '\\Deleted \\Answered '
|
|
eq flags_regex('Blabla \$Junk \\Deleted machin \\Answered truc'),
|
|
'Keep only regex: Exchange case (Phil)' ) ;
|
|
|
|
ok( q{} eq flags_regex( q{} ), 'Keep only regex: Exchange case, null string (Phil)' ) ;
|
|
|
|
ok( q{}
|
|
eq flags_regex('Blabla $Junk machin truc'),
|
|
'Keep only regex: Exchange case, no accepted flags (Phil)' ) ;
|
|
|
|
ok('\\Deleted \\Answered \\Draft \\Flagged '
|
|
eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '),
|
|
'Keep only regex: Exchange case (Phil)' ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub flags_regex {
|
|
my ( $h1_flags ) = @_ ;
|
|
foreach my $regexflag ( @regexflag ) {
|
|
my $h1_flags_orig = $h1_flags ;
|
|
$debugflags and myprint( "eval \$h1_flags =~ $regexflag\n" ) ;
|
|
my $ret = eval "\$h1_flags =~ $regexflag ; 1 " ;
|
|
$debugflags and myprint( "regexflag $regexflag [$h1_flags_orig] -> [$h1_flags]\n" ) ;
|
|
if( not ( defined $ret ) or $@ ) {
|
|
myprint( "Error: eval regexflag '$regexflag': $@\n" ) ;
|
|
return( undef ) ;
|
|
}
|
|
}
|
|
return( $h1_flags ) ;
|
|
}
|
|
|
|
sub acls_sync {
|
|
my($h1_fold, $h2_fold) = @_ ;
|
|
if ( $syncacls ) {
|
|
my $h1_hash = $imap1->getacl($h1_fold)
|
|
or myprint( "Could not getacl for $h1_fold: $@\n" ) ;
|
|
my $h2_hash = $imap2->getacl($h2_fold)
|
|
or myprint( "Could not getacl for $h2_fold: $@\n" ) ;
|
|
my %users = map { ($_, 1) } ( keys %{ $h1_hash} , keys %{ $h2_hash } ) ;
|
|
foreach my $user (sort keys %users ) {
|
|
my $acl = $h1_hash->{$user} || 'none' ;
|
|
myprint( "acl $user: [$acl]\n" ) ;
|
|
next if ($h1_hash->{$user} && $h2_hash->{$user} &&
|
|
$h1_hash->{$user} eq $h2_hash->{$user});
|
|
unless ($dry) {
|
|
myprint( "setting acl $h2_fold $user $acl\n" ) ;
|
|
$imap2->setacl($h2_fold, $user, $acl)
|
|
or myprint( "Could not set acl: $@\n" ) ;
|
|
}
|
|
}
|
|
}
|
|
return ;
|
|
}
|
|
|
|
|
|
sub tests_permanentflags {
|
|
|
|
my $string;
|
|
ok(q{} eq permanentflags(' * OK [PERMANENTFLAGS (\* \Draft \Answered)] Limited'),
|
|
'permanentflags \*');
|
|
ok('\Draft \Answered' eq permanentflags(' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited'),
|
|
'permanentflags \Draft \Answered');
|
|
ok('\Draft \Answered'
|
|
eq permanentflags('Blabla',
|
|
' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited',
|
|
'Blabla'),
|
|
'permanentflags \Draft \Answered'
|
|
);
|
|
ok(q{} eq permanentflags('Blabla'), 'permanentflags nothing');
|
|
return ;
|
|
}
|
|
|
|
sub permanentflags {
|
|
my @lines = @_ ;
|
|
|
|
foreach my $line (@lines) {
|
|
if ( $line =~ m{\[PERMANENTFLAGS\s\(([^)]+?)\)\]}x ) {
|
|
( $debugflags or $debug ) and myprint( "permanentflags: $line" ) ;
|
|
my $permanentflags = $1 ;
|
|
if ( $permanentflags =~ m{\\\*}x ) {
|
|
$permanentflags = q{} ;
|
|
}
|
|
return($permanentflags) ;
|
|
} ;
|
|
}
|
|
return( q{} ) ;
|
|
}
|
|
|
|
sub tests_flags_filter {
|
|
|
|
ok( '\Seen' eq flags_filter('\Seen', '\Draft \Seen \Answered'), 'flags_filter ' );
|
|
ok( q{} eq flags_filter('\Seen', '\Draft \Answered'), 'flags_filter ' );
|
|
ok( '\Seen' eq flags_filter('\Seen', '\Seen'), 'flags_filter ' );
|
|
ok( '\Seen' eq flags_filter('\Seen', ' \Seen '), 'flags_filter ' );
|
|
ok( '\Seen \Draft'
|
|
eq flags_filter('\Seen \Draft', '\Draft \Seen \Answered'), 'flags_filter ' );
|
|
ok( '\Seen \Draft'
|
|
eq flags_filter('\Seen \Draft', ' \Draft \Seen \Answered '), 'flags_filter ' );
|
|
return ;
|
|
}
|
|
|
|
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 flagscase {
|
|
my $flags = shift ;
|
|
|
|
my @flags = split /\s+/x, $flags ;
|
|
my %rfc_flags = map { $_ => 1 } split q{ }, '\Answered \Flagged \Deleted \Seen \Draft' ;
|
|
my @flags_out = map { exists $rfc_flags{ ucsecond( lc $_ ) } ? ucsecond( lc $_ ) : $_ } @flags ;
|
|
|
|
my $flags_out = join q{ }, @flags_out ;
|
|
|
|
return( $flags_out ) ;
|
|
}
|
|
|
|
sub tests_flagscase {
|
|
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' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub ucsecond {
|
|
my $string = shift ;
|
|
my $output ;
|
|
|
|
return( $string ) if ( 1 >= length $string ) ;
|
|
|
|
$output = ( substr( $string, 0, 1) ) . ( uc substr $string, 1, 1 ) . ( substr $string, 2 ) ;
|
|
#myprint( "UUU $string -> $output\n" ) ;
|
|
return( $output ) ;
|
|
}
|
|
|
|
|
|
sub tests_ucsecond {
|
|
ok( 'aBcde' eq ucsecond( 'abcde' ), 'ucsecond: abcde -> aBcde' ) ;
|
|
ok( 'ABCDE' eq ucsecond( 'ABCDE' ), 'ucsecond: ABCDE -> ABCDE' ) ;
|
|
ok( 'ABCDE' eq ucsecond( 'AbCDE' ), 'ucsecond: AbCDE -> ABCDE' ) ;
|
|
ok( 'ABCde' eq ucsecond( 'AbCde' ), 'ucsecond: AbCde -> ABCde' ) ;
|
|
ok( 'A' eq ucsecond( 'A' ), 'ucsecond: A -> A' ) ;
|
|
ok( 'AB' eq ucsecond( 'Ab' ), 'ucsecond: Ab -> AB' ) ;
|
|
ok( '\B' eq ucsecond( '\b' ), 'ucsecond: \b -> \B' ) ;
|
|
ok( '\Bcde' eq ucsecond( '\bcde' ), 'ucsecond: \bcde -> \Bcde' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub select_msgs {
|
|
my ( $imap, $msgs_all_hash_ref, $search_cmd, $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 $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 $uidnext = $imap->uidnext( $folder ) || $uidnext_default ;
|
|
my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
|
|
%fetch = %{$imap->fetch_hash( $fetch_hash_uids, 'INTERNALDATE' ) } ;
|
|
|
|
@msgs_all = sort { $a <=> $b } keys %fetch ;
|
|
$debugdev and myprint( "Done fetch_hash()\n" ) ;
|
|
|
|
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: {
|
|
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 {
|
|
my @msgs ;
|
|
$maxage = $NUMBER_200 ;
|
|
@msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
|
|
ok( 0 == compare_lists( [ '1', '2' ], \@msgs ), 'msgs_from_maxmin: maxage++' ) ;
|
|
$minage = $NUMBER_100 ;
|
|
@msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
|
|
ok( 0 == compare_lists( [ '2' ], \@msgs ), 'msgs_from_maxmin: -maxage++minage-' ) ;
|
|
$minage = $NUMBER_300 ;
|
|
@msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
|
|
ok( 0 == compare_lists( [ '1', '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++maxage-minage++' ) ;
|
|
$maxage = undef ;
|
|
@msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
|
|
ok( 0 == compare_lists( [ '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++minage-' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub lastuid {
|
|
my $imap = shift ;
|
|
my $folder = shift ;
|
|
my $lastuid_guess = shift ;
|
|
my $lastuid ;
|
|
|
|
# rfc3501: The only reliable way to identify recent messages is to
|
|
# look at message flags to see which have the \Recent flag
|
|
# set, or to do a SEARCH RECENT.
|
|
# SEARCH RECENT doesn't work this way on courrier.
|
|
|
|
my @recent_messages ;
|
|
# SEARCH RECENT for each transfer can be expensive with a big folder
|
|
# Call commented for now
|
|
#@recent_messages = $imap->recent( ) ;
|
|
#myprint( "Recent: @recent_messages\n" ) ;
|
|
|
|
my $max_recent ;
|
|
$max_recent = max( @recent_messages ) ;
|
|
|
|
if ( defined $max_recent and ($lastuid_guess <= $max_recent ) ) {
|
|
$lastuid = $max_recent ;
|
|
}else{
|
|
$lastuid = $lastuid_guess
|
|
}
|
|
return( $lastuid ) ;
|
|
}
|
|
|
|
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 $maxsize and $h1_size > $maxsize) {
|
|
myprint( "msg $h1_fold/$h1_msg skipped ($h1_size exceeds maxsize limit $maxsize bytes)\n" ) ;
|
|
$total_bytes_skipped += $h1_size;
|
|
$nb_msg_skipped += 1;
|
|
return( 1 ) ;
|
|
}
|
|
if (defined $minsize and $h1_size <= $minsize) {
|
|
myprint( "msg $h1_fold/$h1_msg skipped ($h1_size smaller than minsize $minsize bytes)\n" ) ;
|
|
$total_bytes_skipped += $h1_size;
|
|
$nb_msg_skipped += 1;
|
|
return( 1 ) ;
|
|
}
|
|
return( 0 ) ;
|
|
}
|
|
|
|
sub message_exists {
|
|
my( $imap, $msg ) = @_ ;
|
|
return( 1 ) if not $imap->Uid( ) ;
|
|
|
|
my $search_uid ;
|
|
( $search_uid ) = $imap->search( "UID $msg" ) ;
|
|
#myprint( "$search ? $msg\n" ) ;
|
|
return( 1 ) if ( $search_uid eq $msg ) ;
|
|
return( 0 ) ;
|
|
}
|
|
|
|
sub copy_message {
|
|
# copy
|
|
|
|
my ( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) = @_ ;
|
|
( $debug or $dry) and myprint( "msg $h1_fold/$h1_msg copying to $h2_fold $dry_message\n" ) ;
|
|
|
|
my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} || 0 ;
|
|
my $h1_flags = $h1_fir_ref->{$h1_msg}->{'FLAGS'} || q{} ;
|
|
my $h1_idate = $h1_fir_ref->{$h1_msg}->{'INTERNALDATE'} || q{} ;
|
|
|
|
|
|
if ( size_filtered( $h1_size, $h1_msg, $h1_fold, $h2_fold ) ) {
|
|
$h1_nb_msg_processed +=1 ;
|
|
return ;
|
|
}
|
|
|
|
debugsleep( $sync ) ;
|
|
myprint( "- msg $h1_fold/$h1_msg S[$h1_size] F[$h1_flags] I[$h1_idate] has RFC822.SIZE null!\n" ) if ( ! $h1_size ) ;
|
|
|
|
|
|
if ( $checkmessageexists and not message_exists( $imap1, $h1_msg ) ) {
|
|
$total_bytes_skipped += $h1_size;
|
|
$nb_msg_skipped += 1;
|
|
$h1_nb_msg_processed +=1 ;
|
|
return ;
|
|
}
|
|
if ( $sync->{debugmemory} ) {
|
|
myprintf("C1: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
|
|
}
|
|
|
|
my ( $string, $string_len ) ;
|
|
( $string_len ) = message_for_host2( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, \$string ) ;
|
|
|
|
if ( $sync->{debugmemory} ) {
|
|
myprintf("C2: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
|
|
}
|
|
|
|
# not defined or empty $string
|
|
if ( ( not $string ) and ( not $string_len ) ) {
|
|
myprint( "- msg $h1_fold/$h1_msg skipped.\n" ) ;
|
|
$total_bytes_skipped += $h1_size;
|
|
$nb_msg_skipped += 1;
|
|
$h1_nb_msg_processed +=1 ;
|
|
return ;
|
|
}
|
|
|
|
# Lines too long (or not enough) => do no copy or fix
|
|
if ( ( defined $maxlinelength ) or ( defined $minmaxlinelength ) ) {
|
|
$string = linelengthstuff( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) ;
|
|
if ( not defined $string ) {
|
|
$h1_nb_msg_processed +=1 ;
|
|
$total_bytes_skipped += $h1_size ;
|
|
$nb_msg_skipped += 1 ;
|
|
return ;
|
|
}
|
|
}
|
|
|
|
my $h1_date = date_for_host2( $h1_msg, $h1_idate ) ;
|
|
|
|
( $debug or $debugflags ) and
|
|
myprint( "Host1 flags init msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ;
|
|
|
|
$h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ;
|
|
|
|
( $debug or $debugflags ) and
|
|
myprint( "Host1 flags filt msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ;
|
|
|
|
$h1_date = undef if ($h1_date eq q{});
|
|
|
|
my $new_id = append_message_on_host2( \$string, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) ;
|
|
|
|
if ( $new_id and $syncflagsaftercopy ) {
|
|
sync_flags_after_copy( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $new_id, $permanentflags2 ) ;
|
|
}
|
|
|
|
if ( $sync->{debugmemory} ) {
|
|
myprintf("C3: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
|
|
}
|
|
|
|
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
|
|
# $addheader
|
|
# $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 ( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) = @_ ;
|
|
|
|
# abort when missing a parameter
|
|
if ( (!$sync) or (!$h1_msg) or (!$h1_fold) or (!$h1_size) or (!defined $h1_flags) or (!$h1_idate) or (!$h1_fir_ref) or (!$string_ref) ) {
|
|
return ;
|
|
}
|
|
|
|
if ( $sync->{debugmemory} ) {
|
|
myprintf("M1: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
|
|
}
|
|
|
|
my $imap1 = $sync->{imap1} ;
|
|
my $string_ok = $imap1->message_to_file( $string_ref, $h1_msg ) ;
|
|
|
|
if ( $sync->{debugmemory} ) {
|
|
myprintf("M2: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
|
|
}
|
|
|
|
my $string_len = length_ref( $string_ref ) ;
|
|
|
|
|
|
unless ( defined $string_ok and $string_len ) {
|
|
# undef or 0 length
|
|
my $error = join q{},
|
|
"- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] could not be fetched: ",
|
|
$imap1->LastError || q{}, "\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
$total_bytes_error += $h1_size if ( $h1_size ) ;
|
|
$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 ( $addheader and defined $h1_fir_ref->{$h1_msg}->{'NO_HEADER'} ) {
|
|
my $header = add_header( $h1_msg ) ;
|
|
$debug and myprint( "msg $h1_fold/$h1_msg adding custom header [$header]\n" ) ;
|
|
${ $string_ref } = $header . "\r\n" . ${ $string_ref } ;
|
|
}
|
|
|
|
$string_len = length_ref( $string_ref ) ;
|
|
|
|
$debugcontent and myprint(
|
|
q{=} x $STD_CHAR_PER_LINE, "\n",
|
|
"F message content begin next line ($string_len characters long)\n",
|
|
${ $string_ref },
|
|
"F message content ended on previous line\n", q{=} x $STD_CHAR_PER_LINE, "\n" ) ;
|
|
|
|
if ( $sync->{debugmemory} ) {
|
|
myprintf("M3: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
|
|
}
|
|
|
|
return $string_len ;
|
|
}
|
|
|
|
sub tests_message_for_host2 {
|
|
|
|
my ( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) ;
|
|
|
|
is( undef, message_for_host2( ), q{message_for_host2: no args} ) ;
|
|
is( undef, message_for_host2( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), q{message_for_host2: undef args} ) ;
|
|
|
|
require Test::MockObject ;
|
|
my $imapT = Test::MockObject->new( ) ;
|
|
$sync->{imap1} = $imapT ;
|
|
my $string ;
|
|
|
|
$h1_msg = 1 ;
|
|
$h1_fold = 'FoldFoo';
|
|
$h1_size = 9 ;
|
|
$h1_flags = '' ;
|
|
$h1_idate = '10-Jul-2015 09:00:00 +0200' ;
|
|
$h1_fir_ref = {} ;
|
|
$string_ref = \$string ;
|
|
$imapT->mock( 'message_to_file',
|
|
sub {
|
|
my ( $imap, $string_ref, $msg ) = @_ ;
|
|
${$string_ref} = 'blablabla' ;
|
|
return length ${$string_ref} ;
|
|
}
|
|
) ;
|
|
is( 9, message_for_host2( $sync, $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( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
|
|
q{message_for_host2: --pipemess 'cat', length} ) ;
|
|
is( 'blablabla', $string, q{message_for_host2: --pipemess 'cat', value} ) ;
|
|
|
|
|
|
# failure by false
|
|
@pipemess = ( 'false' ) ;
|
|
is( undef, message_for_host2( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
|
|
q{message_for_host2: --pipemess 'false', length} ) ;
|
|
is( undef, $string, q{message_for_host2: --pipemess 'false', value} ) ;
|
|
|
|
# failure by true since no output
|
|
@pipemess = ( 'true' ) ;
|
|
is( undef, message_for_host2( $sync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
|
|
q{message_for_host2: --pipemess 'true', length} ) ;
|
|
is( undef, $string, q{message_for_host2: --pipemess 'true', value} ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub length_ref {
|
|
my $string_ref = shift ;
|
|
my $string_len = defined ${ $string_ref } ? length( ${ $string_ref } ) : q{} ; # length or empty string
|
|
return $string_len ;
|
|
}
|
|
|
|
sub 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} ) ;
|
|
return ;
|
|
}
|
|
|
|
sub date_for_host2 {
|
|
my( $h1_msg, $h1_idate ) = @_ ;
|
|
|
|
my $h1_date = q{} ;
|
|
|
|
if ( $syncinternaldates ) {
|
|
$h1_date = $h1_idate ;
|
|
$debug and myprint( "internal date from host1: [$h1_date]\n" ) ;
|
|
$h1_date = good_date( $h1_date ) ;
|
|
$debug and myprint( "internal date from host1: [$h1_date] (fixed)\n" ) ;
|
|
}
|
|
|
|
if ( $idatefromheader ) {
|
|
$h1_date = $imap1->get_header( $h1_msg, 'Date' ) ;
|
|
$debug and myprint( "header date from host1: [$h1_date]\n" ) ;
|
|
$h1_date = good_date( $h1_date ) ;
|
|
$debug and myprint( "header date from host1: [$h1_date] (fixed)\n" ) ;
|
|
}
|
|
|
|
return( $h1_date ) ;
|
|
}
|
|
|
|
sub flags_for_host2 {
|
|
my( $h1_flags, $permanentflags2 ) = @_ ;
|
|
# RFC 2060: This flag can not be altered by any client
|
|
$h1_flags =~ s@\\Recent\s?@@xgi ;
|
|
my $h1_flags_re ;
|
|
if ( @regexflag and defined( $h1_flags_re = flags_regex( $h1_flags ) ) ) {
|
|
$h1_flags = $h1_flags_re ;
|
|
}
|
|
$h1_flags = flagscase( $h1_flags ) if $flagscase ;
|
|
$h1_flags = flags_filter( $h1_flags, $permanentflags2) if ( $permanentflags2 and $filterflags ) ;
|
|
|
|
return( $h1_flags ) ;
|
|
}
|
|
|
|
sub subject {
|
|
my $string = shift ;
|
|
my $subject = q{} ;
|
|
|
|
my $header = extract_header( $string ) ;
|
|
|
|
if( $header =~ m/^Subject:\s*([^\n\r]*)\r?$/msx ) {
|
|
#myprint( "MMM[$1]\n" ) ;
|
|
$subject = $1 ;
|
|
}
|
|
return( $subject ) ;
|
|
}
|
|
|
|
sub tests_subject {
|
|
ok( q{} eq subject( q{} ), 'subject: null') ;
|
|
ok( 'toto le hero' eq subject( 'Subject: toto le hero' ), 'subject: toto le hero') ;
|
|
ok( 'toto le hero' eq subject( 'Subject:toto le hero' ), 'subject: toto le hero blank') ;
|
|
ok( 'toto le hero' eq subject( "Subject:toto le hero\r\n" ), 'subject: toto le hero\r\n') ;
|
|
|
|
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') ;
|
|
|
|
return ;
|
|
}
|
|
|
|
|
|
# GlobVar
|
|
# $dry
|
|
# $max_msg_size_in_bytes
|
|
# $imap2
|
|
# $imap1
|
|
# $total_bytes_error
|
|
# $h1_nb_msg_processed
|
|
# $h2_uidguess
|
|
# $total_bytes_transferred
|
|
# $nb_msg_transferred
|
|
# $begin_transfer_time
|
|
# $time_spent
|
|
# ...
|
|
#
|
|
#
|
|
sub append_message_on_host2 {
|
|
my( $string_ref, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) = @_ ;
|
|
if ( $sync->{debugmemory} ) {
|
|
myprintf("A1: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
|
|
}
|
|
|
|
my $new_id ;
|
|
if ( ! $dry ) {
|
|
$max_msg_size_in_bytes = max( $h1_size, $max_msg_size_in_bytes ) ;
|
|
$new_id = $imap2->append_string( $h2_fold, ${ $string_ref }, $h1_flags, $h1_date ) ;
|
|
if ( $sync->{debugmemory} ) {
|
|
myprintf("A2: Memory consumption: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI) ;
|
|
}
|
|
if ( ! $new_id){
|
|
my $subject = subject( ${ $string_ref } ) ;
|
|
my $error_imap = $imap2->LastError || q{} ;
|
|
my $error = "- msg $h1_fold/$h1_msg {$string_len} couldn't append (Subject:[$subject]) to folder $h2_fold: $error_imap\n" ;
|
|
errors_incr( $sync, $error ) ;
|
|
$total_bytes_error += $h1_size;
|
|
$h1_nb_msg_processed +=1 ;
|
|
return ;
|
|
}
|
|
else{
|
|
# good
|
|
# $new_id is an id if the IMAP server has the
|
|
# UIDPLUS capability else just a ref
|
|
if ( $new_id !~ m{^\d+$}x ) {
|
|
$new_id = lastuid( $imap2, $h2_fold, $h2_uidguess ) ;
|
|
}
|
|
$h2_uidguess += 1 ;
|
|
$total_bytes_transferred += $h1_size ;
|
|
$nb_msg_transferred += 1 ;
|
|
$h1_nb_msg_processed +=1 ;
|
|
|
|
my $time_spent = timesince( $begin_transfer_time ) ;
|
|
my $rate = bytes_display_string( $total_bytes_transferred / $time_spent ) ;
|
|
my $eta = eta( $time_spent,
|
|
$h1_nb_msg_processed, $h1_nb_msg_start, $nb_msg_transferred ) ;
|
|
my $amount_transferred = bytes_display_string( $total_bytes_transferred ) ;
|
|
myprintf( "msg %s/%-19s copied to %s/%-10s %.2f msgs/s %s/s %s copied %s\n",
|
|
$h1_fold, "$h1_msg {$string_len}", $h2_fold, $new_id, $nb_msg_transferred/$time_spent, $rate,
|
|
$amount_transferred,
|
|
$eta );
|
|
sleep_if_needed( $time_spent, $total_bytes_transferred, $nb_msg_transferred ) ;
|
|
if ( $usecache and $cacheaftercopy and $new_id =~ m{^\d+$}x ) {
|
|
$debugcache and myprint( "touch $cache_dir/${h1_msg}_$new_id\n" ) ;
|
|
touch( "$cache_dir/${h1_msg}_$new_id" )
|
|
or croak( "Couldn't touch $cache_dir/${h1_msg}_$new_id" ) ;
|
|
}
|
|
if ( $delete ) {
|
|
delete_message_on_host1( $h1_msg, $h1_fold ) ;
|
|
}
|
|
#myprint( "PRESS ENTER" ) and my $a = <> ;
|
|
return( $new_id ) ;
|
|
}
|
|
}
|
|
else{
|
|
# NOOP to avoid timeout on large folders.
|
|
$imap2->noop( ) ;
|
|
$nb_msg_skipped_dry_mode += 1 ;
|
|
$h1_nb_msg_processed +=1 ;
|
|
}
|
|
|
|
return ;
|
|
}
|
|
|
|
sub sleep_if_needed {
|
|
my( $time_spent, $total_bytes_transferred, $nb_msg_transferred ) = @_ ;
|
|
my $sleep_max_messages = sleep_max_messages( $nb_msg_transferred, $time_spent, $maxmessagespersecond ) ;
|
|
my $sleep_max_bytes = sleep_max_bytes( $total_bytes_transferred, $time_spent, $maxbytespersecond ) ;
|
|
my $sleep_max = max( $sleep_max_messages, $sleep_max_bytes ) ;
|
|
if ( $sleep_max > 0 ) {
|
|
myprintf( "sleeping %.2f s\n", $sleep_max ) ;
|
|
sleep $sleep_max ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
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 {
|
|
ok( 0 == sleep_max_messages( 4, 2, undef ), 'sleep_max_messages: maxmessagespersecond = undef') ;
|
|
ok( 0 == sleep_max_messages( 4, 2, 0 ), 'sleep_max_messages: maxmessagespersecond = 0') ;
|
|
ok( 0 == sleep_max_messages( 4, 2, $MINUS_ONE ), 'sleep_max_messages: maxmessagespersecond = -1') ;
|
|
ok( 0 == sleep_max_messages( 4, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max reached') ;
|
|
ok( 2 == sleep_max_messages( 8, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max over') ;
|
|
ok( 0 == sleep_max_messages( 2, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max not reached') ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub sleep_max_bytes {
|
|
# how long we have to sleep to go under max_bytes_per_second
|
|
my( $total_bytes_transferred, $time_spent, $maxbytespersecond ) = @_ ;
|
|
if ( ( not defined $maxbytespersecond ) or $maxbytespersecond <= 0 ) { return( 0 ) } ;
|
|
my $sleep = ( $total_bytes_transferred / $maxbytespersecond ) - $time_spent ;
|
|
# the sleep must be positive
|
|
return( max( 0, $sleep ) ) ;
|
|
}
|
|
|
|
|
|
sub tests_sleep_max_bytes {
|
|
ok( 0 == sleep_max_bytes( 4000, 2, undef ), 'sleep_max_bytes: maxbytespersecond = undef') ;
|
|
ok( 0 == sleep_max_bytes( 4000, 2, 0 ), 'sleep_max_bytes: maxbytespersecond = 0') ;
|
|
ok( 0 == sleep_max_bytes( 4000, 2, $MINUS_ONE ), 'sleep_max_bytes: maxbytespersecond = -1') ;
|
|
ok( 0 == sleep_max_bytes( 4000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2 max reached') ;
|
|
ok( 2 == sleep_max_bytes( 8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2 max over') ;
|
|
ok( 0 == sleep_max_bytes( 2000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2 max not reached') ;
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
|
|
# 6 GlobVar: $dry_message $dry $imap1 $h1_nb_msg_deleted $expunge $expunge1
|
|
sub delete_message_on_host1 {
|
|
my( $h1_msg, $h1_fold ) = @_ ;
|
|
my $expunge_message = q{} ;
|
|
$expunge_message = 'and expunged' if ( $expungeaftereach and ( $expunge or $expunge1 ) ) ;
|
|
myprint( "Host1 msg $h1_fold/$h1_msg marked deleted $expunge_message $dry_message\n" ) ;
|
|
if ( ! $dry ) {
|
|
$imap1->delete_message( $h1_msg ) ;
|
|
$h1_nb_msg_deleted += 1 ;
|
|
$imap1->expunge( ) if ( $expungeaftereach and ( $expunge or $expunge1 ) ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
|
|
sub eta {
|
|
my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @_ ;
|
|
return( q{} ) if not $foldersizes ;
|
|
|
|
my $time_remaining = time_remaining( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) ;
|
|
my $nb_msg_remaining = $h1_nb_msg_start - $h1_nb_processed ;
|
|
my $eta_date = localtime( time + $time_remaining ) ;
|
|
return( mysprintf( 'ETA: %s %1.0f s %s/%s msgs left', $eta_date, $time_remaining, $nb_msg_remaining, $h1_nb_msg_start ) ) ;
|
|
}
|
|
|
|
sub time_remaining {
|
|
|
|
my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @_ ;
|
|
|
|
my $time_remaining = ( $my_time_spent / $nb_transferred ) * ( $h1_nb_msg_start - $h1_nb_processed ) ;
|
|
return( $time_remaining ) ;
|
|
}
|
|
|
|
|
|
sub tests_time_remaining {
|
|
|
|
ok( 1 == time_remaining( 1, 1, 2, 1 ), 'time_remaining: 1, 1, 2, 1 -> 1' ) ;
|
|
ok( 1 == time_remaining( 9, 9, 10, 9 ), 'time_remaining: 9, 9, 10, 9 -> 1' ) ;
|
|
ok( 9 == time_remaining( 1, 1, 10, 1 ), 'time_remaining: 1, 1, 10, 1 -> 1' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
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 {
|
|
#$debugcache = 1 ;
|
|
my @cache_files = qw (
|
|
100_200
|
|
101_201
|
|
120_220
|
|
142_242
|
|
143_243
|
|
177_277
|
|
177_278
|
|
177_279
|
|
155_255
|
|
180_280
|
|
181_280
|
|
182_280
|
|
130_231
|
|
130_2301
|
|
161_260
|
|
1601_260
|
|
) ;
|
|
|
|
my $msgs_1 = [120, 142, 143, 144, 161, 1601, 177, 182, 130 ];
|
|
my $msgs_2 = [ 242, 243, 260, 299, 377, 279, 255, 280, 231, 2301 ];
|
|
|
|
my( $c12, $c21 ) ;
|
|
ok( ( $c12, $c21 ) = cache_map( \@cache_files, $msgs_1, $msgs_2 ), 'cache_map: 02' );
|
|
my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ;
|
|
my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ;
|
|
ok( 0 == compare_lists( [ 130, 142, 143, 177, 182, 1601 ], $a1 ), 'cache_map: 03' );
|
|
ok( 0 == compare_lists( [ 242, 243, 260, 279, 280, 2301 ], $a2 ), 'cache_map: 04' );
|
|
ok( ! $c12->{161}, 'cache_map: ! 161 -> 260' );
|
|
ok( 260 == $c12->{1601}, 'cache_map: 1601 -> 260' );
|
|
ok( 2301 == $c12->{130}, 'cache_map: 130 -> 2301' );
|
|
#myprint( $c12->{1601}, "\n" ) ;
|
|
return ;
|
|
|
|
}
|
|
|
|
sub cache_dir_fix {
|
|
my $cache_dir = shift ;
|
|
$cache_dir =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\])/\\$1/xg ;
|
|
#myprint( "cache_dir_fix: $cache_dir\n" ) ;
|
|
return( $cache_dir ) ;
|
|
}
|
|
|
|
sub tests_cache_dir_fix {
|
|
ok( 'lalala' eq cache_dir_fix('lalala'), 'cache_dir_fix: lalala -> lalala' );
|
|
ok( 'ii\\\\ii' eq cache_dir_fix('ii\ii'), 'cache_dir_fix: ii\ii -> ii\\\\ii' );
|
|
ok( 'ii@ii' eq cache_dir_fix('ii@ii'), 'cache_dir_fix: ii@ii -> ii@ii' );
|
|
ok( 'ii@ii\\:ii' eq cache_dir_fix('ii@ii:ii'), 'cache_dir_fix: ii@ii:ii -> ii@ii\\:ii' );
|
|
ok( 'i\\\\i\\\\ii' eq cache_dir_fix('i\i\ii'), 'cache_dir_fix: i\i\ii -> i\\\\i\\\\ii' );
|
|
ok( 'i\\\\ii' eq cache_dir_fix('i\\ii'), 'cache_dir_fix: i\\ii -> i\\\\\\\\ii' );
|
|
ok( '\\\\ ' eq cache_dir_fix('\\ '), 'cache_dir_fix: \\ -> \\\\\ ' );
|
|
ok( '\\\\ ' eq cache_dir_fix('\ '), 'cache_dir_fix: \ -> \\\\\ ' );
|
|
ok( '\[bracket\]' eq cache_dir_fix('[bracket]'), 'cache_dir_fix: [bracket] -> \[bracket\]' );
|
|
return ;
|
|
}
|
|
|
|
sub cache_dir_fix_win {
|
|
my $cache_dir = shift ;
|
|
$cache_dir =~ s/(\[|\])/[$1]/xg ;
|
|
#myprint( "cache_dir_fix_win: $cache_dir\n" ) ;
|
|
return( $cache_dir ) ;
|
|
}
|
|
|
|
sub tests_cache_dir_fix_win {
|
|
ok( 'lalala' eq cache_dir_fix_win('lalala'), 'cache_dir_fix_win: lalala -> lalala' );
|
|
ok( '[[]bracket[]]' eq cache_dir_fix_win('[bracket]'), 'cache_dir_fix_win: [bracket] -> [[]bracket[]]' );
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
|
|
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 {
|
|
|
|
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');
|
|
return ;
|
|
}
|
|
|
|
sub match_a_cache_file {
|
|
my $file = shift ;
|
|
my ( $cache_uid1, $cache_uid2 ) ;
|
|
|
|
return( ( undef, undef ) ) if ( ! $file ) ;
|
|
if ( $file =~ m{(?:^|/)(\d+)_(\d+)$}x ) {
|
|
$cache_uid1 = $1 ;
|
|
$cache_uid2 = $2 ;
|
|
}
|
|
return( $cache_uid1, $cache_uid2 ) ;
|
|
}
|
|
|
|
sub tests_match_a_cache_file {
|
|
my ( $tuid1, $tuid2 ) ;
|
|
ok( ( $tuid1, $tuid2 ) = match_a_cache_file( ), 'match_a_cache_file: no arg' ) ;
|
|
ok( ! defined $tuid1 , 'match_a_cache_file: no arg 1' ) ;
|
|
ok( ! defined $tuid2 , 'match_a_cache_file: no arg 2' ) ;
|
|
|
|
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' ) ;
|
|
|
|
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( "$!" ) ;
|
|
}
|
|
}
|
|
|
|
$debugcache and myprint( "Exiting clean_cache\n" ) ;
|
|
return( 1 ) ;
|
|
}
|
|
|
|
sub tests_clean_cache {
|
|
|
|
ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache: rmtree W/tmp/cache/G1/G2' ) ;
|
|
ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache: mkpath W/tmp/cache/G1/G2' ) ;
|
|
|
|
my @test_files_cache = ( qw(
|
|
W/tmp/cache/G1/G2/100_200
|
|
W/tmp/cache/G1/G2/101_201
|
|
W/tmp/cache/G1/G2/120_220
|
|
W/tmp/cache/G1/G2/142_242
|
|
W/tmp/cache/G1/G2/143_243
|
|
W/tmp/cache/G1/G2/177_277
|
|
W/tmp/cache/G1/G2/177_377
|
|
W/tmp/cache/G1/G2/177_777
|
|
W/tmp/cache/G1/G2/155_255
|
|
) ) ;
|
|
ok( touch(@test_files_cache), 'clean_cache: touch W/tmp/cache/G1/G2/...' ) ;
|
|
|
|
ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 before' );
|
|
ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 before' );
|
|
ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 before' );
|
|
ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 before' );
|
|
ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 before' );
|
|
ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 before' );
|
|
|
|
my $cache = {
|
|
142 => 242,
|
|
177 => 777,
|
|
} ;
|
|
|
|
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' );
|
|
return ;
|
|
}
|
|
|
|
sub tests_clean_cache_2 {
|
|
|
|
ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache_2: rmtree W/tmp/cache/G1/G2' ) ;
|
|
ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache_2: mkpath W/tmp/cache/G1/G2' ) ;
|
|
|
|
my @test_files_cache = ( qw(
|
|
W/tmp/cache/G1/G2/100_200
|
|
W/tmp/cache/G1/G2/101_201
|
|
W/tmp/cache/G1/G2/120_220
|
|
W/tmp/cache/G1/G2/142_242
|
|
W/tmp/cache/G1/G2/143_243
|
|
W/tmp/cache/G1/G2/177_277
|
|
W/tmp/cache/G1/G2/177_377
|
|
W/tmp/cache/G1/G2/177_777
|
|
W/tmp/cache/G1/G2/155_255
|
|
) ) ;
|
|
ok( touch(@test_files_cache), 'clean_cache_2: touch W/tmp/cache/G1/G2/...' ) ;
|
|
|
|
ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 before' );
|
|
ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 before' );
|
|
ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 before' );
|
|
ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 before' );
|
|
ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 before' );
|
|
ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 before' );
|
|
|
|
my $cache = {
|
|
142 => 242,
|
|
177 => 777,
|
|
} ;
|
|
|
|
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' );
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub tests_mkpath {
|
|
|
|
ok( 1 == 1, 'tests_mkpath: 1 == 1' ) ;
|
|
|
|
SKIP: {
|
|
skip( 'Tests only for Unix', 2 ) if ( 'MSWin32' eq $OSNAME ) ;
|
|
my $long_path_unix = '123456789/' x 30 ;
|
|
ok( (-d "W/tmp/tests/long/$long_path_unix" or mkpath( "W/tmp/tests/long/$long_path_unix" ) ), 'tests_mkpath: mkpath > 300 char' ) ;
|
|
ok( (-d "W/tmp/tests/long/$long_path_unix" and rmtree( 'W/tmp/tests/long/' ) ), 'tests_mkpath: rmtree > 300 char' ) ;
|
|
} ;
|
|
|
|
SKIP: {
|
|
skip( 'Tests only for MSWin32', 6 ) if ( 'MSWin32' ne $OSNAME ) ;
|
|
my $long_path_2_prefix = "$tmpdir\\imapsync_tests" || '\\\?\\E:\\TEMP\\imapsync_tests' ;
|
|
myprint( "long_path_2_prefix: $long_path_2_prefix\n" ) ;
|
|
|
|
my $long_path_2 = $long_path_2_prefix . '\\' . '123456789\\' x 10 . 'END' ;
|
|
my $long_path_300 = $long_path_2_prefix . '\\' . '123456789\\' x 30 . 'END' ;
|
|
|
|
myprint( "$long_path_2\n" ) ;
|
|
|
|
#ok( ( -d $long_path_2_prefix and rmtree( $long_path_2_prefix ) ), 'tests_mkpath: rmtree > 200 char' ) ;
|
|
#ok( ( -d $long_path_2_prefix or mkpath( "\\\\\?\\E:\\\\TEMP\\imapsync_tests" ) ), 'tests_mkpath: -d small path 1' ) ;
|
|
|
|
ok( ( -d $long_path_2_prefix or mkpath( $long_path_2_prefix ) ), 'tests_mkpath: -d mkpath small path' ) ;
|
|
ok( ( -d $long_path_2_prefix ), 'tests_mkpath: -d mkpath small path done' ) ;
|
|
ok( ( -d $long_path_2 or mkpath( $long_path_2 ) ), 'tests_mkpath: mkpath > 200 char' ) ;
|
|
ok( ( -d $long_path_2 ), 'tests_mkpath: -d mkpath > 200 char done' ) ;
|
|
ok( ( -d $long_path_2_prefix and rmtree( $long_path_2_prefix ) ), 'tests_mkpath: rmtree > 200 char' ) ;
|
|
ok( (! -d $long_path_2_prefix ), 'tests_mkpath: ! -d rmtree done' ) ;
|
|
|
|
myprint( "$long_path_300\n" ) ;
|
|
# This one just kill the whole process without a whisper:
|
|
#ok( ( -d $long_path_300 or mkpath( $long_path_300 ) ), 'tests_mkpath: mkpath fails > 300 char' ) ;
|
|
#ok( ( -d $long_path_300 and rmtree( $long_path_300 ) ), 'tests_mkpath: rmtree \ > 300 char' ) ;
|
|
} ;
|
|
|
|
return 1 ;
|
|
}
|
|
|
|
sub tests_touch {
|
|
|
|
ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'tests_touch: mkpath W/tmp/tests/' ) ;
|
|
ok( 1 == touch( 'W/tmp/tests/lala'), 'tests_touch: W/tmp/tests/lala') ;
|
|
ok( 1 == touch( 'W/tmp/tests/\y'), 'tests_touch: W/tmp/tests/\y') ;
|
|
ok( 0 == touch( '/no/no/no/aaa'), 'tests_touch: not /aaa') ;
|
|
ok( 1 == touch( 'W/tmp/tests/lili', 'W/tmp/tests/lolo'), 'tests_touch: 2 files') ;
|
|
ok( 0 == touch( 'W/tmp/tests/\y', '/no/no/aaa'), 'tests_touch: 2 files, 1 fails' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
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 {
|
|
|
|
ok( 0 == tmpdir_has_colon_bug( q{} ), 'tmpdir_has_colon_bug: ' ) ;
|
|
ok( 0 == tmpdir_has_colon_bug( '/tmp' ), 'tmpdir_has_colon_bug: /tmp' ) ;
|
|
ok( 1 == tmpdir_has_colon_bug( 'C:' ), 'tmpdir_has_colon_bug: C:' ) ;
|
|
ok( 1 == tmpdir_has_colon_bug( 'C:\temp' ), 'tmpdir_has_colon_bug: C:\temp' ) ;
|
|
|
|
return( 0 ) ;
|
|
}
|
|
|
|
sub tmpdir_has_colon_bug {
|
|
my $path = shift ;
|
|
|
|
my $path_filtered = filter_forbidden_characters( $path ) ;
|
|
if ( $path_filtered ne $path ) {
|
|
( -d $path_filtered ) and myprint( "Path $path was previously mistakely changed to $path_filtered\n" ) ;
|
|
return( 1 ) ;
|
|
}
|
|
return( 0 ) ;
|
|
}
|
|
|
|
sub tmpdir_fix_colon_bug {
|
|
|
|
my $err = 0 ;
|
|
if ( not (-d $tmpdir and -r _ and -w _) ) {
|
|
myprint( "tmpdir $tmpdir is not valid\n" ) ;
|
|
return( 0 ) ;
|
|
}
|
|
my $cachedir_new = "$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 successfuly moved\n" ) ;
|
|
}
|
|
}
|
|
return( not $err ) ;
|
|
}
|
|
|
|
|
|
sub tests_cache_folder {
|
|
|
|
ok( '/path/fold1/fold2' eq cache_folder( q{}, '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ;
|
|
ok( '/pa_th/fold1/fold2' eq cache_folder( q{}, '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ;
|
|
ok( '/_p_a__th/fol_d1/fold2' eq cache_folder( q{}, '/>p<a|*th', 'fol*d1', 'fold2'), 'cache_folder: />p<a|*th, fol*d1, fold2 -> /path/fol_d1/fold2' ) ;
|
|
|
|
ok( 'D:/path/fold1/fold2' eq cache_folder( 'D:', '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ;
|
|
ok( 'D:/pa_th/fold1/fold2' eq cache_folder( 'D:', '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ;
|
|
ok( 'D:/_p_a__th/fol_d1/fold2' eq cache_folder( 'D:', '/>p<a|*th', 'fol*d1', 'fold2'), 'cache_folder: />p<a|*th, fol*d1, fold2 -> /path/fol_d1/fold2' ) ;
|
|
ok( '//' eq cache_folder( q{}, q{}, q{}, q{}), 'cache_folder: -> //' ) ;
|
|
ok( '//_______' eq cache_folder( q{}, q{}, q{}, '*|?:"<>'), 'cache_folder: *|?:"<> -> //_______' ) ;
|
|
return ;
|
|
}
|
|
|
|
sub cache_folder {
|
|
my( $cache_base, $cache_dir, $h1_fold, $h2_fold ) = @_ ;
|
|
|
|
my $sep_1 = $h1_sep || '/';
|
|
my $sep_2 = $h2_sep || '/';
|
|
|
|
#myprint( "$cache_dir h1_fold $h1_fold sep1 $sep_1 h2_fold $h2_fold sep2 $sep_2\n" ) ;
|
|
$h1_fold = convert_sep_to_slash( $h1_fold, $sep_1 ) ;
|
|
$h2_fold = convert_sep_to_slash( $h2_fold, $sep_2 ) ;
|
|
|
|
my $cache_folder = "$cache_base" . filter_forbidden_characters( "$cache_dir/$h1_fold/$h2_fold" ) ;
|
|
#myprint( "cache_folder [$cache_folder]\n" ) ;
|
|
return( $cache_folder ) ;
|
|
}
|
|
|
|
sub filter_forbidden_characters {
|
|
my $string = shift ;
|
|
|
|
if ( 'MSWin32' eq $OSNAME ) {
|
|
# Move trailing whitespace to _ " a b /c d " -> " a b_/c d_"
|
|
$string =~ s{\ (/|$)}{_$1}xg ;
|
|
}
|
|
$string =~ s{[\Q*|?:"<>\E]}{_}xg ;
|
|
#myprint( "[$string]\n" ) ;
|
|
return( $string ) ;
|
|
}
|
|
|
|
sub tests_filter_forbidden_characters {
|
|
|
|
ok( 'a_b' eq filter_forbidden_characters( 'a_b' ), 'filter_forbidden_characters: a_b -> a_b' ) ;
|
|
ok( 'a_b' eq filter_forbidden_characters( 'a*b' ), 'filter_forbidden_characters: a*b -> a_b' ) ;
|
|
ok( 'a_b' eq filter_forbidden_characters( 'a|b' ), 'filter_forbidden_characters: a|b -> a_b' ) ;
|
|
ok( 'a_b' eq filter_forbidden_characters( 'a?b' ), 'filter_forbidden_characters: a?b -> a_b' ) ;
|
|
ok( 'a_______b' eq filter_forbidden_characters( 'a*|?:"<>b' ), 'filter_forbidden_characters: a*|?:"<>b -> a_______b' ) ;
|
|
|
|
SKIP: {
|
|
skip( 'Not on MSWin32', 1 ) if ( 'MSWin32' eq $OSNAME ) ;
|
|
ok( ( 'a b ' eq filter_forbidden_characters( 'a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b "' ) ;
|
|
} ;
|
|
|
|
SKIP: {
|
|
skip( 'Only on MSWin32', 2 ) if ( 'MSWin32' ne $OSNAME ) ;
|
|
ok( ( ' a b_' eq filter_forbidden_characters( ' a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b_"' ) ;
|
|
ok( ( ' a b_/ c d_' eq filter_forbidden_characters( ' a b / c d ' ) ), 'filter_forbidden_characters: " a b / c d " -> "a b_/ c d_"' ) ;
|
|
} ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub convert_sep_to_slash {
|
|
my ( $folder, $sep ) = @_ ;
|
|
|
|
$folder =~ s{\Q$sep\E}{/}xg ;
|
|
return( $folder ) ;
|
|
}
|
|
|
|
sub tests_convert_sep_to_slash {
|
|
|
|
ok(q{} eq convert_sep_to_slash(q{}, '/'), 'convert_sep_to_slash: no folder');
|
|
ok('INBOX' eq convert_sep_to_slash('INBOX', '/'), 'convert_sep_to_slash: INBOX');
|
|
ok('INBOX/foo' eq convert_sep_to_slash('INBOX/foo', '/'), 'convert_sep_to_slash: INBOX/foo');
|
|
ok('INBOX/foo' eq convert_sep_to_slash('INBOX_foo', '_'), 'convert_sep_to_slash: INBOX_foo');
|
|
ok('INBOX/foo/zob' eq convert_sep_to_slash('INBOX_foo_zob', '_'), 'convert_sep_to_slash: INBOX_foo_zob');
|
|
ok('INBOX/foo' eq convert_sep_to_slash('INBOX.foo', '.'), 'convert_sep_to_slash: INBOX.foo');
|
|
ok('INBOX/foo/hi' eq convert_sep_to_slash('INBOX.foo.hi', '.'), 'convert_sep_to_slash: INBOX.foo.hi');
|
|
return ;
|
|
}
|
|
|
|
|
|
sub 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{}),
|
|
'From mbox 1 add colon blank');
|
|
|
|
ok( 'From:<tartanpion@machin.truc>'
|
|
eq regexmess('From <tartanpion@machin.truc>'),
|
|
'From mbox 2 add colo');
|
|
|
|
ok( "\n" . 'From <tartanpion@machin.truc>'
|
|
eq regexmess("\n" . 'From <tartanpion@machin.truc>'),
|
|
'From mbox 3 add colo') ;
|
|
|
|
ok( "From: zzz\n" . 'From <tartanpion@machin.truc>'
|
|
eq regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'),
|
|
'From mbox 4 add colo') ;
|
|
|
|
@regexmess = ( 's{\AFrom\ [^\n]*(\n)?}{}gxms' ) ;
|
|
ok( q{}
|
|
eq regexmess(q{}),
|
|
'From mbox 1 remove, blank');
|
|
|
|
ok( q{}
|
|
eq regexmess('From <tartanpion@machin.truc>'),
|
|
'From mbox 2 remove');
|
|
|
|
ok( "\n" . 'From <tartanpion@machin.truc>'
|
|
eq regexmess("\n" . 'From <tartanpion@machin.truc>'),
|
|
'From mbox 3 remove');
|
|
|
|
#myprint( "[", regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), "]" ) ;
|
|
ok( q{} . 'From <tartanpion@machin.truc>'
|
|
eq regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'),
|
|
'From mbox 4 remove');
|
|
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
From zzz
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Bye.
|
|
EOM
|
|
), '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:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 1 Delete header Disposition-Notification-To:');
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Hello,
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 2 Delete header Disposition-Notification-To:');
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 3 Delete header Disposition-Notification-To:');
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 4 Delete header Disposition-Notification-To:');
|
|
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 5 Delete header Disposition-Notification-To:');
|
|
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 6 Delete header Disposition-Notification-To:');
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 7 Delete header Disposition-Notification-To:');
|
|
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 8 Delete header Disposition-Notification-To:');
|
|
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 9 Delete header Disposition-Notification-To:');
|
|
|
|
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 10 Delete header Disposition-Notification-To:');
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 11 Delete header Disposition-Notification-To:');
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
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:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
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 <gilles.lamiral@laposte.net>
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
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 <gilles.lamiral@laposte.net>
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 15 Delete header Disposition-Notification-To:');
|
|
|
|
|
|
ok(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
X-Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Hello,
|
|
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
|
|
Hello,
|
|
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 16 Delete header Disposition-Notification-To:');
|
|
|
|
ok(
|
|
<<'EOM'
|
|
X-Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Bye.
|
|
EOM
|
|
eq regexmess(
|
|
<<'EOM'
|
|
Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net>
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
Hello,
|
|
|
|
Bye.
|
|
EOM
|
|
),
|
|
'regexmess: 17 Delete header Disposition-Notification-To:');
|
|
|
|
|
|
|
|
# regex to play with Date: from the FAQ
|
|
#@regexmess = 's{\A(.*?(?! ^$))^Date:(.*?)$}{$1Date:$2\nX-Date:$2}gxms'
|
|
|
|
return ;
|
|
|
|
}
|
|
|
|
sub regexmess {
|
|
my ( $string ) = @_ ;
|
|
foreach my $regexmess ( @regexmess ) {
|
|
$debug and myprint( "eval \$string =~ $regexmess\n" ) ;
|
|
my $ret = eval "\$string =~ $regexmess ; 1" ;
|
|
#myprint( "eval [$ret]\n" ) ;
|
|
if ( ( not $ret ) or $@ ) {
|
|
myprint( "Error: eval regexmess '$regexmess': $@" ) ;
|
|
return( undef ) ;
|
|
}
|
|
}
|
|
$debug and myprint( "$string\n" ) ;
|
|
return( $string ) ;
|
|
}
|
|
|
|
|
|
sub 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:<tartanpion@machin.truc>
|
|
|
|
Hello!
|
|
Bye.
|
|
EOM
|
|
),
|
|
'skipmess: 1 match Content-Type: Message/Partial' ) ;
|
|
|
|
ok( 0 == skipmess(
|
|
<<'EOM'
|
|
Date: Sat, 10 Jul 2010 05:34:45 -0700
|
|
From:<tartanpion@machin.truc>
|
|
|
|
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:<tartanpion@machin.truc>
|
|
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:<tartanpion@machin.truc>
|
|
|
|
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:<tartanpion@machin.truc>
|
|
|
|
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:<tartanpion@machin.truc>
|
|
|
|
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:<tartanpion@machin.truc>
|
|
|
|
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: <gilles@lamiral.info>
|
|
Received: by lamiral.info (Postfix, from userid 1000)
|
|
id 21EB12443BF; Mon, 2 Mar 2015 15:38:35 +0100 (CET)
|
|
Subject: test: aethaecohngiexao
|
|
To: <tata@petite.lamiral.info>
|
|
X-Mailer: mail (GNU Mailutils 2.2)
|
|
Message-Id: <20150302143835.21EB12443BF@lamiral.info>
|
|
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: gilles@lamiral.info (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: gilles@lamiral.info (Gilles LAMIRAL)
|
|
Content-Type: message/partial;
|
|
id="TAN_U_P<1404267997.00007489ed17>";
|
|
number=3;
|
|
total=3
|
|
|
|
test: aethaecohngiexao
|
|
EOM
|
|
. "lalala\n" x 3000000
|
|
),
|
|
'skipmess: 10 match Content-Type: Message/Partial' ) ;
|
|
|
|
ok( 0 == skipmess(
|
|
<<'EOM'
|
|
Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET)
|
|
From: gilles@lamiral.info (Gilles LAMIRAL)
|
|
|
|
test: aethaecohngiexao
|
|
EOM
|
|
. "lalala\n" x 3000000
|
|
),
|
|
'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{!#"$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefg\r\n } x 32730
|
|
),
|
|
'skipmess: 12 not match Content-Type: Message/Partial' ) ;
|
|
# Complex regular subexpression recursion limit (32766) exceeded with more lines
|
|
# exit;
|
|
return ;
|
|
}
|
|
|
|
sub skipmess {
|
|
my ( $string ) = @_ ;
|
|
my $match ;
|
|
#myprint( "$string\n" ) ;
|
|
foreach my $skipmess ( @skipmess ) {
|
|
$debug and myprint( "eval \$match = \$string =~ $skipmess\n" ) ;
|
|
my $ret = eval "\$match = \$string =~ $skipmess ; 1" ;
|
|
#myprint( "eval [$ret]\n" ) ;
|
|
$debug and myprint( "match [$match]\n" ) ;
|
|
if ( ( not $ret ) or $@ ) {
|
|
myprint( "Error: eval skipmess '$skipmess': $@" ) ;
|
|
return( undef ) ;
|
|
}
|
|
return( $match ) if ( $match ) ;
|
|
}
|
|
return( $match ) ;
|
|
}
|
|
|
|
|
|
|
|
|
|
sub tests_bytes_display_string {
|
|
|
|
is( 'NA', bytes_display_string( ), 'bytes_display_string: no args => NA' ) ;
|
|
is( 'NA', bytes_display_string( undef ), 'bytes_display_string: undef => NA' ) ;
|
|
is( 'NA', bytes_display_string( 'blabla' ), 'bytes_display_string: blabla => NA' ) ;
|
|
|
|
ok( '0.000 KiB' eq bytes_display_string( 0 ), 'bytes_display_string: 0' ) ;
|
|
ok( '0.001 KiB' eq bytes_display_string( 1 ), 'bytes_display_string: 1' ) ;
|
|
ok( '0.010 KiB' eq bytes_display_string( 10 ), 'bytes_display_string: 10' ) ;
|
|
ok( '1.000 MiB' eq bytes_display_string( 1048575 ), 'bytes_display_string: 1048575' ) ;
|
|
ok( '1.000 MiB' eq bytes_display_string( 1048576 ), 'bytes_display_string: 1048576' ) ;
|
|
|
|
ok( '1.000 GiB' eq bytes_display_string( 1073741823 ), 'bytes_display_string: 1073741823 ' ) ;
|
|
ok( '1.000 GiB' eq bytes_display_string( 1073741824 ), 'bytes_display_string: 1073741824 ' ) ;
|
|
|
|
ok( '1.000 TiB' eq bytes_display_string( 1099511627775 ), 'bytes_display_string: 1099511627775' ) ;
|
|
ok( '1.000 TiB' eq bytes_display_string( 1099511627776 ), 'bytes_display_string: 1099511627776' ) ;
|
|
|
|
ok( '1.000 PiB' eq bytes_display_string( 1125899906842623 ), 'bytes_display_string: 1125899906842623' ) ;
|
|
ok( '1.000 PiB' eq bytes_display_string( 1125899906842624 ), 'bytes_display_string: 1125899906842624' ) ;
|
|
|
|
ok( '1024.000 PiB' eq bytes_display_string( 1152921504606846975 ), 'bytes_display_string: 1152921504606846975' ) ;
|
|
ok( '1024.000 PiB' eq bytes_display_string( 1152921504606846976 ), 'bytes_display_string: 1152921504606846976' ) ;
|
|
|
|
ok( '1048576.000 PiB' eq bytes_display_string( 1180591620717411303424 ), 'bytes_display_string: 1180591620717411303424' ) ;
|
|
|
|
#myprint( bytes_display_string( 1180591620717411303424 ), "\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
sub bytes_display_string {
|
|
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 stats {
|
|
my $sync_loc = shift ;
|
|
|
|
if ( ! $sync_loc->{stats} ) {
|
|
return ;
|
|
}
|
|
|
|
$timeend = time ;
|
|
my $timediff = $timeend - $sync_loc->{timestart} ;
|
|
|
|
my $timeend_str = localtime $timeend ;
|
|
|
|
my $memory_consumption = 0 ;
|
|
$memory_consumption = memory_consumption( ) || 0 ;
|
|
my $memory_ratio = ($max_msg_size_in_bytes) ?
|
|
mysprintf('%.1f', $memory_consumption / $max_msg_size_in_bytes) : 'NA' ;
|
|
|
|
my $host1_reconnect_count = $imap1->Reconnect_counter() || 0 ;
|
|
my $host2_reconnect_count = $imap2->Reconnect_counter() || 0 ;
|
|
|
|
myprint( "++++ Statistics\n" ) ;
|
|
myprint( "Transfer started on : $timestart_str\n" ) ;
|
|
myprint( "Transfer ended on : $timeend_str\n" ) ;
|
|
myprintf( "Transfer time : %.1f sec\n", $timediff ) ;
|
|
myprint( "Folders synced : $h1_folders_wanted_ct/$h1_folders_wanted_nb synced\n" ) ;
|
|
myprint( "Messages transferred : $nb_msg_transferred " ) ;
|
|
myprint( "(could be $nb_msg_skipped_dry_mode without dry mode)" ) if ( $dry ) ;
|
|
myprint( "\n" ) ;
|
|
myprint( "Messages skipped : $nb_msg_skipped\n" ) ;
|
|
myprint( "Messages found duplicate on host1 : $h1_nb_msg_duplicate\n" ) ;
|
|
myprint( "Messages found duplicate on host2 : $h2_nb_msg_duplicate\n" ) ;
|
|
myprint( "Messages void (noheader) on host1 : $h1_nb_msg_noheader\n" ) ;
|
|
myprint( "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n" ) ;
|
|
myprint( "Messages deleted on host1 : $h1_nb_msg_deleted\n" ) ;
|
|
myprint( "Messages deleted on host2 : $h2_nb_msg_deleted\n" ) ;
|
|
myprintf( "Total bytes transferred : %s (%s)\n",
|
|
$total_bytes_transferred,
|
|
bytes_display_string( $total_bytes_transferred ) ) ;
|
|
myprintf( "Total bytes duplicate host1 : %s (%s)\n",
|
|
$h1_total_bytes_duplicate,
|
|
bytes_display_string( $h1_total_bytes_duplicate) ) ;
|
|
myprintf( "Total bytes duplicate host2 : %s (%s)\n",
|
|
$h2_total_bytes_duplicate,
|
|
bytes_display_string( $h2_total_bytes_duplicate) ) ;
|
|
myprintf( "Total bytes skipped : %s (%s)\n",
|
|
$total_bytes_skipped,
|
|
bytes_display_string( $total_bytes_skipped ) ) ;
|
|
myprintf( "Total bytes error : %s (%s)\n",
|
|
$total_bytes_error,
|
|
bytes_display_string( $total_bytes_error ) ) ;
|
|
$timediff ||= 1 ; # No division per 0
|
|
myprintf("Message rate : %.1f messages/s\n", $nb_msg_transferred / $timediff ) ;
|
|
myprintf("Average bandwidth rate : %.1f KiB/s\n", $total_bytes_transferred / $KIBI / $timediff ) ;
|
|
#myprint( "Reconnections to host1 : $host1_reconnect_count\n" ) ;
|
|
#myprint( "Reconnections to host2 : $host2_reconnect_count\n" ) ;
|
|
myprintf("Memory consumption : %.1f MiB\n", $memory_consumption / $KIBI / $KIBI ) ;
|
|
myprintf("Biggest message : %s bytes (%s)\n",
|
|
$max_msg_size_in_bytes,
|
|
bytes_display_string( $max_msg_size_in_bytes) ) ;
|
|
myprint( "Memory/biggest message ratio : $memory_ratio\n" ) ;
|
|
if ( $foldersizesatend and $foldersizes ) {
|
|
|
|
|
|
my $nb_msg_start_diff = diff_or_NA( $h2_nb_msg_start, $h1_nb_msg_start ) ;
|
|
my $bytes_start_diff = diff_or_NA( $h2_bytes_start, $h1_bytes_start ) ;
|
|
|
|
myprintf("Start difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_start_diff,
|
|
$bytes_start_diff,
|
|
bytes_display_string( $bytes_start_diff ) ) ;
|
|
|
|
my $nb_msg_end_diff = diff_or_NA( $h2_nb_msg_end, $h1_nb_msg_end ) ;
|
|
my $bytes_end_diff = diff_or_NA( $h2_bytes_end, $h1_bytes_end ) ;
|
|
|
|
myprintf("Final difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_end_diff,
|
|
$bytes_end_diff,
|
|
bytes_display_string( $bytes_end_diff ) ) ;
|
|
}
|
|
myprint( "Detected $sync->{nb_errors} errors\n\n" ) ;
|
|
|
|
myprint( $warn_release, "\n" ) ;
|
|
myprint( thank_author( ) ) ;
|
|
return ;
|
|
}
|
|
|
|
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]?/ ) {
|
|
return 1 ;
|
|
}
|
|
else {
|
|
return 0 ;
|
|
}
|
|
}
|
|
|
|
|
|
sub 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' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub 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' ) ;
|
|
return ;
|
|
}
|
|
|
|
sub thank_author {
|
|
return( "Homepage: http://imapsync.lamiral.info/\n" ) ;
|
|
}
|
|
|
|
|
|
sub load_modules {
|
|
|
|
if ( $ssl1 or $ssl2 or $tls1 or $tls2) {
|
|
# not yet a "use" statement
|
|
require IO::Socket::SSL ;
|
|
if ( $sync->{inet4} ) {
|
|
IO::Socket::SSL->import( 'inet4' ) ;
|
|
}
|
|
if ( $sync->{inet6} ) {
|
|
IO::Socket::SSL->import( 'inet6' ) ;
|
|
}
|
|
}
|
|
|
|
if ( ( ( not( $password1 or $passfile1 ) )
|
|
or (not ( $password2 or $passfile2 ) )
|
|
)
|
|
and ( not $help ) ) {
|
|
# now a "use" statement
|
|
#require Term::ReadKey ;
|
|
}
|
|
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub parse_header_msg {
|
|
my ( $imap, $m_uid, $s_heads, $s_fir, $side, $s_hash ) = @_ ;
|
|
|
|
my $head = $s_heads->{$m_uid} ;
|
|
my $headnum = scalar keys %{ $head } ;
|
|
$debug and myprint( "$side uid $m_uid head nb pass one: ", $headnum, "\n" ) ;
|
|
|
|
if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){
|
|
myprint( "$side uid $m_uid no header by parse_headers so taking whole header with BODY.PEEK[HEADER]\n" ) ;
|
|
$imap->fetch($m_uid, 'BODY.PEEK[HEADER]' ) ;
|
|
my $whole_header = $imap->_transaction_literals ;
|
|
|
|
#myprint( $whole_header ) ;
|
|
$head = decompose_header( $whole_header ) ;
|
|
|
|
$headnum = scalar keys %{ $head } ;
|
|
$debug and myprint( "$side uid $m_uid head nb pass two: ", $headnum, "\n" ) ;
|
|
}
|
|
|
|
#myprint( Data::Dumper->Dump( [ $head, \%useheader ] ) ) ;
|
|
|
|
my $headstr ;
|
|
|
|
$headstr = header_construct( $head, $side, $m_uid ) ;
|
|
|
|
if ( ( ! $headstr) and ( $addheader ) and ( $side eq 'Host1' ) ) {
|
|
my $header = add_header( $m_uid ) ;
|
|
myprint( "Host1 uid $m_uid no header found so adding our own [$header]\n" ) ;
|
|
$headstr .= uc $header ;
|
|
$s_fir->{$m_uid}->{NO_HEADER} = 1;
|
|
}
|
|
|
|
return if ( ! $headstr ) ;
|
|
|
|
my $size = $s_fir->{$m_uid}->{'RFC822.SIZE'} ;
|
|
my $flags = $s_fir->{$m_uid}->{'FLAGS'} ;
|
|
my $idate = $s_fir->{$m_uid}->{'INTERNALDATE'} ;
|
|
$size = length $headstr unless ( $size ) ;
|
|
my $m_md5 = md5_base64( $headstr ) ;
|
|
$debug and myprint( "$side uid $m_uid sig $m_md5 size $size idate $idate\n" ) ;
|
|
my $key ;
|
|
if ($skipsize) {
|
|
$key = "$m_md5";
|
|
}
|
|
else {
|
|
$key = "$m_md5:$size";
|
|
}
|
|
# 0 return code is used to identify duplicate message hash
|
|
return 0 if exists $s_hash->{"$key"};
|
|
$s_hash->{"$key"}{'5'} = $m_md5;
|
|
$s_hash->{"$key"}{'s'} = $size;
|
|
$s_hash->{"$key"}{'D'} = $idate;
|
|
$s_hash->{"$key"}{'F'} = $flags;
|
|
$s_hash->{"$key"}{'m'} = $m_uid;
|
|
|
|
return( 1 ) ;
|
|
}
|
|
|
|
sub header_construct {
|
|
|
|
my( $head, $side, $m_uid ) = @_ ;
|
|
|
|
my $headstr ;
|
|
foreach my $h ( sort keys %{ $head } ) {
|
|
next if ( not ( exists $useheader{ uc $h } )
|
|
and ( not exists $useheader{ 'ALL' } )
|
|
) ;
|
|
foreach my $val ( sort @{$head->{$h}} ) {
|
|
|
|
my $H = header_line_normalize( $h, $val ) ;
|
|
|
|
# show stuff in debug mode
|
|
$debug and myprint( "$side uid $m_uid header [$H]", "\n" ) ;
|
|
|
|
if ($skipheader and $H =~ m/$skipheader/xi) {
|
|
$debug and myprint( "$side uid $m_uid skipping header [$H]\n" ) ;
|
|
next ;
|
|
}
|
|
$headstr .= "$H" ;
|
|
}
|
|
}
|
|
return( $headstr ) ;
|
|
}
|
|
|
|
|
|
sub header_line_normalize {
|
|
my( $header_key, $header_val ) = @_ ;
|
|
|
|
# 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 {
|
|
|
|
ok( ': ' eq header_line_normalize( q{}, q{} ), 'header_line_normalize: empty args' ) ;
|
|
ok( 'HHH: VVV' eq header_line_normalize( 'hhh', 'vvv' ), 'header_line_normalize: hhh vvv ' ) ;
|
|
ok( 'HHH: VVV' eq header_line_normalize( 'hhh', ' vvv' ), 'header_line_normalize: remove first blancs' ) ;
|
|
ok( 'HHH: AA BB CCC D' eq header_line_normalize( 'hhh', 'aa bb ccc d' ), 'header_line_normalize: remove succesive blanks' ) ;
|
|
ok( 'HHH: AA BB CCC' eq header_line_normalize( 'hhh', 'aa bb ccc ' ), 'header_line_normalize: remove last blanks' ) ;
|
|
ok( 'HHH: VVV XX YY' eq header_line_normalize( 'hhh', "vvv\t\txx\tyy" ), 'header_line_normalize: tabs' ) ;
|
|
ok( 'HHH: XABX' eq header_line_normalize( 'hhh', "\x80AB\xff" ), 'header_line_normalize: 8bit' ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
|
|
sub firstline {
|
|
# extract the first line of a file (without \n)
|
|
|
|
my( $file ) = @_ ;
|
|
my $line = q{} ;
|
|
my $FILE ;
|
|
open $FILE, '<', $file or do {
|
|
myprint( "Error opening file $file : $!\n" ) ;
|
|
return ;
|
|
} ;
|
|
$line = <$FILE> || q{} ;
|
|
close $FILE ;
|
|
chomp $line ;
|
|
return $line ;
|
|
}
|
|
|
|
sub tests_firstline {
|
|
is( 1 , string_to_file( "blabla\n", 'tmp/firstline.txt' ), 'tests_firstline: put blabla in tmp/firstline.txt' ) ;
|
|
is( 'blabla' , firstline( 'tmp/firstline.txt' ), 'tests_firstline: get blabla from tmp/firstline.txt' ) ;
|
|
is( undef , firstline( 'tmp/noexist.txt' ), 'tests_firstline: get blabla from tmp/noexist.txt' ) ;
|
|
is( 1 , string_to_file( q{}, 'tmp/firstline2.txt' ), 'tests_firstline: put empty string in tmp/firstline2.txt' ) ;
|
|
is( q{} , firstline( 'tmp/firstline2.txt' ), 'tests_firstline: get empty string from tmp/firstline2.txt' ) ;
|
|
is( 1 , string_to_file( "\n", 'tmp/firstline3.txt' ), 'tests_firstline: put CR in tmp/firstline3.txt' ) ;
|
|
is( q{} , firstline( 'tmp/firstline3.txt' ), 'tests_firstline: get empty string from tmp/firstline3.txt' ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
|
|
sub file_to_string {
|
|
my( $file ) = @_ ;
|
|
my @string ;
|
|
open my $FILE, '<', $file or die_clean( "Error with file $file : $! " ) ;
|
|
@string = <$FILE> ;
|
|
close $FILE ;
|
|
return( join q{}, @string ) ;
|
|
}
|
|
|
|
|
|
sub string_to_file {
|
|
my( $string, $file ) = @_ ;
|
|
sysopen( FILE, $file, O_WRONLY|O_TRUNC|O_CREAT, 0600) or die_clean( "$! $file" ) ;
|
|
print FILE $string ;
|
|
close FILE ;
|
|
return 1 ;
|
|
}
|
|
|
|
q^
|
|
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.
|
|
^ if 0 ; # End of multiline comment.
|
|
|
|
sub pipemess {
|
|
my ( $string, @commands ) = @_ ;
|
|
my $error = q{} ;
|
|
foreach my $command ( @commands ) {
|
|
my $input_tmpfile = "$tmpdir/imapsync_tmp_file.$PROCESS_ID.inp.txt" ;
|
|
my $output_tmpfile = "$tmpdir/imapsync_tmp_file.$PROCESS_ID.out.txt" ;
|
|
my $error_tmpfile = "$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 {
|
|
|
|
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{Failure: --pipemess command "true" ended with "0" characters exit value "0" and STDERR ""}, 'pipemess: list context, true but no output, error' ) ;
|
|
|
|
( $stringT, $errorT ) = pipemess( 'dontcare', 'false' ) ;
|
|
is( $stringT, undef, 'pipemess: list context, false and no output, string' ) ;
|
|
like( $errorT, qr{Failure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""}, 'pipemess: list context, false and no output, error' ) ;
|
|
|
|
( $stringT, $errorT ) = pipemess( 'dontcare', 'echo -n blablabla' ) ;
|
|
is( $stringT, q{blablabla}, 'pipemess: list context, "echo -n blablabla", string' ) ;
|
|
is( $errorT, q{}, 'pipemess: list context, "echo blablabla", error' ) ;
|
|
|
|
|
|
( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ;
|
|
is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla", string' ) ;
|
|
like( $errorT, qr{blablabla"$}, 'pipemess: list context, "no output STDERR blablabla", error' ) ;
|
|
|
|
|
|
( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )', 'false' ) ;
|
|
is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla then false", string' ) ;
|
|
like( $errorT, qr{blablabla"$}, 'pipemess: list context, "no output STDERR blablabla then false", error' ) ;
|
|
|
|
( $stringT, $errorT ) = pipemess( 'dontcare', 'false', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ;
|
|
is( $stringT, undef, 'pipemess: list context, "false then STDERR blablabla", string' ) ;
|
|
like( $errorT, qr{Failure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""}, 'pipemess: list context, "false then STDERR blablabla", error' ) ;
|
|
|
|
( $stringT, $errorT ) = pipemess( 'dontcare', '( echo rrrrr ; echo -n error_blablabla 3>&1 1>&2 2>&3 )' ) ;
|
|
like( $stringT, qr{rrrrr}, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", string' ) ;
|
|
like( $errorT, qr{STDERR.*error_blablabla}, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", error' ) ;
|
|
|
|
}
|
|
|
|
( $stringT, $errorT ) = pipemess( 'dontcare', 'cacaprout' ) ;
|
|
is( $stringT, undef, 'pipemess: list context, cacaprout not found, string' ) ;
|
|
like( $errorT, qr{Failure: --pipemess command "cacaprout" ended with "0" characters exit value.*}, 'pipemess: list context, cacaprout not found, error' ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub tests_is_a_release_number {
|
|
ok(is_a_release_number($RELEASE_NUMBER_EXAMPLE_1), 'is_a_release_number 1.351') ;
|
|
ok(is_a_release_number($RELEASE_NUMBER_EXAMPLE_2), 'is_a_release_number 42.4242') ;
|
|
ok(is_a_release_number(imapsync_version()), 'is_a_release_number imapsync_version()') ;
|
|
ok(! is_a_release_number('blabla' ), '! is_a_release_number blabla') ;
|
|
return ;
|
|
}
|
|
|
|
sub is_a_release_number {
|
|
my $number = shift;
|
|
|
|
return( $number =~ m{^\d+\.\d+$}xo ) ;
|
|
}
|
|
|
|
sub check_last_release {
|
|
|
|
my $public_release = not_long_imapsync_version_public( ) ;
|
|
$debug and myprint( "check_last_release: [$public_release]\n" ) ;
|
|
return('unknown') if ($public_release eq 'unknown') ;
|
|
return('timeout') if ($public_release eq 'timeout') ;
|
|
return('unknown') if (! is_a_release_number( $public_release ) ) ;
|
|
|
|
my $imapsync_here = imapsync_version();
|
|
|
|
if ($public_release > $imapsync_here) {
|
|
return("New imapsync release $public_release available");
|
|
}else{
|
|
return( 'This imapsync is up to date') ;
|
|
}
|
|
}
|
|
|
|
sub imapsync_version {
|
|
my $rcs_imapsync = '$Id: imapsync,v 1.727 2016/08/19 10:30:36 gilles Exp gilles $ ' ;
|
|
my $imapsync_version ;
|
|
|
|
if ( $rcs_imapsync =~ m{,v\s+(\d+\.\d+)}xo ) {
|
|
$imapsync_version = $1
|
|
} else {
|
|
$imapsync_version = 'UNKNOWN' ;
|
|
}
|
|
return( $imapsync_version ) ;
|
|
}
|
|
|
|
sub tests_imapsync_basename {
|
|
ok( imapsync_basename() =~ m/imapsync/, 'imapsync_basename: match imapsync');
|
|
ok( 'blabla' ne imapsync_basename(), 'imapsync_basename: do not equal blabla');
|
|
return ;
|
|
}
|
|
|
|
sub imapsync_basename {
|
|
|
|
return basename($0);
|
|
|
|
}
|
|
|
|
sub imapsync_version_public {
|
|
|
|
my $local_version = imapsync_version();
|
|
my $imapsync_basename = imapsync_basename();
|
|
my $agent_info = "$OSNAME system, perl "
|
|
. mysprintf( '%vd', $PERL_VERSION)
|
|
. ", Mail::IMAPClient $Mail::IMAPClient::VERSION"
|
|
. " $imapsync_basename";
|
|
my $sock = IO::Socket::INET->new(
|
|
PeerAddr => 'imapsync.lamiral.info',
|
|
PeerPort => 80,
|
|
Proto => 'tcp',
|
|
) ;
|
|
return( 'unknown' ) if not $sock ;
|
|
print $sock
|
|
"GET /prj/imapsync/VERSION HTTP/1.0\n",
|
|
"User-Agent: imapsync/$local_version ($agent_info)\n",
|
|
"Host: ks.lamiral.info\n\n";
|
|
my @line = <$sock>;
|
|
close $sock ;
|
|
my $last_release = $line[$LAST];
|
|
chomp $last_release ;
|
|
return($last_release) ;
|
|
}
|
|
|
|
sub not_long_imapsync_version_public {
|
|
#myprint( "Entering not_long_imapsync_version_public\n" ) ;
|
|
|
|
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: $!\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 $@ ) {
|
|
#myprint( "$@" ) ;
|
|
if ($@ =~ /alarm/) {
|
|
# timed out
|
|
return('timeout');
|
|
}else{
|
|
alarm 0 ;
|
|
return('unknown'); # propagate unexpected errors
|
|
}
|
|
}else {
|
|
# Good!
|
|
return($val);
|
|
}
|
|
}
|
|
|
|
sub localhost_info {
|
|
|
|
my($infos) = join q{},
|
|
"Here is a [$OSNAME] system (",
|
|
join(q{ },
|
|
uname(),
|
|
),
|
|
")\n",
|
|
'with Perl ',
|
|
mysprintf( '%vd', $PERL_VERSION),
|
|
" Mail::IMAPClient $Mail::IMAPClient::VERSION",
|
|
;
|
|
return($infos) ;
|
|
}
|
|
|
|
sub memory_consumption {
|
|
# memory consumed by imapsync until now in bytes
|
|
return( ( memory_consumption_of_pids( ) )[0] );
|
|
}
|
|
|
|
sub tests_memory_consumption {
|
|
|
|
like( memory_consumption( ), qr{\d+},'memory_consumption no args') ;
|
|
like( memory_consumption( 1 ), qr{\d+},'memory_consumption 1') ;
|
|
like( memory_consumption( $PROCESS_ID ), qr{\d+},"memory_consumption_of_pids $PROCESS_ID") ;
|
|
|
|
like( memory_consumption_ratio(), qr{\d+}, 'memory_consumption_ratio' ) ;
|
|
like( memory_consumption_ratio(1), qr{\d+}, 'memory_consumption_ratio 1' ) ;
|
|
like( memory_consumption_ratio(10), qr{\d+}, 'memory_consumption_ratio 10' ) ;
|
|
|
|
like( memory_consumption(), qr{\d+}, "memory_consumption\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub memory_consumption_of_pids {
|
|
|
|
my @pid = @_;
|
|
@pid = (@pid) ? @pid : ($PROCESS_ID) ;
|
|
|
|
#myprint( "PIDs: @pid\n" ) ;
|
|
my @val;
|
|
if ('MSWin32' eq $OSNAME) {
|
|
@val = memory_consumption_of_pids_win32(@pid);
|
|
}else{
|
|
# Unix
|
|
my @ps = qx{ ps -o vsz -p @pid } ;
|
|
#myprint( @ps ) ;
|
|
#my @ps = backtick( "ps -o vsz -p @pid" ) ;
|
|
shift @ps; # First line is column name "VSZ"
|
|
chomp @ps;
|
|
# convert to octets
|
|
|
|
@val = map { $_ * $KIBI } @ps;
|
|
}
|
|
return( @val ) ;
|
|
}
|
|
|
|
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 reading the tasklist documentation
|
|
#@ps = qx{ tasklist /FI "PID eq @PID" };
|
|
|
|
my @ps = qx{ tasklist /NH /FO CSV } ;
|
|
#my @ps = backtick( 'tasklist /NH /FO CSV' ) ;
|
|
#myprint( "-" x $STD_CHAR_PER_LINE, "\n", @ps, "-" x $STD_CHAR_PER_LINE, "\n" ) ;
|
|
my @val;
|
|
foreach my $line (@ps) {
|
|
my($name, $pid, $mem) = (split ',', $line )[0,1,4];
|
|
next if (! $pid);
|
|
#myprint( "[$name][$pid][$mem]" ) ;
|
|
if ($PID{remove_qq($pid)}) {
|
|
#myprint( "MATCH !\n" ) ;
|
|
chomp $mem ;
|
|
$mem = remove_qq($mem);
|
|
$mem = remove_Ko($mem);
|
|
$mem = remove_not_num($mem);
|
|
#myprint( "[$mem]\n" ) ;
|
|
push @val, $mem * $KIBI;
|
|
}
|
|
}
|
|
return(@val);
|
|
}
|
|
|
|
sub backtick {
|
|
my $command = shift ;
|
|
my ( $writer, $reader, $err ) ;
|
|
my @output ;
|
|
open3( $writer, $reader, $err, $command ) ;
|
|
@output = <$reader>; #Output here
|
|
#my @errors = <$err>; #Errors here, instead of the console
|
|
$debugdev and myprint( @output ) ;
|
|
return( @output ) ;
|
|
}
|
|
|
|
sub tests_backtick {
|
|
|
|
SKIP: {
|
|
skip( 'Tests for MSWin32', 3 ) if ('MSWin32' ne $OSNAME) ;
|
|
my @output ;
|
|
@output = backtick( 'echo Hello World!' ) ;
|
|
# Add \r on Windows.
|
|
ok( "Hello World!\r\n" eq $output[0], 'backtick: echo Hello World!' ) ;
|
|
$debug and myprint( "[@output]" ) ;
|
|
@output = backtick( 'echo Hello & echo World!' ) ;
|
|
ok( "Hello \r\n" eq $output[0], 'backtick: echo Hello & echo World!' ) ;
|
|
ok( "World!\r\n" eq $output[1], 'backtick: echo Hello & echo World!' ) ;
|
|
$debug and myprint( "[@output][$output[0]][$output[1]]" ) ;
|
|
} ;
|
|
SKIP: {
|
|
skip( 'Tests for Unix', 3 ) if ('MSWin32' eq $OSNAME) ;
|
|
my @output ;
|
|
@output = backtick( 'echo Hello World!' ) ;
|
|
ok( "Hello World!\n" eq $output[0], 'backtick: echo Hello World!' ) ;
|
|
$debug and myprint( "[@output]" ) ;
|
|
@output = backtick( "echo Hello\necho World!" ) ;
|
|
ok( "Hello\n" eq $output[0], 'backtick: echo Hello; echo World!' ) ;
|
|
ok( "World!\n" eq $output[1], 'backtick: echo Hello; echo World!' ) ;
|
|
$debug and myprint( "[@output]" ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub remove_not_num {
|
|
|
|
my $string = shift;
|
|
$string =~ tr/0-9//cd;
|
|
#myprint( "tr [$string]\n" ) ;
|
|
return($string);
|
|
}
|
|
|
|
sub tests_remove_not_num {
|
|
|
|
ok('123' eq remove_not_num(123), 'remove_not_num( 123 )' ) ;
|
|
ok('123' eq remove_not_num('123'), q{remove_not_num( '123' )} ) ;
|
|
ok('123' eq remove_not_num('12 3'), q{remove_not_num( '12 3' )} ) ;
|
|
ok('123' eq remove_not_num('a 12 3 Ko'), q{remove_not_num( 'a 12 3 Ko' )} ) ;
|
|
return ;
|
|
}
|
|
|
|
sub remove_Ko {
|
|
my $string = shift;
|
|
if ($string =~ /^(.*)\sKo$/xo) {
|
|
return($1);
|
|
}else{
|
|
return($string);
|
|
}
|
|
}
|
|
|
|
sub remove_qq {
|
|
my $string = shift;
|
|
if ($string =~ /^"(.*)"$/xo) {
|
|
return($1);
|
|
}else{
|
|
return($string);
|
|
}
|
|
}
|
|
|
|
sub memory_consumption_ratio {
|
|
|
|
my ($base) = @_;
|
|
$base ||= 1;
|
|
my $consu = memory_consumption();
|
|
return($consu / $base);
|
|
}
|
|
|
|
|
|
sub date_from_rcs {
|
|
my $d = shift ;
|
|
|
|
my %num2mon = qw( 01 Jan 02 Feb 03 Mar 04 Apr 05 May 06 Jun 07 Jul 08 Aug 09 Sep 10 Oct 11 Nov 12 Dec ) ;
|
|
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 {
|
|
ok('19-Sep-2015 16:11:07 +0000'
|
|
eq date_from_rcs('Date: 2015/09/19 16:11:07 '), 'date_from_rcs from RCS date' ) ;
|
|
return ;
|
|
}
|
|
|
|
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 ;
|
|
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 {
|
|
|
|
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' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub 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}');
|
|
|
|
return ;
|
|
}
|
|
|
|
sub list_keys_in_2_not_in_1 {
|
|
|
|
my $folders1_ref = shift;
|
|
my $folders2_ref = shift;
|
|
my @list;
|
|
|
|
foreach my $folder ( sort keys %{ $folders2_ref } ) {
|
|
next if exists $folders1_ref->{$folder};
|
|
push @list, $folder;
|
|
}
|
|
return(@list);
|
|
}
|
|
|
|
|
|
sub list_folders_in_2_not_in_1 {
|
|
|
|
my (@h2_folders_not_in_h1, %h2_folders_not_in_h1) ;
|
|
@h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h1_folders_all, \%h2_folders_all) ;
|
|
map { $h2_folders_not_in_h1{$_} = 1} @h2_folders_not_in_h1 ;
|
|
@h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h2_folders_from_1_all, \%h2_folders_not_in_h1) ;
|
|
|
|
return( reverse @h2_folders_not_in_h1 );
|
|
}
|
|
|
|
sub 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 = $dry ; # always success in dry mode!
|
|
$imap2->unsubscribe( $folder ) if ( ! $dry ) ;
|
|
$res = $imap2->delete( $folder ) if ( ! $dry ) ;
|
|
if ( $res ) {
|
|
myprint( "Deleted $folder", "$dry_message", "\n" ) ;
|
|
}else{
|
|
myprint( "Deleting $folder failed", "\n" ) ;
|
|
}
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub delete_folder {
|
|
my ( $sync, $imap, $folder, $Side ) = @_ ;
|
|
if ( ! $sync ) { return ; }
|
|
if ( ! $imap ) { return ; }
|
|
if ( ! $folder ) { return ; }
|
|
$Side ||= 'HostX' ;
|
|
|
|
my $res = $sync->{dry} ; # always success in dry mode!
|
|
if ( ! $sync->{dry} ) {
|
|
$imap->unsubscribe( $folder ) ;
|
|
$res = $imap->delete( $folder ) ;
|
|
}
|
|
if ( $res ) {
|
|
myprint( "$Side deleted $folder", $sync->{dry_message}, "\n" ) ;
|
|
return 1 ;
|
|
}else{
|
|
myprint( "$Side deleting $folder failed", "\n" ) ;
|
|
return ;
|
|
}
|
|
}
|
|
|
|
sub delete1emptyfolders {
|
|
my $sync = shift ;
|
|
if ( ! $sync ) { return ; } # abort if no parameter
|
|
if ( ! $sync->{delete1emptyfolders} ) { return ; } # abort if --delete1emptyfolders off
|
|
my $imap = $sync->{imap1} ;
|
|
if ( ! $imap ) { return ; } # abort if no imap
|
|
if ( $imap->IsUnconnected( ) ) { return ; } # abort if diesconnected
|
|
|
|
my %folders_kept ;
|
|
myprint( qq{Host1 deleting empty folders\n} ) ;
|
|
foreach my $folder ( reverse sort @{ $sync->{h1_folders_wanted} } ) {
|
|
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( $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( $sync, $imap, $folder, 'Host1' ) ) {
|
|
next ; # Deleted, good!
|
|
}else{
|
|
$folders_kept{ $folder }++ ;
|
|
next ; # Not deleted, bad!
|
|
}
|
|
}
|
|
remove_deleted_folders_from_wanted_list( $sync, %folders_kept ) ;
|
|
myprint( qq{Host1 ended deleting empty folders\n} ) ;
|
|
return ;
|
|
}
|
|
|
|
sub remove_deleted_folders_from_wanted_list {
|
|
my ( $sync, %folders_kept ) = @ARG ;
|
|
|
|
my @h1_folders_wanted_init = @{ $sync->{h1_folders_wanted} } ;
|
|
my @h1_folders_wanted_last ;
|
|
foreach my $folder ( @h1_folders_wanted_init ) {
|
|
if ( $folders_kept{ $folder } ) {
|
|
push @h1_folders_wanted_last, $folder ;
|
|
}
|
|
}
|
|
@{ $sync->{h1_folders_wanted} } = @h1_folders_wanted_last ;
|
|
return ;
|
|
}
|
|
|
|
sub examine_folder_and_count {
|
|
my ( $imap, $folder, $Side ) = @_ ;
|
|
$Side ||= 'HostX' ;
|
|
|
|
if ( ! examine_folder( $imap, $folder, $Side ) ) {
|
|
return ;
|
|
}
|
|
my $nb_messages_select = count_from_select( $imap->History ) ;
|
|
return $nb_messages_select ;
|
|
}
|
|
|
|
|
|
sub 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 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}
|
|
) ;
|
|
|
|
|
|
|
|
|
|
return ;
|
|
}
|
|
|
|
sub tests_delete1emptyfolders_unit {
|
|
my $syncT = shift ;
|
|
my $folders1wanted_init_ref = shift ;
|
|
my $folders1wanted_after_ref = shift ;
|
|
my $comment = shift || q{delete1emptyfolders:} ;
|
|
|
|
my @folders1wanted_init = @{ $folders1wanted_init_ref } ;
|
|
my @folders1wanted_after = @{ $folders1wanted_after_ref } ;
|
|
|
|
@{ $syncT->{h1_folders_wanted} } = @folders1wanted_init ;
|
|
|
|
is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_init, qq{$comment, init check} ) ;
|
|
delete1emptyfolders( $syncT ) ;
|
|
is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_after, qq{$comment, after check} ) ;
|
|
return ;
|
|
}
|
|
|
|
sub extract_header {
|
|
my $string = shift ;
|
|
|
|
my ( $header ) = split /\n\n/x, $string ;
|
|
if ( ! $header ) { return( q{} ) ; }
|
|
#myprint( "[$header]\n" ) ;
|
|
return( $header ) ;
|
|
}
|
|
|
|
sub tests_extract_header {
|
|
|
|
|
|
my $h = <<'EOM';
|
|
Message-Id: <20100428101817.A66CB162474E@plume.est.belle>
|
|
Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST)
|
|
From: gilles@louloutte.dyndns.org (Gilles LAMIRAL)
|
|
EOM
|
|
chomp $h ;
|
|
ok( $h eq extract_header(
|
|
<<'EOM'
|
|
Message-Id: <20100428101817.A66CB162474E@plume.est.belle>
|
|
Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST)
|
|
From: gilles@louloutte.dyndns.org (Gilles LAMIRAL)
|
|
|
|
body
|
|
lalala
|
|
EOM
|
|
), 'extract_header: 1') ;
|
|
|
|
|
|
|
|
return ;
|
|
}
|
|
|
|
sub decompose_header{
|
|
my $string = shift ;
|
|
|
|
# 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{
|
|
|
|
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: <20100428101817.A66CB162474E@plume.est.belle>
|
|
Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST)
|
|
From: gilles@louloutte.dyndns.org (Gilles LAMIRAL)
|
|
EOH
|
|
) ;
|
|
|
|
ok( '<20100428101817.A66CB162474E@plume.est.belle>'
|
|
eq $header_dec->{ 'Message-Id' }[0], 'decompose_header: 1' ) ;
|
|
|
|
$header_dec = decompose_header(
|
|
<<'EOH'
|
|
Return-Path: <gilles@louloutte.dyndns.org>
|
|
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_++' ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub epoch {
|
|
# incoming format:
|
|
# internal date 24-Aug-2010 16:00:00 +0200
|
|
|
|
# outgoing format: epoch
|
|
|
|
|
|
my $d = shift ;
|
|
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 ) ;
|
|
|
|
$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_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' ) ;
|
|
return ;
|
|
}
|
|
|
|
sub add_header {
|
|
my $header_uid = shift || 'mistake' ;
|
|
my $header_Message_Id = 'Message-Id: <' . $header_uid . '@imapsync>' ;
|
|
return( $header_Message_Id ) ;
|
|
}
|
|
|
|
sub tests_add_header {
|
|
ok( 'Message-Id: <mistake@imapsync>' eq add_header(), 'add_header no arg' ) ;
|
|
ok( 'Message-Id: <123456789@imapsync>' eq add_header(123456789), 'add_header 123456789' ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub tests_Banner{
|
|
|
|
my $imap = Mail::IMAPClient->new( ) ;
|
|
ok( 'lalala' eq $imap->Banner('lalala'), 'Banner set lalala' ) ;
|
|
ok( 'lalala' eq $imap->Banner(), 'Banner returns lalala' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
|
|
sub max_line_length {
|
|
my $string = shift ;
|
|
my $max = 0 ;
|
|
|
|
while ( $string =~ m/([^\n]*\n?)/msxg ) {
|
|
$max = max( $max, length $1 ) ;
|
|
}
|
|
return( $max ) ;
|
|
}
|
|
|
|
sub tests_max_line_length {
|
|
ok( 0 == max_line_length( q{} ), 'max_line_length: 0 == null string' ) ;
|
|
ok( 1 == max_line_length( "\n" ), 'max_line_length: 1 == \n' ) ;
|
|
ok( 1 == max_line_length( "\n\n" ), 'max_line_length: 1 == \n\n' ) ;
|
|
ok( 1 == max_line_length( "\n" x 500 ), 'max_line_length: 1 == 500 \n' ) ;
|
|
ok( 1 == max_line_length( 'a' ), 'max_line_length: 1 == a' ) ;
|
|
ok( 2 == max_line_length( "a\na" ), 'max_line_length: 2 == a\na' ) ;
|
|
ok( 2 == max_line_length( "a\na\n" ), 'max_line_length: 2 == a\na\n' ) ;
|
|
ok( 3 == max_line_length( "a\nab\n" ), 'max_line_length: 3 == a\nab\n' ) ;
|
|
ok( 3 == max_line_length( "a\nab\n" x 10000 ), 'max_line_length: 3 == 10000 a\nab\n' ) ;
|
|
ok( 3 == max_line_length( "a\nab\nabc" ), 'max_line_length: 3 == a\nab\nabc' ) ;
|
|
|
|
ok( 4 == max_line_length( "a\nab\nabc\n" ), 'max_line_length: 4 == a\nab\nabc\n' ) ;
|
|
ok( 5 == max_line_length( "a\nabcd\nabc\n" ), 'max_line_length: 5 == a\nabcd\nabc\n' ) ;
|
|
ok( 5 == max_line_length( "a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd" ), 'max_line_length: 5 == a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd' ) ;
|
|
return ;
|
|
}
|
|
|
|
sub setlogfile {
|
|
my( $mysync ) = shift ;
|
|
$mysync->{logdir} = defined $mysync->{logdir} ? $mysync->{logdir} : 'LOG_imapsync' ;
|
|
$mysync->{logfile} = defined $mysync->{logfile} ? "$mysync->{logdir}/$mysync->{logfile}" :
|
|
logfile( $mysync->{timestart}, $mysync->{user2}, $mysync->{logdir} ) ;
|
|
#myprint( "logdir = $mysync->{logdir}\n" ) ;
|
|
#myprint( "logfile = $mysync->{logfile}\n" ) ;
|
|
return( $mysync->{logfile} ) ;
|
|
}
|
|
|
|
sub tests_setlogfile {
|
|
my $mysync = {
|
|
timestart => 2,
|
|
user2 => 'user2',
|
|
} ;
|
|
|
|
ok( 'LOG_imapsync/1970_01_01_01_00_02_user2.txt' eq setlogfile( $mysync ),
|
|
'setlogfile: default is like LOG_imapsync/1970_01_01_01_00_02_user2.txt' ) ;
|
|
|
|
$mysync->{logdir} = undef ;
|
|
$mysync->{logfile} = undef ;
|
|
ok( 'LOG_imapsync/1970_01_01_01_00_02_user2.txt' eq setlogfile( $mysync ),
|
|
'setlogfile: logdir undef, LOG_imapsync/1970_01_01_01_00_02_user2.txt' ) ;
|
|
|
|
$mysync->{logdir} = q{} ;
|
|
$mysync->{logfile} = undef ;
|
|
ok( '1970_01_01_01_00_02_user2.txt' eq setlogfile( $mysync ),
|
|
'setlogfile: logdir empty, 1970_01_01_01_00_02_user2.txt' ) ;
|
|
|
|
$mysync->{logdir} = 'vallogdir' ;
|
|
$mysync->{logfile} = undef ;
|
|
ok( 'vallogdir/1970_01_01_01_00_02_user2.txt' eq setlogfile( $mysync ),
|
|
'setlogfile: logdir vallogdir, vallogdir/1970_01_01_01_00_02_user2.txt' ) ;
|
|
|
|
$mysync->{logdir} = 'vallogdir' ;
|
|
$mysync->{logfile} = 'vallogfile.txt' ;
|
|
ok( 'vallogdir/vallogfile.txt' eq setlogfile( $mysync ),
|
|
'setlogfile: logdir vallogdir, logfile vallogfile.txt, vallogdir/vallogfile.txt' ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
|
|
sub logfile {
|
|
my ( $time, $suffix, $dir ) = @_ ;
|
|
|
|
$time ||= 0 ;
|
|
$suffix ||= q{} ;
|
|
my $sep_suffix = ( $suffix ) ? '_' : q{} ;
|
|
$dir ||= q{} ;
|
|
my $sep_dir = ( $dir ) ? '/' : q{} ;
|
|
|
|
my $date_str = POSIX::strftime( '%Y_%m_%d_%H_%M_%S', localtime $time ) ;
|
|
my $logfile = "${dir}${sep_dir}${date_str}${sep_suffix}${suffix}.txt" ;
|
|
$debug and myprint( "date_str: $date_str\n" ) ;
|
|
$debug and myprint( "logfile : $logfile\n" ) ;
|
|
return( $logfile ) ;
|
|
}
|
|
|
|
sub tests_logfile {
|
|
SKIP: {
|
|
# Too hard to have a well known timezone on Windows
|
|
skip( 'Too hard to have a well known timezone on Windows', 6 ) if ( 'MSWin32' eq $OSNAME ) ;
|
|
|
|
local $ENV{TZ} = 'GMT' ;
|
|
{ POSIX::tzset unless ('MSWin32' eq $OSNAME) ;
|
|
ok( '1970_01_01_00_00_00.txt' eq logfile( ), 'logfile: no args => 1970_01_01_00_00_00.txt' ) ;
|
|
ok( '1970_01_01_00_00_00.txt' eq logfile( 0 ), 'logfile: 0 => 1970_01_01_00_00_00.txt' ) ;
|
|
ok( '1970_01_01_00_01_01.txt' eq logfile( 61 ), 'logfile: 0 => 1970_01_01_00_01_01.txt' ) ;
|
|
ok( '2010_08_24_14_00_00.txt' eq logfile( 1282658400 ), 'logfile: 1282658400 => 2010_08_24_14_00_00.txt' ) ;
|
|
ok( '2010_08_24_14_01_01.txt' eq logfile( 1282658461 ), 'logfile: 1282658461 => 2010_08_24_14_01_01.txt' ) ;
|
|
ok( '2010_08_24_14_01_01_poupinette.txt' eq logfile( 1282658461, 'poupinette' ), 'logfile: 1282658461 poupinette => 2010_08_24_14_01_01_poupinette.txt' ) ;
|
|
}
|
|
POSIX::tzset unless ('MSWin32' eq $OSNAME) ;
|
|
} ;
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
sub tests_million_folders_baby_2 {
|
|
my %long ;
|
|
@long{ 1 .. 900_000 } = (1) x 900_000 ;
|
|
#myprint( %long, "\n" ) ;
|
|
my $pasglop = 0 ;
|
|
foreach my $elem ( 1 .. 900_000 ) {
|
|
#$debug and myprint( "$elem " ) ;
|
|
if ( not exists $long{ $elem } ) {
|
|
$pasglop++ ;
|
|
}
|
|
}
|
|
ok( 0 == $pasglop, 'tests_million_folders_baby_2: search among 900_000' ) ;
|
|
# myprint( "$pasglop\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub tests_always_fail {
|
|
ok( 0 == 1, '0 == 1' ) ;
|
|
ok( 1 == 1, '1 == 1' ) ;
|
|
return ;
|
|
}
|
|
|
|
sub logfileprepa {
|
|
my $logfile = shift ;
|
|
|
|
my $dirname = dirname( $logfile ) ;
|
|
is_valid_directory( $dirname ) || return( 0 ) ;
|
|
return( 1 ) ;
|
|
}
|
|
|
|
sub teelaunch {
|
|
my $mysync = shift ;
|
|
my $logfile = $mysync->{logfile} ;
|
|
logfileprepa( $logfile ) || croak "Error no valid directory to write log file $logfile : $!" ;
|
|
my $logfile_handle ;
|
|
open $logfile_handle, '>', $logfile
|
|
or croak( "Can not open $logfile for write: $!" ) ;
|
|
my $tee = IO::Tee->new( $logfile_handle, \*STDOUT ) ;
|
|
*STDERR = *$tee{IO} ;
|
|
select $tee ;
|
|
$tee->autoflush( 1 ) ;
|
|
$mysync->{logfile_handle} = $logfile_handle ;
|
|
$mysync->{tee} = $tee ;
|
|
return $logfile_handle ;
|
|
}
|
|
|
|
sub getpwuid_any_os {
|
|
my $uid = shift ;
|
|
|
|
return( scalar getlogin ) if ( 'MSWin32' eq $OSNAME ) ; # Windows system
|
|
return( scalar getpwuid $uid ) ; # Unix system
|
|
}
|
|
|
|
|
|
|
|
sub usage {
|
|
my $localhost_info = localhost_info();
|
|
my $thank = thank_author();
|
|
my $imapsync_release = q{};
|
|
$imapsync_release = check_last_release() if (not defined $releasecheck);
|
|
my $escape_char = ( 'MSWin32' eq $OSNAME ) ? '^' : '\\';
|
|
myprint( <<"EOF" ) ;
|
|
|
|
usage: $0 [options]
|
|
|
|
Several options are mandatory.
|
|
str means string
|
|
int means integer
|
|
reg means regular expression
|
|
cmd means command
|
|
|
|
--dry : Makes imapsync doing nothing, just print what would
|
|
be done without --dry.
|
|
|
|
--host1 str : Source or "from" imap server. Mandatory.
|
|
--port1 int : Port to connect on host1. Default is 143, 993 if --ssl1
|
|
--user1 str : User to login on host1. Mandatory.
|
|
--showpasswords : Shows passwords on output instead of "MASKED".
|
|
Useful to restart a complete run by just reading the log.
|
|
--password1 str : Password for the user1.
|
|
--host2 str : "destination" imap server. Mandatory.
|
|
--port2 int : Port to connect on host2. Default is 143, 993 if --ssl2
|
|
--user2 str : User to login on host2. Mandatory.
|
|
--password2 str : Password for the user2.
|
|
|
|
--passfile1 str : Password file for the user1. It must contain the
|
|
password on the first line. This option avoids to show
|
|
the password on the command line like --password1 does.
|
|
--passfile2 str : Password file for the user2. Contains the password.
|
|
|
|
--ssl1 : Use a SSL connection on host1.
|
|
--ssl2 : Use a SSL connection on host2.
|
|
--tls1 : Use a TLS connection on host1.
|
|
--tls2 : Use a TLS connection on host2.
|
|
--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
|
|
|
|
--timeout1 int : Connection timeout in seconds for host1.
|
|
Default is 120 and 0 means no timeout at all.
|
|
--timeout2 int : Connection timeout in seconds for host2.
|
|
Default is 120 and 0 means no timeout at all.
|
|
|
|
--authmech1 str : Auth mechanism to use with host1:
|
|
PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE.
|
|
--authmech2 str : Auth mechanism to use with host2. See --authmech1
|
|
|
|
--authuser1 str : User to auth with on host1 (admin user).
|
|
Avoid using --authmech1 SOMETHING with --authuser1.
|
|
--authuser2 str : User to auth with on host2 (admin user).
|
|
--proxyauth1 : Use proxyauth on host1. Requires --authuser1.
|
|
Required by Sun/iPlanet/Netscape IMAP servers to
|
|
be able to use an administrative user.
|
|
--proxyauth2 : Use proxyauth on host2. Requires --authuser2.
|
|
|
|
--authmd51 : Use MD5 authentification for host1.
|
|
--authmd52 : Use MD5 authentification for host2.
|
|
--domain1 str : Domain on host1 (NTLM authentication).
|
|
--domain2 str : Domain on host2 (NTLM authentication).
|
|
|
|
|
|
--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. --folderfirst "Work"
|
|
--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 (ex: Sent SENT sent -> Sent).
|
|
|
|
--skipemptyfolders : Empty host1 folders are not created on host2.
|
|
|
|
--include reg : Sync folders matching this regular expression
|
|
--include reg : or this one, etc.
|
|
in case both --include --exclude options are
|
|
use, include is done before.
|
|
--exclude reg : Skips folders matching this regular expression
|
|
Several folders to avoid:
|
|
--exclude 'fold1|fold2|f3' skips fold1, fold2 and f3.
|
|
--exclude reg : or this one, etc.
|
|
|
|
--subfolder2 str : Move whole host1 folders hierarchy under this
|
|
host2 folder str .
|
|
It does it by adding two --regextrans2 options before
|
|
all others. Add --debug to see what's really going on.
|
|
|
|
--automap : guesses folders mapping, for folders like
|
|
"Sent", "Junk", "Drafts", "All", "Archive", "Flagged".
|
|
--f1f2 str1=str2 : Force folder str1 to be synced to str2,
|
|
--f1f2 overrides --automap and --regextrans2.
|
|
--regextrans2 reg : Apply the whole regex to each destination folders.
|
|
--regextrans2 reg : and this one. etc.
|
|
When you play with the --regextrans2 option, first
|
|
add also the safe options --dry --justfolders
|
|
Then, when happy, remove --dry, remove --justfolders.
|
|
Have in mind that --regextrans2 is applied after prefix
|
|
and separator inversion. For examples see
|
|
http://imapsync.lamiral.info/FAQ.d/FAQ.Folders_Mapping.txt
|
|
|
|
--tmpdir str : Where to store temporary files and subdirectories.
|
|
Will be created if it doesn't exist.
|
|
Default is system specific, Unix is /tmp but
|
|
it's often small and deleted at reboot.
|
|
--tmpdir /var/tmp should be better.
|
|
--pidfile str : The file where imapsync pid is written.
|
|
--pidfilelocking : Abort if pidfile already exists. Usefull to avoid
|
|
concurrent transfers on the same mailbox.
|
|
|
|
--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
|
|
|
|
--prefix1 str : Remove prefix to all destination folders
|
|
(usually INBOX. or INBOX/ or an empty string "")
|
|
you have to use --prefix1 if host1 imap server
|
|
does not have NAMESPACE capability, so imapsync
|
|
suggests to use it. All other cases are bad.
|
|
--prefix2 str : Add prefix to all host2 folders. See --prefix1
|
|
--sep1 str : Host1 separator in case NAMESPACE is not supported.
|
|
--sep2 str : Host2 separator in case NAMESPACE is not supported.
|
|
|
|
--skipmess reg : Skips messages maching the regex.
|
|
Example: 'm/[\\x80-ff]/' # to avoid 8bits messages.
|
|
--skipmess is applied before --regexmess
|
|
--skipmess reg : or this one, etc.
|
|
|
|
--pipemess cmd : Apply this cmd command to each message content
|
|
before the copy.
|
|
--pipemess cmd : and this one, etc.
|
|
|
|
--disarmreadreceipts : Disarms read receipts (host2 Exchange issue)
|
|
|
|
--regexmess reg : Apply the whole regex to each message before transfer.
|
|
Example: 's/\\000/ /g' # to replace null by space.
|
|
--regexmess reg : and this one, etc.
|
|
|
|
--regexflag reg : Apply the whole regex to each flags list.
|
|
Example: 's/\"Junk"//g' # to remove "Junk" flag.
|
|
--regexflag reg : and this one, etc.
|
|
|
|
--delete : Deletes messages on host1 server after a successful
|
|
transfer. Option --delete has the following behavior:
|
|
it marks messages as deleted with the IMAP flag
|
|
\\Deleted, then messages are really deleted with an
|
|
EXPUNGE IMAP command.
|
|
|
|
--delete2 : Delete messages in host2 that are not in
|
|
host1 server. Useful for backup or pre-sync.
|
|
--delete2duplicates : Delete messages in host2 that are duplicates.
|
|
Works only without --useuid since duplicates are
|
|
detected with an header part of each message.
|
|
|
|
--delete2folders : Delete folders in host2 that are not in host1 server.
|
|
For safety, first try it like this (it is safe):
|
|
--delete2folders --dry --justfolders --nofoldersizes
|
|
--delete2foldersonly reg : Deleted only folders matching regex.
|
|
Example: --delete2foldersonly "/^Junk\$|^INBOX.Junk\$/"
|
|
--delete2foldersbutnot reg : Do not delete folders matching regex.
|
|
Example: --delete2foldersbutnot "/Tasks\$|Contacts\$|Foo\$/"
|
|
--noexpunge : Do not expunge messages on host1.
|
|
Expunge really deletes messages marked deleted.
|
|
Expunge is made at the beginning, on host1 only.
|
|
Newly transferred messages are also expunged if
|
|
option --delete is given.
|
|
No expunge is done on host2 account (unless --expunge2)
|
|
--expunge1 : Expunge messages on host1 after messages transfer.
|
|
--expunge2 : Expunge messages on host2 after messages transfer.
|
|
--uidexpunge2 : uidexpunge messages on the host2 account
|
|
that are not on the host1 account, requires --delete2
|
|
--nomixfolders : Avoid merging folders that are considered different on
|
|
host1 but the same on destination host2 because of
|
|
case sensitivities and insensitivities.
|
|
|
|
--syncinternaldates : Sets the internal dates on host2 same as host1.
|
|
Turned on by default. Internal date is the date
|
|
a message arrived on a host (mtime).
|
|
--idatefromheader : Sets the internal dates on host2 same as the
|
|
"Date:" headers.
|
|
|
|
--maxsize int : Skip messages larger (or equal) than int bytes
|
|
--minsize int : Skip messages smaller (or equal) than int bytes
|
|
--maxage int : Skip messages older than int days.
|
|
final stats (skipped) don't count older messages
|
|
see also --minage
|
|
--minage int : Skip messages newer than int days.
|
|
final stats (skipped) don't count newer messages
|
|
You can do (+ are the messages selected):
|
|
past|----maxage+++++++++++++++>now
|
|
past|+++++++++++++++minage---->now
|
|
past|----maxage+++++minage---->now (intersection)
|
|
past|++++minage-----maxage++++>now (union)
|
|
|
|
--search str : Selects only messages returned by this IMAP SEARCH
|
|
command. Applied on both sides.
|
|
--search1 str : Same as --search for selecting host1 messages only.
|
|
--search2 str : Same as --search for selecting host2 messages only.
|
|
--search CRIT equals --search1 CRIT --search2 CRIT
|
|
|
|
--exitwhenover int : Stop syncing when total bytes transferred reached.
|
|
Gmail per day allows
|
|
2500000000 = 2.5 GB downloaded from Gmail as host2
|
|
500000000 = 500 MB uploaded to Gmail as host1.
|
|
|
|
--maxlinelength int : skip messages with a line length longer than int bytes.
|
|
RFC 2822 says it must be no more than 1000 bytes.
|
|
|
|
--useheader str : Use this header to compare messages on both sides.
|
|
Ex: Message-ID or Subject or Date.
|
|
--useheader str and this one, etc.
|
|
|
|
--subscribed : Transfers subscribed folders.
|
|
--subscribe : Subscribe to the folders transferred on the
|
|
host2 that are subscribed on host1. On by default.
|
|
--subscribeall : Subscribe to the folders transferred on the
|
|
host2 even if they are not subscribed on host1.
|
|
|
|
--nofoldersizes : Do not calculate the size of each folder in bytes
|
|
and message counts. Default is to calculate them.
|
|
--nofoldersizesatend: Do not calculate the size of each folder in bytes
|
|
and message counts at the end. Default is on.
|
|
--justfoldersizes : Exit after having printed the folder sizes.
|
|
|
|
--syncacls : Synchronises acls (Access Control Lists).
|
|
--nosyncacls : Does not synchronize acls. This is the default.
|
|
Acls in IMAP are not standardized, be careful.
|
|
|
|
--usecache : Use cache to speedup.
|
|
--nousecache : Do not use cache. Caveat: --useuid --nousecache creates
|
|
duplicates on multiple runs.
|
|
--useuid : Use uid instead of header as a criterium to recognize
|
|
messages. Option --usecache is then implied unless
|
|
--nousecache is used.
|
|
|
|
--debug : Debug mode.
|
|
--debugfolders : Debug mode for the folders part only.
|
|
--debugcontent : Debug content of the messages transfered. Huge ouput.
|
|
--debugflags : Debug mode for flags.
|
|
--debugimap1 : IMAP debug mode for host1. Very verbose.
|
|
--debugimap2 : IMAP debug mode for host2. Very verbose.
|
|
--debugimap : IMAP debug mode for host1 and host2.
|
|
--debugmemory : Debug mode showing memory consumption after each copy.
|
|
|
|
--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 connexion.
|
|
|
|
--version : Print only software version.
|
|
--noreleasecheck : Do not check for new imapsync release (a http request).
|
|
--releasecheck : Check for new imapsync release (a http request).
|
|
--noid : Do not send/receive ID command to imap servers.
|
|
--justconnect : Just connect to both servers and print useful
|
|
information. Need only --host1 and --host2 options.
|
|
--justlogin : Just login to both host1 and host2 with users
|
|
credentials, then exit.
|
|
--justfolders : Do only things about folders (ignore messages).
|
|
|
|
--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"
|
|
|
|
$0 $escape_char
|
|
--host1 test1.lamiral.info --user1 test1 --password1 secret1 $escape_char
|
|
--host2 test2.lamiral.info --user2 test2 --password2 secret2
|
|
|
|
$localhost_info
|
|
$rcs
|
|
$imapsync_release
|
|
|
|
$thank
|
|
EOF
|
|
return( 1 ) ;
|
|
}
|
|
|
|
|
|
sub usage_complete {
|
|
myprint( <<'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 500.
|
|
--split2 int : same thing on host2.
|
|
--nofixInboxINBOX : Don't fix Inbox INBOX mapping.
|
|
EOF
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub get_options {
|
|
# In CGI context arguments are not in @ARGV but in QUERY_STRING variable (with GET).
|
|
my $numopt = scalar @ARGV || length $ENV{'QUERY_STRING'} ;
|
|
my $argv = join "\x00", @ARGV ;
|
|
|
|
if ( $argv =~ m/-delete\x002/x ) {
|
|
myprint( "May be you mean --delete2 instead of --delete 2\n" ) ;
|
|
exit 1 ;
|
|
}
|
|
$sync->{f1f2} = {} ;
|
|
my $opt_ret = Imapsync::Getopt::Long::GetOptions(
|
|
'debug!' => \$debug,
|
|
'debuglist!' => \$debuglist,
|
|
'debugcontent!' => \$debugcontent,
|
|
'debugsleep=f' => \$sync->{debugsleep},
|
|
'debugflags!' => \$debugflags,
|
|
'debugimap!' => \$debugimap,
|
|
'debugimap1!' => \$debugimap1,
|
|
'debugimap2!' => \$debugimap2,
|
|
'debugdev!' => \$debugdev,
|
|
'debugmemory!' => \$sync->{debugmemory},
|
|
'debugfolders!' => \$sync->{debugfolders},
|
|
'debugssl=i' => \$sync->{debugssl},
|
|
'debugbasket=s' => \@debugbasket,
|
|
'debugcgi!' => \$debugcgi,
|
|
'host1=s' => \$host1,
|
|
'host2=s' => \$host2,
|
|
'port1=i' => \$port1,
|
|
'port2=i' => \$port2,
|
|
'inet4' => \$sync->{inet4},
|
|
'inet6' => \$sync->{inet6},
|
|
'user1=s' => \$user1,
|
|
'user2=s' => \$user2,
|
|
'domain1=s' => \$domain1,
|
|
'domain2=s' => \$domain2,
|
|
'password1=s' => \$password1,
|
|
'password2=s' => \$password2,
|
|
'passfile1=s' => \$passfile1,
|
|
'passfile2=s' => \$passfile2,
|
|
'authmd5!' => \$authmd5,
|
|
'authmd51!' => \$authmd51,
|
|
'authmd52!' => \$authmd52,
|
|
'sep1=s' => \$sep1,
|
|
'sep2=s' => \$sep2,
|
|
'folder=s' => \@folder,
|
|
'folderrec=s' => \@folderrec,
|
|
'include=s' => \@include,
|
|
'exclude=s' => \@exclude,
|
|
'folderfirst=s' => \@folderfirst,
|
|
'folderlast=s' => \@folderlast,
|
|
'prefix1=s' => \$prefix1,
|
|
'prefix2=s' => \$prefix2,
|
|
'subfolder2=s' => \$subfolder2,
|
|
'fixslash2!' => \$fixslash2,
|
|
'fixInboxINBOX!' => \$fixInboxINBOX,
|
|
'regextrans2=s' => \@regextrans2,
|
|
'mixfolders!' => \$mixfolders,
|
|
'skipemptyfolders!' => \$skipemptyfolders,
|
|
'regexmess=s' => \@regexmess,
|
|
'skipmess=s' => \@skipmess,
|
|
'pipemess=s' => \@pipemess,
|
|
'pipemesscheck!' => \$pipemesscheck,
|
|
'disarmreadreceipts!' => \$disarmreadreceipts,
|
|
'regexflag=s' => \@regexflag,
|
|
'filterflags!' => \$filterflags,
|
|
'flagscase!' => \$flagscase,
|
|
'syncflagsaftercopy!' => \$syncflagsaftercopy,
|
|
'delete|delete1!' => \$delete,
|
|
'delete2!' => \$delete2,
|
|
'delete2duplicates!' => \$delete2duplicates,
|
|
'delete2folders!' => \$delete2folders,
|
|
'delete2foldersonly=s' => \$delete2foldersonly,
|
|
'delete2foldersbutnot=s' => \$delete2foldersbutnot,
|
|
'syncinternaldates!' => \$syncinternaldates,
|
|
'idatefromheader!' => \$idatefromheader,
|
|
'syncacls!' => \$syncacls,
|
|
'maxsize=i' => \$maxsize,
|
|
'minsize=i' => \$minsize,
|
|
'maxage=i' => \$maxage,
|
|
'minage=i' => \$minage,
|
|
'search=s' => \$search,
|
|
'search1=s' => \$search1,
|
|
'search2=s' => \$search2,
|
|
'foldersizes!' => \$foldersizes,
|
|
'foldersizesatend!' => \$foldersizesatend,
|
|
'dry!' => \$dry,
|
|
'expunge!' => \$expunge,
|
|
'expunge1!' => \$expunge1,
|
|
'expunge2!' => \$expunge2,
|
|
'uidexpunge2!' => \$uidexpunge2,
|
|
'subscribed!' => \$subscribed,
|
|
'subscribe!' => \$subscribe,
|
|
'subscribeall|subscribe_all!' => \$subscribeall,
|
|
'justbanner!' => \$justbanner,
|
|
'justconnect!'=> \$justconnect,
|
|
'justfolders!'=> \$justfolders,
|
|
'justfoldersizes!' => \$justfoldersizes,
|
|
'fast!' => \$fast,
|
|
'version' => \$version,
|
|
'help' => \$help,
|
|
'timeout=i' => \$timeout,
|
|
'timeout1=i' => \$sync->{h1}->{timeout},
|
|
'timeout2=i' => \$sync->{h2}->{timeout},
|
|
'skipheader=s' => \$skipheader,
|
|
'useheader=s' => \@useheader,
|
|
'wholeheaderifneeded!' => \$wholeheaderifneeded,
|
|
'messageidnodomain!' => \$messageidnodomain,
|
|
'skipsize!' => \$skipsize,
|
|
'allowsizemismatch!' => \$allowsizemismatch,
|
|
'fastio1!' => \$fastio1,
|
|
'fastio2!' => \$fastio2,
|
|
'ssl1!' => \$ssl1,
|
|
'ssl2!' => \$ssl2,
|
|
'ssl1_ssl_version=s' => \$sync->{h1}->{sslargs}->{SSL_version},
|
|
'ssl2_ssl_version=s' => \$sync->{h2}->{sslargs}->{SSL_version},
|
|
'sslargs1=s%' => \$sync->{h1}->{sslargs},
|
|
'sslargs2=s%' => \$sync->{h2}->{sslargs},
|
|
'tls1!' => \$tls1,
|
|
'tls2!' => \$tls2,
|
|
'uid1!' => \$uid1,
|
|
'uid2!' => \$uid2,
|
|
'authmech1=s' => \$authmech1,
|
|
'authmech2=s' => \$authmech2,
|
|
'authuser1=s' => \$authuser1,
|
|
'authuser2=s' => \$authuser2,
|
|
'proxyauth1' => \$proxyauth1,
|
|
'proxyauth2' => \$proxyauth2,
|
|
'split1=i' => \$split1,
|
|
'split2=i' => \$split2,
|
|
'buffersize=i' => \$buffersize,
|
|
'reconnectretry1=i' => \$reconnectretry1,
|
|
'reconnectretry2=i' => \$reconnectretry2,
|
|
'tests!' => \$tests,
|
|
'testsdebug|tests_debug!' => \$testsdebug,
|
|
'testslive!' => \$testslive,
|
|
'justlogin!' => \$justlogin,
|
|
'tmpdir=s' => \$tmpdir,
|
|
'pidfile=s' => \$sync->{pidfile},
|
|
'pidfilelocking!' => \$sync->{pidfilelocking},
|
|
'releasecheck!' => \$releasecheck,
|
|
'modulesversion|modules_version!' => \$modulesversion,
|
|
'usecache!' => \$usecache,
|
|
'cacheaftercopy!' => \$cacheaftercopy,
|
|
'debugcache!' => \$debugcache,
|
|
'useuid!' => \$useuid,
|
|
'addheader!' => \$addheader,
|
|
'exitwhenover=i' => \$exitwhenover,
|
|
'checkselectable!' => \$checkselectable,
|
|
'checkmessageexists!' => \$checkmessageexists,
|
|
'expungeaftereach!' => \$expungeaftereach,
|
|
'abletosearch!' => \$abletosearch,
|
|
'showpasswords!' => \$showpasswords,
|
|
'maxlinelength=i' => \$maxlinelength,
|
|
'maxlinelengthcmd=s' => \$maxlinelengthcmd,
|
|
'minmaxlinelength=i' => \$minmaxlinelength,
|
|
'debugmaxlinelength!' => \$debugmaxlinelength,
|
|
'fixcolonbug!' => \$fixcolonbug,
|
|
'create_folder_old!' => \$create_folder_old,
|
|
'maxmessagespersecond=f' => \$maxmessagespersecond,
|
|
'maxbytespersecond=i' => \$maxbytespersecond,
|
|
'skipcrossduplicates!' => \$skipcrossduplicates,
|
|
'debugcrossduplicates!' => \$debugcrossduplicates,
|
|
'log!' => \$sync->{log},
|
|
'logfile=s' => \$sync->{logfile},
|
|
'logdir=s' => \$sync->{logdir},
|
|
'errorsmax=i' => \$sync->{errorsmax},
|
|
'errorsdump!' => \$sync->{errorsdump},
|
|
'fetch_hash_set=s' => \$fetch_hash_set,
|
|
'automap!' => \$sync->{automap},
|
|
'justautomap!' => \$sync->{justautomap},
|
|
'id!' => \$sync->{id},
|
|
'f1f2=s%' => \$sync->{f1f2},
|
|
'justfolderlists!' => \$sync->{justfolderlists},
|
|
'delete1emptyfolders' => \$sync->{delete1emptyfolders},
|
|
) ;
|
|
|
|
|
|
$debugcgi and myprint( map { "$_ => $ENV{$_}\n" } sort keys %ENV ) ;
|
|
$debugcgi and myprint( "@debugbasket\n" ) ;
|
|
$debug and myprint( "get options: [$opt_ret]\n" ) ;
|
|
|
|
# just the version
|
|
myprint( imapsync_version( ), "\n" ) and exit 0 if ( $version ) ;
|
|
# $tmpdir is used in tests_pipemess()
|
|
$tmpdir ||= File::Spec->tmpdir( ) ;
|
|
if ( $tests or $testsdebug ) {
|
|
$test_builder = Test::More->builder ;
|
|
if ( $tests ) { tests( ) ; }
|
|
if ( $testsdebug ) { testsdebug( ) ; }
|
|
#$test_builder->reset( ) ;
|
|
exit ;
|
|
}
|
|
|
|
#$help = 1 if ! $numopt;
|
|
load_modules( );
|
|
|
|
# exit with --help option or no option at all
|
|
$debug and myprint( "numopt:$numopt\n" ) ;
|
|
usage( ) and exit if ( $help or not $numopt ) ;
|
|
|
|
# don't go on if options are not all known.
|
|
exit $EX_USAGE unless ( $opt_ret ) ;
|
|
|
|
# init live varaiables
|
|
testslive( ) if ( $testslive ) ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub testslive {
|
|
$host1 = 'test1.lamiral.info' ;
|
|
$user1 = 'test1' ;
|
|
$password1 = 'secret1' ;
|
|
$host2 = 'test2.lamiral.info' ;
|
|
$user2 = 'test2' ;
|
|
$password2 ='secret2' ;
|
|
return ;
|
|
}
|
|
|
|
sub testsdebug {
|
|
SKIP: {
|
|
skip 'No test in normal run' if ( not $testsdebug ) ;
|
|
#tests_bytes_display_string( ) ;
|
|
#tests_ucsecond( ) ;
|
|
#tests_mkpath( ) ;
|
|
#eval { tests_mkpath( ) ; } or ok( 0 == 1, 'tests_mkpath fail badly?' ) ;
|
|
#tests_format_for_imap_arg( ) ;
|
|
#tests_is_a_release_number( ) ;
|
|
#tests_delete1emptyfolders( ) ;
|
|
#tests_memory_consumption( ) ;
|
|
#tests_imap2_folder_name() ;
|
|
#tests_length_ref( ) ;
|
|
#tests_is_valid_directory( ) ;
|
|
#tests_firstline( ) ;
|
|
#tests_diff_or_NA( ) ;
|
|
#tests_match_number( ) ;
|
|
#tests_all_defined( ) ;
|
|
#tests_guess_separator( ) ;
|
|
tests_pipemess( ) ;
|
|
#tests_message_for_host2( ) ;
|
|
done_testing( ) ;
|
|
note('End of imapsync --tests_debug') ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub tests {
|
|
|
|
SKIP: {
|
|
skip 'No test in normal run' if ( not $tests ) ;
|
|
tests_folder_routines( ) ;
|
|
tests_compare_lists( ) ;
|
|
tests_regexmess();
|
|
tests_skipmess( ) ;
|
|
tests_flags_regex();
|
|
tests_ucsecond( ) ;
|
|
tests_permanentflags();
|
|
tests_flags_filter( ) ;
|
|
tests_separator_invert( ) ;
|
|
tests_imap2_folder_name() ;
|
|
tests_command_line_nopassword();
|
|
tests_good_date( ) ;
|
|
tests_max();
|
|
tests_remove_not_num();
|
|
tests_memory_consumption( ) ;
|
|
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( ) ;
|
|
eval { tests_mkpath( ) ; } or ok( 0 == 1, 'tests_mkpath fail badly?' ) ;
|
|
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_Banner( ) ;
|
|
tests_backtick( ) ;
|
|
tests_bytes_display_string( ) ;
|
|
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( ) ;
|
|
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_is_valid_directory( ) ;
|
|
tests_delete1emptyfolders( ) ;
|
|
tests_message_for_host2( ) ;
|
|
tests_length_ref( ) ;
|
|
tests_firstline( ) ;
|
|
tests_diff_or_NA( ) ;
|
|
#tests_always_fail( ) ;
|
|
tests_match_number( ) ;
|
|
tests_all_defined( ) ;
|
|
done_testing( 693 ) ;
|
|
note('End of imapsync --tests') ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
# IMAPClient 3.xx ads
|
|
|
|
package Mail::IMAPClient;
|
|
|
|
sub Tls {
|
|
my $self = shift ;
|
|
my $value = shift ;
|
|
if ( defined $value ) { $self->{TLS} = $value }
|
|
return $self->{TLS};
|
|
}
|
|
|
|
sub Reconnect_counter {
|
|
my $self = shift ;
|
|
my $value = shift ;
|
|
$self->{Reconnect_counter} = 0 if ( not defined $self->{Reconnect_counter} ) ;
|
|
if ( defined $value ) { $self->{Reconnect_counter} = $value }
|
|
return( $self->{Reconnect_counter} ) ;
|
|
}
|
|
|
|
|
|
sub Banner {
|
|
my $self = shift ;
|
|
my $value = shift ;
|
|
if ( defined $value ) { $self->{ BANNER } = $value }
|
|
return $self->{ BANNER };
|
|
}
|
|
|
|
sub capability_update {
|
|
my $self = shift ;
|
|
|
|
delete $self->{CAPABILITY} ;
|
|
return( $self->capability ) ;
|
|
}
|
|
|
|
|
|
package Imapsync::Getopt::Long ;
|
|
# Started as a copy of Luke Ross Getopt::Long::CGI
|
|
# https://metacpan.org/release/Getopt-Long-CGI
|
|
# So this section is under the same license as Getopt-Long-CGI Luke Ross wants it,
|
|
# which was Perl 5.6 or later licenses at the date of the copy.
|
|
|
|
use strict ;
|
|
use warnings ;
|
|
|
|
use Getopt::Long( ) ;
|
|
|
|
|
|
sub GetOptions {
|
|
my %options = @_ ;
|
|
|
|
if ( not $ENV{SERVER_SOFTWARE} ) {
|
|
# Not CGI - pass upstream for normal command line handling
|
|
return Getopt::Long::GetOptions( %options ) ;
|
|
}
|
|
my $b_ref = $options{'debugbasket=s'} ;
|
|
require CGI ;
|
|
require CGI::Carp ;
|
|
CGI::Carp->import( 'fatalsToBrowser' ) ;
|
|
|
|
my $cgi = CGI->new( ) ;
|
|
$cgi->param( 'debugcgi' ) and myprint( "<h2>Current Values</h2>\n" . $cgi->Dump ) ;
|
|
|
|
foreach my $key (sort keys %options) {
|
|
my $val = $options{$key};
|
|
#push( @{$b_ref}, "opt:[$key] val:[$val]" . ( ('SCALAR' eq ref($val) and defined $$val ) ? " [$$val]" : q{} ) . "\n" ) ;
|
|
if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/ ) {
|
|
push @{$b_ref}, "Unknown opt: [$key]\n" ;
|
|
next ; # Unknown item
|
|
}
|
|
|
|
my $name = [split '|', $1, 1 ]->[0];
|
|
|
|
if (($3 || q{}) eq '+') {
|
|
${ $val } = $cgi->param($name); # "Incremental" integer
|
|
} elsif ($2) {
|
|
my @values = $cgi->param($name);
|
|
my $type = $2;
|
|
if (($3 || q{}) eq '%' or ref($val) eq 'HASH') {
|
|
my %values = map { split /=/, $_, 1 } @values;
|
|
if ($type =~ m/i$/) {
|
|
foreach my $k (keys %values) {
|
|
$values{$k} = int $values{$k} ;
|
|
}
|
|
} elsif ($type =~ m/f$/) {
|
|
foreach my $k (keys %values) {
|
|
$values{$k} = 0 + $values{$k}
|
|
}
|
|
}
|
|
if ( ref($val) eq 'CODE') {
|
|
while(my($k, $v) = each %values) {
|
|
$val->($name, $k, $v);
|
|
}
|
|
} elsif ( 'REF' eq ref $val ) {
|
|
#push( @{$b_ref}, "refref($$val): " . ref($$val) . " %values= ", %values, "\n\n" ) ;
|
|
%{ ${ $val } } = %values;
|
|
} else {
|
|
#push( @{$b_ref}, "ref($val): " . ref($val) . " %values= ", %values, "\n\n" ) ;
|
|
%{ $val } = %values;
|
|
}
|
|
} else {
|
|
if ($type =~ m/i$/) {
|
|
@values = map { int $_ } @values;
|
|
} elsif ($type =~ m/f$/) {
|
|
@values = map { 0 + $_ } @values;
|
|
}
|
|
if (($3 || q{}) eq '@' or ref($val) eq 'ARRAY') {
|
|
if (ref($val) eq 'CODE') {
|
|
$val->($name, \@values)
|
|
} else {
|
|
@{ $val } = @values ;
|
|
}
|
|
} else {
|
|
if (ref($val) eq 'CODE') {
|
|
$val->($name, $values[0]);
|
|
} else {
|
|
${ $val } = $values[0];
|
|
}
|
|
}
|
|
}
|
|
} else {
|
|
# Checkbox
|
|
${ $val } = $cgi->param($name) ? 1 : undef ;
|
|
#push( @{$b_ref}, "param($name) ref($val): " . ref($val) . " val=[$$val]\n\n" ) ;
|
|
}
|
|
}
|
|
return( 1 ) ;
|
|
}
|
|
|
|
|