Skip to content

Instantly share code, notes, and snippets.

@dabrahams

dabrahams/imapsync.pl

Created July 7, 2012 20:12
Show Gist options
  • Save dabrahams/3067952 to your computer and use it in GitHub Desktop.
Save dabrahams/3067952 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
imapsync.pl
#!/opt/local/bin/perl5.12
# structure
# pod documentation
# pragmas
# main program
# global variables initialisation
# default values
# folder loop
# subroutines
# IMAPClient 2.2.9 overrides
# IMAPClient 2.2.9 3.xx ads
=pod
=head1 NAME
imapsync - IMAP synchronisation, sync, copy or migration tool.
Synchronise mailboxes between two imap servers.
Good at IMAP migration. More than 44 different IMAP server softwares
supported with success.
$Revision: 1.488 $
=head1 SYNOPSIS
To synchronise imap account "foo" on "imap.truc.org"
to imap account "bar" on "imap.trac.org"
with foo password "secret1"
and bar password "secret2":
imapsync \
--host1 imap.truc.org --user1 foo --password1 secret1 \
--host2 imap.trac.org --user2 bar --password2 secret2
=head1 INSTALL
imapsync works fine under any Unix OS with perl.
imapsync works fine under Windows (2000, XP)
with Strawberry Perl 5.10 or 5.12
or as a standalone binary software imapsync.exe
imapsync can be available directly on the following distributions:
FreeBSD, Debian, Ubuntu, Gentoo, Fedora,
NetBSD, Darwin, Mandriva and OpenBSD.
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.
The INSTALL file is also at
http://imapsync.lamiral.info/INSTALL
The freecode (was freshmeat) record is at
http://freecode.com/projects/imapsync
=head1 USAGE
imapsync [options]
To get a description of each option just run imapsync like this:
imapsync --help
imapsync
The option list:
imapsync [--host1 server1] [--port1 <num>]
[--user1 <string>] [--passfile1 <string>]
[--host2 server2] [--port2 <num>]
[--user2 <string>] [--passfile2 <string>]
[--ssl1] [--ssl2]
[--tls1] [--tls2]
[--authmech1 <string>] [--authmech2 <string>]
[--proxyauth1] [--proxyauth2]
[--domain1] [--domain2]
[--authmd51] [--authmd52]
[--folder <string> --folder <string> ...]
[--folderrec <string> --folderrec <string> ...]
[--include <regex>] [--exclude <regex>]
[--prefix2 <string>] [--prefix1 <string>]
[--regextrans2 <regex> --regextrans2 <regex> ...]
[--sep1 <char>]
[--sep2 <char>]
[--justfolders] [--justfoldersizes] [--justconnect] [--justbanner]
[--syncinternaldates]
[--idatefromheader]
[--syncacls]
[--regexmess <regex>] [--regexmess <regex>]
[--maxsize <int>]
[--minsize <int>]
[--maxage <int>]
[--minage <int>]
[--skipheader <regex>]
[--useheader <string>] [--useheader <string>]
[--nouid1] [--nouid2]
[--usecache]
[--skipsize] [--allowsizemismatch]
[--delete] [--delete2]
[--expunge] [--expunge1] [--expunge2] [--uidexpunge2]
[--delete2folders] [--delete2foldersonly] [--delete2foldersbutnot]
[--subscribed] [--subscribe] [--subscribe_all]
[--nofoldersizes]
[--dry]
[--debug] [--debugimap][--debugimap1][--debugimap2]
[--timeout <int>] [--fast]
[--split1] [--split2]
[--reconnectretry1 <int>] [--reconnectretry2 <int>]
[--noreleasecheck]
[--pidfile <filepath>]
[--tmpdir <dirpath>]
[--version] [--help]
[--tests] [--tests_debug]
=cut
# comment
=pod
=head1 DESCRIPTION
The command imapsync is a tool allowing incremental and
recursive imap transfer from one mailbox to another.
By default all folders are transferred, recursively.
We sometimes need to transfer mailboxes from one imap server to
another. This is called migration.
imapsync is a good tool because it reduces the amount
of data transferred by not transferring a given message if it
is already on both sides. Same headers
and the transfer is done only once. 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.
You can decide to delete the messages from the source mailbox
after a successful transfer (it is a good feature when migrating).
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
real world scenario for the combinaison --delete --noexpunge).
You can also just synchronize a mailbox A from another mailbox B
in case you just want to keep a "live" copy of B in A (--delete2
may help)
imapsync is not adequate for maintaining two active imap accounts
in synchronization where 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 --help
=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 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.
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
=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
imapsync is free, open source but not always gratis software cover by
the Do What The Fuck You Want To Public License (WTFPL).
See COPYING file included in the distribution or the web site
http://sam.zoy.org/wtfpl/COPYING
=head1 MAILING-LIST
The public mailing-list may be the best way to get 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 may be 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 <lamiral@linux-france.org>
Feedback good or bad is always welcome.
The newsgroup comp.mail.imap may be a good place to talk about
imapsync. I read it when imapsync is concerned.
A better place is the public imapsync mailing-list
(see below).
Gilles LAMIRAL earns his living writing, installing,
configuring and teaching free, open and often gratis
softwares. Do not hesitate to pay him for that services.
=head1 BUG REPORT GUIDELINES
Help us 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 FAQ, 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.
Make a good title with word "imapsync" in it (my spam filter won't filter it),
Don't write an email title with just "imapsync" or "problem",
a good title is made of keywords summary, not too long (one visible line).
Don't write imapsync in uppercase in the email title, we'll
know you run Windows and you haven't read this README yet.
Help us to help you: in your report, please include:
- imapsync version.
- output given with --debug --debugimap near the failure point.
Isolate a message or two in a folder 'BUG' and use
imapsync ... --folder 'BUG' --debug --debugimap
- imap server software on both side 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.
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
Failure stories reported with the following 3 imap servers:
- MailEnable 1.54 (Proprietary) but MailEnable 4.23 is supported.
- DBMail 0.9, 2.0.7 (GPL). But DBMail 1.2.1 is supported.
Patient and confident testers are welcome.
- Imail 7.04 (maybe).
- (2011) MDaemon 12.0.3 as host2 but MDaemon is supported as host1.
MDaemon is simply buggy with the APPEND IMAP command with
any IMAP email client.
Success stories reported with the following 44 imap servers
(software names are in alphabetic order):
- 1und1 H mimap1 84498 [host1]
- a1.net imap.a1.net IMAP4 Ready [host1]
- Archiveopteryx 2.03, 2.04, 2.09, 2.10 [host2], 3.0.0 [host2]
(OSL 3.0) http://www.archiveopteryx.org/
- Axigen Mail Server Version 8.0.0
- BincImap 1.2.3 (GPL) (http://www.bincimap.org/)
- CommuniGatePro server (Redhat 8.0) (Solaris), CommuniGate Pro 5.2.17[host2] (CentOS 5.4)
- Courier IMAP 1.5.1, 2.2.0, 2.1.1, 2.2.1, 3.0.8, 3.0.3, 4.1.1 (GPL)
(http://www.courier-mta.org/)
- Critical Path (7.0.020)
- Cyrus IMAP 1.5, 1.6, 2.1, 2.1.15, 2.1.16, 2.1.18
2.2.1, 2.2.2-BETA, 2.2.10, 2.2.12,
v2.2.3-Invoca-RPM-2.2.3-8,
2.3-alpha (OSI Approved),
v2.2.12-Invoca-RPM-2.2.12-3.RHEL4.1,
2.2.13,
v2.3.1-Invoca-RPM-2.3.1-2.7.fc5,
v2.3.7,
(http://asg.web.cmu.edu/cyrus/)
- David Tobit V8 (proprietary Message system).
- DBMail 1.2.1, 2.0.4, 2.0.9, 2.2rc1 (GPL) (http://www.dbmail.org/).
2.0.7 seems buggy.
- Deerfield VisNetic MailServer 5.8.6 [host1]
- dkimap4 [host1]
- Domino (Notes) 4.61[host1], 6.5[host1], 5.0.6, 5.0.7, 7.0.2, 6.0.2CF1,
7.0.1[host1], 8.0.1[host1], 8.5.2[host2]
- Dovecot 0.99.10.4, 0.99.14, 0.99.14-8.fc4, 1.0-0.beta2.7,
1.0.0 [dest/source] (LGPL) (http://www.dovecot.org/)
- Eudora WorldMail v2
- Gimap (Gmail imap)
- GMX IMAP4 StreamProxy.
- Groupwise IMAP (Novell) 6.x and 7.0. Buggy so see the FAQ.
- hMailServer 5.3.3 [host2], 4.4.1 [host1] (see FAQ)
- iPlanet Messaging server 4.15, 5.1, 5.2
- IMail 7.15 (Ipswitch/Win2003), 8.12, 11.03 [host1]
- Kerio 7.2.0 Patch 1 [host1] [host2]
- MailEnable 4.23 [host1] [host2], 4.26 [host1][host2], 5 [host1]
- MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform), 12 [host2],
12.0.3 [host1]
- Mercury 4.1 (Windows server 2000 platform)
- Microsoft Exchange Server 5.5, 6.0.6249.0[host1], 6.0.6487.0[host1],
6.5.7638.1 [host2], 6.5 [host1], Exchange 2007 SP1 (with Update Rollup 2),
Exchange2007-EP-SP2,
Exchange 2010 RTM (Release to Manufacturing) [host2],
Exchange 2010 SP1 RU2[host2],
- Mirapoint, 4.1.9-GA [host1]
- Netscape Mail Server 3.6 (Wintel !)
- Netscape Messaging Server 4.15 Patch 7
- OpenMail IMAP server B.07.00.k0 (Samsung Contact ?)
- OpenWave
- Oracle Beehive [host1]
- Qualcomm Worldmail (NT)
- Rockliffe Mailsite 5.3.11, 4.5.6
- Samsung Contact IMAP server 8.5.0
- Scalix v10.1, 10.0.1.3, 11.0.0.431
- SmarterMail, Smarter Mail 5.0 Enterprise, Smarter Mail 5.5 [host1].
- SunONE Messaging server 5.2, 6.0 (SUN JES - Java Enterprise System)
- Sun Java(tm) System Messaging Server 6.2-2.05, 6.2-7.05, 6.3
- Surgemail 3.6f5-5
- UW-imap servers (imap-2000b) rijkkramer IMAP4rev1 2000.287
(RedHat uses UW like 2003.338rh), v12.264 Solaris 5.7 (OSI Approved)
(http://www.washington.edu/imap/)
- UW - QMail v2.1
- VMS, Imap part of TCP/IP suite of VMS 7.3.2
- Yahoo [host1]
- Zimbra-IMAP 3.0.1 GA 160, 3.1.0 Build 279, 4.0.5, 4.5.2, 4.5.6,
Zimbra 5.0.24_GA_3356.RHEL4 [host1], 5.5, 6.x
Please report to the author any success or bad story with
imapsync and do not forget to mention the IMAP server
software names and version on both sides. This will help
future users. To help the author maintaining this section
report the two lines at the begining of the output if they
are useful to know the softwares. Example:
Host1 software:* OK louloutte Cyrus IMAP4 v1.5.19 server ready
Host2 software:* OK Courier-IMAP ready
You can use option --justconnect to get those lines.
Example:
imapsync --host1 imap.troc.org --host2 imap.trac.org --justconnect
=head1 HUGE MIGRATION
Pay special attention to options
--subscribed
--subscribe
--delete
--delete2
--delete2folders
--expunge
--expunge1
--expunge2
--uidexpunge2
--maxage
--minage
--maxsize
--useheader
--fast
--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 !
=head1 Hacking
Feel free to hack imapsync as the WTFPL Licence permits it.
=head1 Links
Entries for imapsync:
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.488 2012/04/15 17:38:21 gilles Exp gilles $
=cut
# pragmas
use warnings;
++$|;
use strict;
use Carp;
use Getopt::Long;
use Mail::IMAPClient;
use Digest::MD5 qw(md5_base64);
#use Term::ReadKey;
#use IO::Socket::SSL;
use MIME::Base64;
use English;
use File::Basename;
use POSIX qw(uname SIGALRM);
use Fcntl;
use File::Spec;
use File::Path qw(mkpath rmtree);
use IO::Socket qw(:crlf SOL_SOCKET SO_KEEPALIVE);
use Errno qw(EAGAIN EPIPE ECONNRESET);
use File::Glob qw( :glob ) ;
use IO::File;
use Time::Local ;
use Test::More 'no_plan';
eval { require 'usr/include/sysexits.ph' };
use constant {
Unconnected => 0,
Connected => 1, # connected; not logged in
Authenticated => 2, # logged in; no mailbox selected
Selected => 3, # mailbox selected
};
# global variables
my(
$rcs, $pidfile,
$debug, $debugimap, $debugimap1, $debugimap2, $debugcontent, $debugflags,
$debugLIST, $debugsleep,
$nb_errors,
$host1, $host2, $port1, $port2,
$user1, $user2, $domain1, $domain2,
$password1, $password2, $passfile1, $passfile2,
@folder, @include, @exclude, @folderrec,
$prefix1, $prefix2,
@regextrans2, @regexmess, @regexflag,
$flagsCase, $filterflags,
$sep1, $sep2,
$syncinternaldates,
$idatefromheader,
$usedatemanip,
$syncacls,
$fastio1, $fastio2,
$maxsize, $minsize, $maxage, $minage,
$exitwhenover,
$search,
$skipheader, @useheader,
$skipsize, $allowsizemismatch, $foldersizes, $buffersize,
$delete, $delete2,
$expunge, $expunge1, $expunge2, $uidexpunge2, $dry,
$justfoldersizes,
$authmd5, $authmd51, $authmd52,
$subscribed, $subscribe, $subscribe_all,
$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,
$timeout,
$timestart, $timeend, $timediff,
$timesize, $timebefore,
$ssl1, $ssl2,
$tls1, $tls2,
$uid1, $uid2,
$authuser1, $authuser2,
$proxyauth1, $proxyauth2,
$authmech1, $authmech2,
$split1, $split2,
$reconnectretry1, $reconnectretry2,
$relogin1, $relogin2,
$tests, $test_builder, $tests_debug,
$allow3xx, $justlogin,
$tmpdir,
$releasecheck,
$max_msg_size_in_bytes,
$modules_version,
$delete2folders, $delete2foldersonly, $delete2foldersbutnot,
$usecache, $debugcache, $cacheaftercopy,
$wholeheaderifneeded, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess,
$addheader,
%h1, %h2,
);
# main program
# global variables initialisation
$rcs = '$Id: imapsync,v 1.488 2012/04/15 17:38:21 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;
$nb_errors = 0;
$max_msg_size_in_bytes = 0;
my %month_abrev = (
Jan => 0,
Feb => 1,
Mar => 2,
Apr => 3,
May => 4,
Jun => 5,
Jul => 6,
Aug => 7,
Sep => 8,
Oct => 9,
Nov => 10,
Dec => 11,
);
unless(defined(&_SYSEXITS_H)) {
# 64 on my linux box.
eval 'sub EX_USAGE () {64;}' unless defined(&EX_USAGE);
}
# @ARGV will be eat by get_options()
my @argv_copy = @ARGV;
get_options();
$modules_version = defined($modules_version) ? $modules_version : 1;
# $SIG{ INT } = \&catch_continue ;
$releasecheck = defined($releasecheck) ? $releasecheck : 1;
my $warn_release = ($releasecheck) ? check_last_release() : '';
$SIG{ INT } = \&catch_exit ;
# default values
$tmpdir ||= File::Spec->tmpdir();
$pidfile ||= $tmpdir . '/imapsync.pid';
# allow Mail::IMAPClient 3.0.xx by default
$allow3xx = defined($allow3xx) ? $allow3xx : 1;
$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 ;
# turn on relogin 5 by default
$relogin1 = defined( $relogin1 ) ? $relogin1 : 5 ;
$relogin2 = defined( $relogin2 ) ? $relogin2 : 5 ;
if ( $fast ) {
# $useuid = 1 ;
$foldersizes = 0 ;
}
# Activate --usecache if --useuid is set and no --nousecache
$usecache = 1 if ( $useuid and ( ! defined( $usecache ) ) ) ;
$cacheaftercopy = 1 if ( $usecache and ( ! defined( $cacheaftercopy ) ) ) ;
print banner_imapsync(@argv_copy);
print "Temp directory is $tmpdir\n";
is_valid_directory($tmpdir);
write_pidfile($pidfile) if ($pidfile);
$modules_version and print "Modules version list:\n", modules_VERSION(), "\n";
check_lib_version() or
die "imapsync needs perl lib Mail::IMAPClient release 2.2.9, or 3.25 or superior \n";
exit_clean(0) if ($justbanner);
# By default, 1000 at a time, not more.
$split1 ||= 100;
$split2 ||= 100;
$host1 || missing_option("--host1") ;
$port1 ||= (defined $ssl1 and !defined $tls1) ? 993 : 143;
$host2 || missing_option("--host2") ;
$port2 ||= (defined $ssl2 && !defined $tls2) ? 993 : 143;
$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(0);
}
$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)) {
$expunge = 1;
}
}
if ( $uidexpunge2 and ! Mail::IMAPClient->can( 'uidexpunge' ) ) {
print "Failure: uidexpunge not supported (IMAPClient release < 3.17), use --expunge2 instead\n" ;
exit_clean( 3 ) ;
}
if ( $delete2 and ! defined( $uidexpunge2 ) ) {
if ( Mail::IMAPClient->can( 'uidexpunge' ) ) {
print "Info: will act as --uidexpunge2\n" ;
$uidexpunge2 = 1 ;
}elsif ( ! defined( $expunge2 ) ) {
print "Info: will act as --expunge2 (no uidexpunge support)\n" ;
$expunge2 = 1 ;
}
}
if ( $delete and $delete2 ) {
print "Warning: using --delete and --delete2 is almost always a bad idea, exiting imapsync\n" ;
exit_clean( 4 ) ;
}
if ($idatefromheader) {
print "Turned ON idatefromheader, ",
"will set the internal dates on host2 from the 'Date:' header line.\n";
$syncinternaldates = 0;
}
if ($syncinternaldates) {
print "Info: turned ON syncinternaldates, ",
"will set the internal dates (arrival dates) on host2 same as host1.\n";
}else{
print "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;
print "Info: will try to use $authmech1 authentication on host1\n";
print "Info: will try to use $authmech2 authentication on host2\n";
$syncacls = (defined($syncacls)) ? $syncacls : 0;
$foldersizes = (defined($foldersizes)) ? $foldersizes : 1;
$fastio1 = (defined($fastio1)) ? $fastio1 : 0;
$fastio2 = (defined($fastio2)) ? $fastio2 : 0;
$reconnectretry1 = (defined($reconnectretry1)) ? $reconnectretry1 : 3;
$reconnectretry2 = (defined($reconnectretry2)) ? $reconnectretry2 : 3;
@useheader = ( "Message-Id", "Message-ID", "Received" ) unless ( @useheader ) ;
my %useheader ;
# Make a hash %useheader of each --useheader 'key' in uppercase
@useheader{ map( { uc( $_ ) } @useheader ) } = ( ) ;
#require Data::Dumper ;
#print Data::Dumper->Dump( [ \%useheader ] ) ;
print "Host1: imap server [$host1] port [$port1] user [$user1]\n";
print "Host2: imap server [$host2] port [$port2] user [$user2]\n";
$password1 || $passfile1 || do {
$password1 = ask_for_password($authuser1 || $user1, $host1);
};
$password1 = (defined($passfile1)) ? firstline ($passfile1) : $password1;
$password2 || $passfile2 || do {
$password2 = ask_for_password($authuser2 || $user2, $host2);
};
$password2 = (defined($passfile2)) ? firstline ($passfile2) : $password2;
if ( ! ( 1
or ( $maxsize
or $minsize
or $maxage
or $minage )
and $usecache
and ! $delete ) ) {
die_clean(
"Problem --usecache can not be used safely with options --maxsize --minsize --maxage --minage
Use --nousecache or suppress the --max* --min* options\n" ) ;
}
my $imap1 = ();
my $imap2 = ();
$timestart = time( );
$timebefore = $timestart;
$debugimap1 and print "Host1 connection\n";
$imap1 = login_imap($host1, $port1, $user1, $domain1, $password1,
$debugimap1, $timeout, $fastio1, $ssl1, $tls1,
$authmech1, $authuser1, $reconnectretry1,
$proxyauth1, $uid1, $split1);
$debugimap2 and print "Host2 connection\n";
$imap2 = login_imap($host2, $port2, $user2, $domain2, $password2,
$debugimap2, $timeout, $fastio2, $ssl2, $tls2,
$authmech2, $authuser2, $reconnectretry2,
$proxyauth2, $uid2, $split2);
$debug and print "Host1 Buffer I/O: ", $imap1->Buffer(), "\n";
$debug and print "Host2 Buffer I/O: ", $imap2->Buffer(), "\n";
die_clean() unless $imap1->IsAuthenticated();
print "Host1: state Authenticated\n";
die_clean() unless $imap2->IsAuthenticated();
print "Host2: state Authenticated\n";
print "Host1 capability: ", join(" ", $imap1->capability_update()), "\n";
print "Host2 capability: ", join(" ", $imap2->capability_update()), "\n";
exit_clean(0) if ($justlogin);
#
# 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_from_1_wanted, %h2_folders_from_1_wanted,
@h2_folders_from_1_all, %h2_folders_from_1_all,
);
# Make a hash of subscribed folders in both servers.
map { $h1_subscribed_folder{ $_ } = 1 } $imap1->subscribed( );
map { $h2_subscribed_folder{ $_ } = 1 } $imap2->subscribed( );
# All folders on host1 and host2
@h1_folders_all = sort $imap1->folders();
@h2_folders_all = sort $imap2->folders();
map { $h1_folders_all{$_} = 1} @h1_folders_all;
map { $h2_folders_all{$_} = 1} @h2_folders_all;
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)) {
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);
print "Including folders matching pattern '$include': @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);
print "Excluding folders matching pattern '$exclude': @excluded_folders\n";
}
}
# Remove no selectable folders
foreach my $folder (keys(%requested_folder)) {
if ( not $imap1->selectable($folder)) {
print "Warning: ignoring folder $folder because it is not selectable\n";
remove_from_requested_folders($folder);
}
}
my @requested_folder = sort(keys(%requested_folder));
@h1_folders_wanted = @requested_folder;
#my $h1_namespace = $imap1->namespace() ;
#my $h2_namespace = $imap2->namespace() ;
#require Data::Dumper ;
#$debug and print "Host1 namespace:\n", Data::Dumper->Dump([$h1_namespace]) ;
#$debug and print "Host2 namespace:\n", Data::Dumper->Dump([$h2_namespace]) ;
my($h1_sep,$h2_sep);
# what are the private folders separators for each server ?
$debug and print "Getting separators\n";
$h1_sep = get_separator($imap1, $sep1, "--sep1");
$h2_sep = get_separator($imap2, $sep2, "--sep2");
my($h1_prefix,$h2_prefix);
$h1_prefix = get_prefix($imap1, $prefix1, "--prefix1");
$h2_prefix = get_prefix($imap2, $prefix2, "--prefix2");
print "Host1 separator and prefix: [$h1_sep][$h1_prefix]\n";
print "Host2 separator and prefix: [$h2_sep][$h2_prefix]\n";
foreach my $h1_fold (@h1_folders_wanted) {
my $h2_fold;
$h2_fold = imap2_folder_name($h1_fold);
$h2_folders_from_1_wanted{$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}++;
}
#@h2_folders_from_1_all = sort keys(%h2_folders_from_1_all);
if ($foldersizes) {
foldersizes( "Host1", $imap1, @h1_folders_wanted ) ;
foldersizes( "Host2", $imap2, @h2_folders_from_1_wanted ) ;
sleep( 2 ) ;
}
exit_clean(0) if ($justfoldersizes);
print
"++++ Listing folders\n",
"Host1 folders list:\n", map("[$_]\n",@h1_folders_all),"\n",
"Host2 folders list:\n", map("[$_]\n",@h2_folders_all),"\n";
print
"Host1 subscribed folders list: ",
map( "[$_] ", 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();
print "Folders in host2 not in host1:\n",
map("[$_]\n", @h2_folders_not_in_1),"\n";
delete_folders_in_2_not_in_1() if $delete2folders;
# folder loop
print "++++ Looping on each folder\n";
FOLDER: foreach my $h1_fold (@h1_folders_wanted) {
my $h2_fold = imap2_folder_name( $h1_fold ) ;
#relogin1( ) if ( $relogin1 ) ;
printf( "%-35s -> %-35s\n", "[$h1_fold]", "[$h2_fold]" ) ;
# host1 can not be fetched read only, select is needed because of expunge.
select_folder( $imap1, $h1_fold, 'Host1' ) or next FOLDER ;
#examine_folder( $imap1, $h1_fold, 'Host1' ) or next FOLDER ;
if ( ! exists( $h2_folders_all{ $h2_fold } ) ) {
create_folder( $imap2, $h2_fold, $h1_fold ) or next FOLDER ;
}
acls_sync( $h1_fold, $h2_fold ) ;
# 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( ) ;
#print "%%% @select_results\n" ;
my $permanentflags2 = permanentflags( @select_results ) ;
$debug and print "permanentflags: $permanentflags2\n" ;
if ( $expunge or $expunge1 ){
print "Expunging host1 $h1_fold\n" ;
unless($dry) { $imap1->expunge() } ;
#print "Expunging host2 $h2_fold\n" ;
#unless($dry) { $imap2->expunge() } ;
}
if ( ( ( $subscribe and exists $h1_subscribed_folder{ $h1_fold } ) or $subscribe_all )
and ! exists $h2_subscribed_folder{ $h2_fold } ) {
print "Subscribing to folder $h2_fold on destination server\n" ;
unless( $dry ) { $imap2->subscribe( $h2_fold ) } ;
}
next FOLDER if ($justfolders);
my $h1_msgs_all_hash_ref = { } ;
my @h1_msgs = select_msgs( $imap1, $h1_msgs_all_hash_ref );
my $h1_msgs_nb = scalar( @h1_msgs ) ;
$h1{ $h1_fold }{ 'messages_nb' } = $h1_msgs_nb ;
( $debug or $debugLIST ) and print "Host1 LIST: $h1_msgs_nb messages [@h1_msgs]\n" ;
my $h2_msgs_all_hash_ref = { } ;
my @h2_msgs = select_msgs( $imap2, $h2_msgs_all_hash_ref ) ;
my $h2_msgs_nb = scalar( @h2_msgs ) ;
$h2{ $h2_fold }{ 'messages_nb' } = $h2_msgs_nb ;
( $debug or $debugLIST ) and print "Host2 LIST: $h2_msgs_nb messages [@h2_msgs]\n";
my $cache_base = "$tmpdir/imapsync_cache/$host1/$user1/$host2/$user2";
my $cache_dir = cache_folder( $cache_base, $h1_fold, $h2_fold );
my ( $cache_1_2_ref, $cache_2_1_ref ) = ( {}, {} );
if ( $usecache ) {
print "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 ) ;
print "CACHE h1 h2: ", scalar( keys %$cache_1_2_ref ), " files\n" ;
$debug and print '[',
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 ;
#print "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 = ( ) ;
#print "delete2: @h2_msgs_delete2_not_in_cache\n";
}
$debug and print "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 print "Host1 parsing headers of folder [$h1_fold] took ", timenext(), " s\n";
@$h1_fir_ref{@h1_msgs} = (undef);
$debug and print "Host1 getting flags idate and sizes of folder [$h1_fold]\n" ;
$h1_fir_ref = $imap1->fetch_hash("FLAGS", "INTERNALDATE", "RFC822.SIZE", $h1_fir_ref)
if (@h1_msgs);
$debug and print "Host1 getting flags idate and sizes of folder [$h1_fold] took ", timenext(), " s\n";
unless ($h1_fir_ref) {
print
"Host1 folder $h1_fold: Could not fetch_hash ",
scalar(@h1_msgs), " msgs: ", $imap1->LastError, "\n";
$nb_errors++;
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;
print "Host1 $h1_fold/$m size $h1_size ignored (no wanted headers so we ignore this message)\n" ;
$total_bytes_skipped += $h1_size;
$nb_msg_skipped += 1;
$h1_nb_msg_noheader +=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;
}
}
my $h1_msgs_duplicate_nb = scalar( @h1_msgs_duplicate ) ;
$h1{ $h1_fold }{ 'duplicates_nb' } = $h1_msgs_duplicate_nb ;
$debug and print "Host1 selected: $h1_msgs_nb duplicates: $h1_msgs_duplicate_nb\n" ;
$debug and print "Host1 whole time parsing headers took ", timenext(), " s\n";
$debug and print "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 print "Host2 parsing headers of folder [$h2_fold] took ", timenext(), " s\n" ;
$debug and print "Host2 getting flags idate and sizes of folder [$h2_fold]\n" ;
@$h2_fir_ref{@h2_msgs} = ( ); # fetch_hash can select by uid with last arg as ref
$h2_fir_ref = $imap2->fetch_hash("FLAGS", "INTERNALDATE", "RFC822.SIZE", $h2_fir_ref)
if (@h2_msgs);
$debug and print "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)) {
print "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);
}
}
my $h2_msgs_duplicate_nb = scalar( @h2_msgs_duplicate ) ;
$h2{ $h2_fold }{ 'duplicates_nb' } = $h2_msgs_duplicate_nb ;
$debug and print "Host2 selected: $h2_msgs_nb duplicates: $h2_msgs_duplicate_nb\n" ;
$debug and print "Host2 whole time parsing headers took ", timenext(), " s\n";
$debug and print "++++ 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);
#print map { $h1_hash{$_}{'m'} . " "} @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 ( 0 ) {
# hashes, keys are uid, values are the internaldates in epoch (best format to compare dates)
my %h1_epoch ;
my %h2_epoch ;
@h1_epoch{ @h1_msgs } = map( { epoch( $h1_fir_ref->{ $_ }->{ 'INTERNALDATE' } ) } @h1_msgs ) ;
@h2_epoch{ @h2_msgs } = map( { epoch( $h2_fir_ref->{ $_ }->{ 'INTERNALDATE' } ) } @h2_msgs ) ;
#print keyval( %h1_epoch ) ;
#print keyval( %h2_epoch ) ;
my $h1_greatest_epoch = max( values %h1_epoch ) ;
print "h1_greatest_epoch $h1_greatest_epoch\n" ;
}
#next FOLDER ;
if($delete2) {
my @h2_expunge;
foreach my $m_id (@h2_hash_keys_sorted_by_uid) {
#print "$m_id ";
unless (exists($h1_hash{$m_id})) {
my $h2_msg = $h2_hash{$m_id}{'m'};
my $h2_flags = $h2_hash{$m_id}{'F'} || "";
my $isdel = $h2_flags =~ /\B\\Deleted\b/ ? 1 : 0;
print "msg $h2_fold/$h2_msg marked \\Deleted on host2 [$m_id]\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_duplicate) {
print "msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2\n";
push(@h2_expunge, $h2_msg) if $uidexpunge2;
unless ($dry) {
$imap2->delete_message($h2_msg);
$h2_nb_msg_deleted += 1;
}
}
foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) {
print "msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2\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 ) {
print "uidexpunge $cnt message(s)\n" ;
$imap2->uidexpunge( \@h2_expunge ) if ! $dry ;
}
if ($expunge2){
print "Expunging host2 folder $h2_fold\n" ;
$imap2->expunge( ) if ! $dry ;
}
}
my $h2_uidnext = $imap2->uidnext( $h2_fold ) ;
$debug and print "Host2 uidnext: $h2_uidnext\n" ;
$h2_uidguess = $h2_uidnext ;
MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) {
my $h1_size = $h1_hash{$m_id}{'s'};
my $h1_msg = $h1_hash{$m_id}{'m'};
my $h1_idate = $h1_hash{$m_id}{'D'};
unless (exists($h2_hash{$m_id})) {
# copy
copy_message( $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ;
last FOLDER if total_bytes_max_reached( ) ;
next MESS;
}
else{
# already on host2
my $h2_msg = $h2_hash{$m_id}{'m'} ;
$debug and print "Host1 found msg $h1_fold/$h1_msg equals Host2 $h2_fold/$h2_msg\n" ;
$total_bytes_skipped += $h1_size ;
$nb_msg_skipped += 1 ;
$debugcache and print "touch $cache_dir/${h1_msg}_$h2_msg\n" if ( $usecache ) ;
touch( "$cache_dir/${h1_msg}_$h2_msg" ) if ( $usecache ) ;
}
#$debug and print "MESSAGE $m_id\n";
my $h2_msg = $h2_hash{$m_id}{'m'};
sync_flags( $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 print
"Host1 size msg $h1_fold/$h1_msg = $h1_size <> $h2_size = Host2 $h2_fold/$h2_msg\n";
if( $delete ) {
print "Host1 msg $h1_fold/$h1_msg deleted\n";
unless( $dry ) {
$imap1->delete_message( $h1_msg );
$h1_nb_msg_deleted += 1;
$imap1->expunge() if ( $expunge or $expunge1 );
}
}
}
# END MESS: loop
MESS_IN_CACHE: foreach my $h1_msg ( @h1_msgs_in_cache ) {
my $h2_msg = $cache_1_2_ref->{ $h1_msg } ;
$debugcache and print "cache messages update flags $h1_msg->$h2_msg\n";
sync_flags( $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;
}
#print "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 print "Copy by uid $h1_fold/$h1_msg\n" ;
copy_message( $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ;
last FOLDER if total_bytes_max_reached( ) ;
}
if ($expunge or $expunge1){
print "Expunging host1 folder $h1_fold\n";
unless($dry) { $imap1->expunge() };
}
if ($expunge2){
print "Expunging host2 folder $h2_fold\n";
unless($dry) { $imap2->expunge() };
}
$debug and print "Time: ", timenext(), " s\n";
}
sub total_bytes_max_reached {
return( 0 ) if not $exitwhenover ;
if ( $total_bytes_transferred >= $exitwhenover ) {
print "Maximum bytes transfered reached, $total_bytes_transferred >= $exitwhenover, ending sync\n" ;
return( 1 ) ;
}
}
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 {
my ( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ;
$debug and print "Host1 flags $h1_fold/$h1_msg -> Host2 $h2_fold/$h2_msg\n";
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" } || '' ;
my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ "FLAGS" } || '' ;
( $debug or $debugflags ) and
print "Host1 flags init msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 $h2_fold/$h2_msg flags( $h2_flags )\n" ;
# RFC 2060: This flag can not be altered by any client
$h1_flags =~ s@\\Recent\s?@@gi ;
$h1_flags = flags_regex( $h1_flags ) if @regexflag;
$h1_flags = flagsCase( $h1_flags ) if $flagsCase ;
$h1_flags = flags_filter( $h1_flags, $permanentflags2) if ( $permanentflags2 and $filterflags ) ;
# compare flags - set flags if there a difference
my @h1_flags = sort split(' ', $h1_flags );
my @h2_flags = sort split(' ', $h2_flags );
my $diff = compare_lists( \@h1_flags, \@h2_flags );
#$diff = 1 ;
( $debug or $debugflags ) and print "Host1 flags filt msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 $h2_fold/$h2_msg flags( $h2_flags )\n" ;
$diff and ( $debug or $debugflags )
and print "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 ( ! $dry and $diff and ! $imap2->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) {
print "Host2 flags msg $h2_fold/$h2_msg could not add flags [@h1_flags]: ",
$imap2->LastError, "\n";
#$nb_errors++;
}
}
print "++++ End looping on each folder\n";
#print memory_consumption();
$imap1->logout();
$imap2->logout();
stats();
exit_clean(1) if( $nb_errors );
exit_clean(0);
# END of main program
# subroutines
sub max {
return(undef) if (0 == scalar(@_));
my @sorted = sort { $a <=> $b } @_;
return(pop(@sorted));
}
sub tests_max {
ok(0 == max(0), "max 0");
ok(1 == max(1), "max 1");
ok(-1 == max(-1), "max -1");
ok(! defined(max()), "max no arg");
ok(100 == max(1, 100), "max 1 100");
ok(100 == max(100, 1), "max 100 1");
ok(100 == max(100, 42, 1), "max 100 42 1");
ok(100 == max(100, "42", 1), "max 100 42 1");
ok(100 == max("100", "42", 1), "max 100 42 1");
#ok(100 == max(100, "haha", 1), "max 100 42 1");
}
sub keyval {
my %hash = @_ ;
return( join( " ", map( { "$_ => " . $hash{ $_ } } keys %hash ) ) . "\n" ) ;
}
sub check_lib_version {
$debug and print "IMAPClient $Mail::IMAPClient::VERSION\n";
if ($Mail::IMAPClient::VERSION eq '2.2.9') {
override_imapclient();
return(1);
}
else{
# 3.x.x is no longer buggy with imapsync.
if ($allow3xx) {
return(1);
}else{
return(0);
}
}
}
sub modules_VERSION {
my @list_version;
foreach my $module (qw(
Mail::IMAPClient
IO::Socket
IO::Socket::INET
IO::Socket::SSL
Digest::MD5
Digest::HMAC_MD5
Term::ReadKey
Authen::NTLM))
{
my $v = "?";
if (eval "require $module") {
# module is here
$v = eval "\$${module}::VERSION";
}else{
# no module
$v = "?";
}
#print ("$module ", $v, "\n");
push (@list_version, sprintf("%-20s %s\n", $module, $v));
}
return(@list_version);
}
# Construct a command line copy with passwords replaced by MASKED.
sub command_line_nopassword {
my @argv_copy = @_;
my @argv_nopassword;
while (@argv_copy) {
my $arg = shift(@argv_copy); # option name or value
if ($arg =~ m/-password[12]/) {
shift(@argv_copy); # 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('' eq command_line_nopassword(), 'command_line_nopassword void');
ok('--blabla' eq command_line_nopassword('--blabla'), 'command_line_nopassword --blabla');
#print 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');
}
sub ask_for_password {
my ($user, $host) = @_;
print "What's the password for $user\@$host? ";
Term::ReadKey::ReadMode(2);
my $password = <>;
chomp $password;
printf "\n";
Term::ReadKey::ReadMode(0);
return $password;
}
sub catch_exit {
my $signame = shift ;
print "\nGot a SIG$signame!\n" ;
stats( ) ;
exit_clean( ) ;
}
sub catch_continue {
my $signame = shift ;
print "\nGot a SIG$signame!\n" ;
}
sub myconnect {
my $self = shift;
$debug and print "Entering myconnect\n";
%$self = (%$self, @_);
my $sock = (($self->Ssl) ? IO::Socket::SSL->new : IO::Socket::INET->new);
my $dp = ($self->Ssl ? 'imaps(993)' : 'imap(143)');
$debug and print "Calling configure\n";
my $ret = $sock->configure({
PeerAddr => $self->Server ,
PeerPort => $self->Port||$dp ,
Proto => 'tcp' ,
Timeout => $self->Timeout||0 ,
Debug => $self->Debug ,
});
unless ( defined($ret) ) {
$self->LastError( "$@\n");
$@ = "$@";
carp "$@"
unless defined wantarray;
return undef;
}
$sock->autoflush(1);
my $banner = $sock->getline();
$debug and print "Read: $banner";
$self->Banner($banner);
$self->RawSocket2($sock);
$self->State(Connected);
if ($banner =~ /\* PREAUTH/)
{
$self->State(Authenticated);
}
if ($self->Tls) {
starttls($self);
$self->Starttls( 1 ) ;
}
$self->Ignoresizeerrors($allowsizemismatch);
if ($self->User and $self->Password) {
$debug and print "Calling login\n";
return $self->login ;
}
else {
return $self;
}
}
sub starttls {
my $self = shift;
my $socket = $self->RawSocket2();
$debug and print "Entering starttls\n";
unless ($self->has_capability("STARTTLS")) {
die_clean( "No STARTTLS capability" );
}
print $socket, "\n";
print $socket "z00 STARTTLS\015\012";
CORE::select( undef, undef, undef, 0.025 );
my $txt = $socket->getline();
$debug and print "Read tls: $txt";
unless($txt =~ /^z00 OK/){
die_clean( "Invalid response for STARTTLS: $txt\n" );
}
$debug and print "Calling start_SSL\n";
unless(IO::Socket::SSL->start_SSL($socket,
{
SSL_version => "TLSV1",
SSL_startHandshake => 1,
SSL_verify_depth => 1,
}))
{
die_clean( "Couldn't start TLS: ".IO::Socket::SSL::errstr()."\n");
}
if (ref($socket) ne "IO::Socket::SSL") {
die_clean( "Socket has NOT been converted to SSL");
}else{
$debug and print "Socket successfuly converted to SSL\n";
}
$debug and print "Ending starttls\n";
}
sub connect_imap {
my($host, $port, $debugimap, $ssl, $tls) = @_;
my $imap = Mail::IMAPClient->new();
$imap->Ssl($ssl) if ($ssl);
$imap->Tls($tls) if ($tls);
$imap->Server($host);
$imap->Port($port);
$imap->Debug($debugimap);
#$imap->connect()
myconnect($imap)
or die_clean("Can not open imap connection on [$host]: $@\n");
}
sub justconnect {
my $imap1 = ();
my $imap2 = ();
$imap1 = connect_imap($host1, $port1, $debugimap1, $ssl1, $tls1);
print "Host1 software: ", server_banner($imap1);
print "Host1 capability: ", join(" ", $imap1->capability()), "\n";
$imap2 = connect_imap($host2, $port2, $debugimap2, $ssl2, $tls2);
print "Host2 software: ", server_banner($imap2);
print "Host2 capability: ", join(" ", $imap2->capability()), "\n";
$imap1->logout();
$imap2->logout();
}
sub relogin1 {
$imap1 = relogin_imap(
$imap1,
$host1, $port1, $user1, $domain1, $password1,
$debugimap1, $timeout, $fastio1, $ssl1, $tls1,
$authmech1, $authuser1, $reconnectretry1,
$proxyauth1, $uid1, $split1) ;
$relogin1-- if ( $relogin1 ) ;
}
sub relogin2 {
$imap2 = relogin_imap(
$imap2,
$host2, $port2, $user2, $domain2, $password2,
$debugimap2, $timeout, $fastio2, $ssl2, $tls2,
$authmech2, $authuser2, $reconnectretry2,
$proxyauth2, $uid2, $split2) ;
$relogin2-- if ( $relogin2 ) ;
}
sub relogin_imap {
my($imap,
$host, $port, $user, $domain, $password,
$debugimap, $timeout, $fastio,
$ssl, $tls, $authmech, $authuser, $reconnectretry,
$proxyauth, $uid, $split) = @_;
my $folder_current = $imap->Folder ;
$imap->logout( ) ;
$imap = login_imap(
$host, $port, $user, $domain, $password,
$debugimap, $timeout, $fastio,
$ssl, $tls, $authmech, $authuser, $reconnectretry,
$proxyauth, $uid, $split
) ;
$imap->select( $folder_current ) if defined( $folder_current ) ;
return( $imap ) ;
}
sub login_imap {
my($host, $port, $user, $domain, $password,
$debugimap, $timeout, $fastio,
$ssl, $tls, $authmech, $authuser, $reconnectretry,
$proxyauth, $uid, $split ) = @_;
my ($imap);
$imap = Mail::IMAPClient->new();
$imap->Ssl($ssl) if ($ssl);
$imap->Tls($tls) if ($tls);
$imap->Clear(1);
$imap->Server($host);
$imap->Port($port);
$imap->Fast_io($fastio);
$imap->Buffer($buffersize || 4096);
$imap->Uid($uid);
#$imap->Uid(0);
$imap->Peek(1);
$imap->Debug($debugimap);
$timeout and $imap->Timeout($timeout);
$imap->Reconnectretry($reconnectretry) if ($reconnectretry);
#$imap->connect()
myconnect($imap)
or die_clean("Failure: can not open imap connection on [$host] with user [$user]: $@\n");
print "Banner: ", server_banner($imap);
if ($authmech eq 'PREAUTH') {
$imap->Socket;
printf("Info: Assuming PREAUTH for host %s\n",
$imap->Server);
}
elsif ($imap->has_capability("AUTH=$authmech")
or $imap->has_capability($authmech)
) {
printf("Info: host %s says it has CAPABILITY for AUTHENTICATE %s\n",
$imap->Server, $authmech);
}
else {
printf("Info: host %s says it has NO CAPABILITY for AUTHENTICATE %s\n",
$imap->Server, $authmech);
if ($authmech eq 'PLAIN') {
print "Info: frequently PLAIN is only supported with SSL, ",
"try --ssl or --tls options\n";
}
}
if ($proxyauth) {
$imap->Authmechanism("");
} else {
$imap->Authmechanism($authmech) unless ($authmech eq 'LOGIN' or $authmech eq 'PREAUTH');
}
$imap->Authcallback(\&plainauth) if $authmech eq "PLAIN";
if ($proxyauth) {
$imap->User($authuser);
$imap->Domain($domain) if (defined($domain));
$imap->Authuser($authuser);
$imap->Password($password);
} else {
$imap->User($user);
$imap->Domain($domain) if (defined($domain));
$imap->Authuser($authuser);
$imap->Password($password);
}
unless ($authmech eq 'PREAUTH' or $imap->login()) {
my $info = "Failure: error login [$host] with user [$user] auth";
my $einfo = $imap->LastError || @{$imap->History}[-1];
chomp($einfo);
my $error = "$info [$authmech]: $einfo\n";
print $error; # note: duplicating error on stdout/stderr
die_clean($error) if ($authmech eq 'LOGIN' or $imap->IsUnconnected() or $authuser);
print "Info: trying LOGIN Auth mechanism on [$host] with user [$user]\n";
$imap->Authmechanism("");
$imap->login() or
die_clean("$info [LOGIN]: ", $imap->LastError, "\n");
}
$proxyauth && $imap->proxyauth($user);
$split and $imap->Split( $split ) ;
print "Info: success login on [$host] with user [$user] auth [$authmech]\n";
return($imap);
}
sub plainauth() {
my $code = shift;
my $imap = shift;
my $string = sprintf("%s\x00%s\x00%s", $imap->User,
$imap->Authuser, $imap->Password);
return encode_base64("$string", "");
}
sub server_banner {
my $imap = shift;
my $banner = $imap->Banner() || "No banner\n";
return $banner;
}
sub banner_imapsync {
my @argv_copy = @_;
my $banner_imapsync = join("",
'$RCSfile: imapsync,v $ ',
'$Revision: 1.488 $ ',
'$Date: 2012/04/15 17:38:21 $ ',
"\n",localhost_info(), "\n",
"Command line used:\n",
"$0 ", command_line_nopassword(@argv_copy), "\n",
);
}
sub is_valid_directory {
my $dir = shift;
return(1) if (-d $dir and -r _ and -w _);
# Trying to create it
mkpath($dir) or die "Error creating tmpdir $tmpdir : $!";
die "Error with tmpdir $tmpdir : $!" if not (-d $dir and -r _ and -w _);
return(1);
}
sub write_pidfile {
my $pidfile = shift;
print "PID file is $pidfile\n";
if (-e $pidfile) {
print "$pidfile already exists, overwriting it\n";
}
open(PIDFILE, ">$pidfile") or do {
print "Could not open $pidfile for writing";
return undef;
};
print PIDFILE $PROCESS_ID;
close PIDFILE;
return($PROCESS_ID);
}
sub exit_clean {
my $status = shift;
$status = defined( $status ) ? $status : 1 ;
unlink($pidfile);
exit($status);
}
sub die_clean {
unlink($pidfile);
die @_;
}
sub missing_option {
my ($option) = @_;
die_clean("$option option must be used, run $0 --help for help\n");
}
sub select_folder {
my ( $imap, $folder, $hostside ) = @_ ;
if ( ! $imap->select( $folder ) ) {
print
"$hostside folder $folder: Could not select: ",
$imap->LastError, "\n" ;
$nb_errors++ ;
return( 0 ) ;
}else{
# ok select succeeded
return( 1 ) ;
}
}
sub examine_folder {
my ( $imap, $folder, $hostside ) = @_ ;
if ( ! $imap->examine( $folder ) ) {
print
"$hostside folder $folder: Could not examine: ",
$imap->LastError, "\n" ;
$nb_errors++ ;
return( 0 ) ;
}else{
# ok examine succeeded
return( 1 ) ;
}
}
sub create_folder {
my( $imap2, $h2_fold, $h1_fold ) = @_ ;
print "Creating folder [$h2_fold] on host2\n";
if ( ( 'INBOX' eq uc( $h2_fold) )
and ( $imap2->exists( $h2_fold ) ) ) {
print "Folder [$h2_fold] already exists\n" ;
return( 1 ) ;
}
if ( ! $dry ){
if ( ! $imap2->create( $h2_fold ) ) {
print( "Couldn't create folder [$h2_fold] from [$h1_fold]: ",
$imap2->LastError( ), "\n" );
$nb_errors++;
# success if folder exists ("already exists" error)
return( 1 ) if $imap2->exists( $h2_fold ) ;
# failure since create failed
return( 0 );
}else{
#create succeeded
return( 1 );
}
}else{
# dry mode, no folder so many imap will fail, assuming failure
return( 0 );
}
}
sub tests_folder_routines {
ok( !is_requested_folder('folder_foo') );
ok( add_to_requested_folders('folder_foo') );
ok( is_requested_folder('folder_foo') );
ok( !is_requested_folder('folder_NO_EXIST') );
ok( !remove_from_requested_folders('folder_foo'), "removed folder_foo");
ok( !is_requested_folder('folder_foo') );
my @f;
ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f");
ok( is_requested_folder('folder_bar') );
ok( is_requested_folder('folder_toto') );
ok( remove_from_requested_folders('folder_toto') );
ok( !is_requested_folder('folder_toto') );
}
sub is_requested_folder {
my ( $folder ) = @_;
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(-1) 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 = -1;
#print "\$#$list_1_ref:", $#$list_1_ref, "\n";
#print "\$#$list_2_ref:", $#$list_2_ref, "\n";
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 -1 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(-1 == compare_lists(undef , []) , 'compare_lists, undef < []');
ok(-1 == compare_lists(undef , [1]) , 'compare_lists, undef < [1]');
ok(-1 == 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(-1 == 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(-1 == compare_lists( 0 , 1 ) , "compare_lists, 0 < 1 ") ;
ok(-1 == compare_lists(-1 , 0 ) , "compare_lists, -1 < 0 ") ;
ok(-1 == 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(-1 == compare_lists([1], [1,2]) , "compare_lists, [1] < [1,2]") ;
ok(+1 == compare_lists([2], [1,2]) , "compare_lists, [2] > [1,2]") ;
ok(-1 == 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 .. 20_000] , [1 .. 20_000])
, "compare_lists, [1..20_000] = [1..20_000]") ;
ok(-1 == compare_lists([1], [3]) , 'compare_lists, [1] < [3]') ;
ok( 0 == compare_lists([2], [2]) , 'compare_lists, [0] = [2]') ;
ok(+1 == compare_lists([3], [1]) , 'compare_lists, [3] > [1]') ;
ok(-1 == 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(-1 == compare_lists(["a"], ["aa"]) , 'compare_lists, ["a"] < ["aa"]') ;
ok(-1 == compare_lists(["a"], ["a", "a"]), 'compare_lists, ["a"] < ["a", "a"]') ;
ok( 0 == compare_lists([split(" ", "a b")], ["a", "b"]), 'compare_lists, split') ;
ok( 0 == compare_lists([sort split(" ", "b a")], ["a", "b"]), 'compare_lists, sort split') ;
}
sub get_prefix {
my($imap, $prefix_in, $prefix_opt) = @_;
my($prefix_out);
$debug and print "Getting prefix namespace\n";
if (defined($prefix_in)) {
print "Using [$prefix_in] given by $prefix_opt\n";
$prefix_out = $prefix_in;
return($prefix_out);
}
$debug and print "Calling namespace capability\n";
if ($imap->has_capability("namespace")) {
my $r_namespace = $imap->namespace();
$prefix_out = $r_namespace->[0][0][0];
return($prefix_out);
}
else{
print
"No NAMESPACE capability in imap server ",
$imap->Server(),"\n",
help_to_guess_prefix($imap, $prefix_opt);
exit_clean(1);
}
}
sub get_separator {
my($imap, $sep_in, $sep_opt) = @_;
my($sep_out);
if ( defined( $sep_in ) ) {
print "Using [$sep_in] given by $sep_opt\n";
$sep_out = $sep_in;
return($sep_out);
}
$debug and print "Calling namespace capability\n";
if ($imap->has_capability("namespace")) {
$sep_out = $imap->separator();
return($sep_out) if defined $sep_out;
print
"NAMESPACE request failed for ",
$imap->Server(), ": ", $imap->LastError, "\n",
help_to_guess_sep( $imap, $sep_opt ) ;
exit_clean(1);
}
else{
print
"No NAMESPACE capability in imap server ",
$imap->Server(),"\n",
help_to_guess_sep($imap, $sep_opt);
exit_clean(1);
}
}
sub help_to_guess_sep {
my($imap, $sep_opt) = @_;
my $help = "Give the separator character with the $sep_opt option,\n"
. "the folowing listing of folders may help you to find it:\n"
. folders_list_to_help($imap)
. "Most of the time it is character . or /\n"
. "so try $sep_opt . or $sep_opt /\n";
return($help);
}
sub help_to_guess_prefix {
my($imap, $prefix_opt) = @_;
my $help = "Give 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)
. "Most of the time it is INBOX. or an empty string\n"
. "so try $prefix_opt INBOX. or $prefix_opt ''\n";
return($help);
}
sub folders_list_to_help {
my($imap) = @_;
my @folders = $imap->folders;
my $listing = join('', map { "[$_]\n" } @folders);
return $listing;
}
sub separator_invert {
# The separator we hope we'll never encounter: 00000000
my $o_sep="\000";
my($h1_fold, $h1_sep, $h2_sep) = @_;
my $h2_fold = $h1_fold;
$h2_fold =~ s@\Q$h2_sep@$o_sep@g;
$h2_fold =~ s@\Q$h1_sep@$h2_sep@g;
$h2_fold =~ s@\Q$o_sep@$h1_sep@g;
return($h2_fold);
}
sub tests_imap2_folder_name {
$h1_prefix = $h2_prefix = '';
$h1_sep = '/';
$h2_sep = '.';
$debug and print
"prefix1: [$h1_prefix]
prefix2: [$h2_prefix]
sep1:[$h1_sep]
sep2:[$h2_sep]
";
ok('' eq imap2_folder_name(''), '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');
@regextrans2 = ('s,/,X,g');
ok('' eq imap2_folder_name(''), '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 = ('s,(.*),\U$1,');
ok('BLABLA' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla [s,\U(.*)\E,$1,]');
}
sub imap2_folder_name {
my ($h2_fold);
my ($x_fold) = @_;
# first we remove the prefix
$x_fold =~ s/^\Q$h1_prefix\E//;
$debug and print "removed host1 prefix: [$x_fold]\n";
$h2_fold = separator_invert($x_fold,$h1_sep, $h2_sep);
$debug and print "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$/i));
$debug and print "added host2 prefix: [$h2_fold]\n";
# Transforming the folder name by the --regextrans2 option(s)
foreach my $regextrans2 (@regextrans2) {
my $h2_fold_before = $h2_fold;
eval("\$h2_fold =~ $regextrans2");
$debug and print "[$h2_fold_before] -> [$h2_fold] using re [$regextrans2]\n";
die_clean("error: eval regextrans2 '$regextrans2': $@\n") if $@;
}
return($h2_fold);
}
sub foldersizes {
my ( $side, $imap, @folders ) = @_ ;
my $total_size = 0 ;
my $total_nb = 0 ;
my $biggest = 0 ;
print "++++ Calculating sizes\n" ;
foreach my $folder ( @folders ) {
my $stot = 0 ;
my $nb_msgs = 0 ;
printf( "$side folder %-35s", "[$folder]" ) ;
if ( 'Host2' eq $side and ! exists( $h2_folders_all{ $folder } ) ) {
print(" does not exist yet\n") ;
next ;
}
if ( 'Host1' eq $side and ! exists( $h1_folders_all{ $folder } ) ) {
print( " does not exist\n" ) ;
next ;
}
unless ( $imap->examine( $folder ) ) {
print
"$side Folder $folder: Could not examine: ",
$imap->LastError, "\n" ;
$nb_errors++ ;
next ;
}
my $hash_ref = { } ;
my @msgs = select_msgs( $imap ) ;
$nb_msgs = scalar( @msgs ) ;
my $smax = 0 ;
@$hash_ref{ @msgs } = ( undef ) if @msgs ;
if ( $nb_msgs > 0 and @msgs ) {
$imap->fetch_hash("RFC822.SIZE",$hash_ref) or die_clean("$@") ;
#print map {$hash_ref->{$_}->{"RFC822.SIZE"}, " "} keys %$hash_ref ;
map { $stot += $hash_ref->{ $_ }->{ "RFC822.SIZE" } } keys %$hash_ref ;
$smax = max( map { $hash_ref->{ $_ }->{ "RFC822.SIZE" } } keys %$hash_ref ) ;
$biggest = max( $biggest, $smax ) ;
}
printf( " Size: %9s", $stot ) ;
printf( " Messages: %5s", $nb_msgs ) ;
printf( " Biggest: %9s\n", $smax ) ;
$total_size += $stot ;
$total_nb += $nb_msgs ;
}
printf ( "Nb messages: %11s\n", $total_nb ) ;
printf ( "Total size: %11s bytes\n", $total_size ) ;
printf ( "Biggest message: %11s bytes\n", $biggest ) ;
printf ( "Time: %11s seconds\n", timenext( ) ) ;
}
sub timenext {
my ($timenow, $timerel);
# $timebefore is global, beurk !
$timenow = time;
$timerel = $timenow - $timebefore;
$timebefore = $timenow;
return($timerel);
}
sub tests_flags_regex {
my $string;
ok('' eq flags_regex(''), "flags_regex, null string ''");
ok('\Seen NonJunk $Spam' eq flags_regex('\Seen NonJunk $Spam'), 'flags_regex, nothing to do');
ok('\Seen NonJunk $Spam' eq flags_regex('\Seen NonJunk $Spam'), 'flags_regex,');
@regexflag = ('s/NonJunk//g');
ok('\Seen $Spam' eq flags_regex('\Seen NonJunk $Spam'), "flags_regex, remove NonJunk: 's/NonJunk//g'");
@regexflag = ('s/\$Spam//g');
ok('\Seen NonJunk ' eq flags_regex('\Seen NonJunk $Spam'), 'flags_regex, remove $Spam: '."'s/\$Spam//g'");
@regexflag = ('s/\\\\Seen//g');
ok(' NonJunk $Spam' eq flags_regex('\Seen NonJunk $Spam'), 'flags_regex, remove \Seen: '. "'s/\\\\\\\\Seen//g'");
@regexflag = ('s/(\s|^)[^\\\\]\w+//g');
ok('\Seen \Middle \End' eq flags_regex('\Seen NonJunk \Middle $Spam \End'), 'flags_regex, only \word [' . flags_regex('\Seen NonJunk \Middle $Spam \End'.']'));
ok(' \Seen \Middle \End1' eq flags_regex('Begin \Seen NonJunk \Middle $Spam \End1 End'), 'flags_regex, only \word [' . flags_regex('Begin \Seen NonJunk \Middle $Spam \End1 End'.']'));
@regexflag = ('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('Keep1 Keep2 Remove1'), "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 = ('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");
#ok('' eq flags_regex('REM REM'), "Keep only regex");
@regexflag = ('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'), "Keep only regex 's/(.*)/\$1 jrdH8u/'");
@regexflag = ('s/jrdH8u *//');
ok('REM REM REM REM REM ' eq flags_regex('REM REM REM REM REM jrdH8u'), "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'), "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('' 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('' eq flags_regex(''), "Keep only regex: Exchange case, null string");
ok(''
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('' eq flags_regex(''), "Keep only regex: Exchange case, null string (Phil)");
ok(''
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)");
}
sub flags_regex {
my ($h1_flags) = @_;
foreach my $regexflag (@regexflag) {
my $h1_flags_orig = $h1_flags;
$debugflags and print "eval \$h1_flags =~ $regexflag\n";
eval("\$h1_flags =~ $regexflag");
die_clean("error: eval regexflag '$regexflag': $@\n") if $@;
$debugflags and print "regexflag $regexflag [$h1_flags_orig] -> [$h1_flags]\n";
}
return($h1_flags);
}
sub acls_sync {
my($h1_fold, $h2_fold) = @_;
if ($syncacls) {
my $h1_hash = $imap1->getacl($h1_fold)
or print "Could not getacl for $h1_fold: $@\n";
my $h2_hash = $imap2->getacl($h2_fold)
or print "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";
print "acl $user: [$acl]\n";
next if ($h1_hash->{$user} && $h2_hash->{$user} &&
$h1_hash->{$user} eq $h2_hash->{$user});
unless ($dry) {
print "setting acl $h2_fold $user $acl\n";
$imap2->setacl($h2_fold, $user, $acl)
or print "Could not set acl: $@\n";
}
}
}
}
sub tests_permanentflags {
my $string;
ok('' 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('' eq permanentflags('Blabla'), 'permanentflags nothing');
}
sub permanentflags {
my @lines = @_ ;
foreach my $line (@lines) {
if ( $line =~ m{\[PERMANENTFLAGS \(([^)]+?)\)\]} ) {
( $debugflags or $debug ) and print "permanentflags: $line" ;
my $permanentflags = $1 ;
if ( $permanentflags =~ m{\\\*} ) {
$permanentflags = '' ;
}
return($permanentflags) ;
};
}
}
sub tests_flags_filter {
ok( '\Seen' eq flags_filter('\Seen', '\Draft \Seen \Answered'), 'flags_filter ' );
ok( '' 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 ' );
}
sub flags_filter {
my($flags, $allowed_flags) = @_;
my @flags = split(/\s+/, $flags);
my %allowed_flags = map { $_ => 1 } split(' ', $allowed_flags );
my @flags_out = map { exists $allowed_flags{$_} ? $_ : () } @flags;
my $flags_out = join(' ', @flags_out);
#print "%%%$flags_out%%%\n";
return($flags_out);
}
sub flagsCase {
my $flags = shift ;
my @flags = split( /\s+/, $flags );
my %rfc_flags = map { $_ => 1 } split(' ', '\Answered \Flagged \Deleted \Seen \Draft' );
my @flags_out = map { exists $rfc_flags{ ucsecond( lc( $_ ) ) } ? ucsecond( lc( $_ ) ) : $_ } @flags ;
my $flags_out = join( ' ', @flags_out ) ;
#print "%%%$flags_out%%%\n" ;
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' ) ;
}
sub ucsecond {
my $string = shift ;
my $output ;
return( $string ) if ( 1 >= length( $string ) ) ;
$output = substr( $string, 0, 1) . uc( substr( $string, 1, 1 ) ) if ( 2 == length( $string ) ) ;
$output = substr( $string, 0, 1) . uc( substr( $string, 1, 1 ) ) . substr( $string, 2 );
#print "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' ) ;
}
sub select_msgs {
my ( $imap, $msgs_all_hash_ref ) = @_ ;
my ( @msgs, @msgs_all, @max, @min, @union, @inter ) ;
# Need to have the whole list in msgs_all_hash_ref
# without calling messages() several times.
if ( defined( $msgs_all_hash_ref )
or ( ! defined( $maxage ) and ! defined( $minage ) and ! defined( $search ) )
) {
@msgs = $imap->messages() ;
if ( defined( $msgs_all_hash_ref ) ) {
@msgs_all = @msgs ;
@{ $msgs_all_hash_ref }{ @msgs_all } = () ;
}
# return all messages
if ( ! defined( $maxage ) and ! defined( $minage ) and ! defined( $search ) ) {
return( @msgs ) ;
}
}
if ( defined( $search ) ) {
@msgs = $imap->search( $search ) ;
return( @msgs ) ;
}
if ( defined( $maxage ) ) {
@max = $imap->sentsince( $timestart - 86400 * $maxage ) ;
}
if ( defined($minage ) ) {
@min = $imap->sentbefore( $timestart - 86400 * $minage ) ;
}
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 = keys( %inter ) ;
@union = 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 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( ) ;
#print "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) {
print "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) {
print "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 ;
( $search ) = $imap->search( "UID $msg" ) ;
#print "$search ? $msg\n" ;
return( 1 ) if ( $search eq $msg ) ;
return( 0 ) ;
}
sub copy_message {
# copy
my ( $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) = @_ ;
$debug and print "msg $h1_fold/$h1_msg copying to $h2_fold\n";
my $h1_size = $h1_fir_ref->{$h1_msg}->{"RFC822.SIZE"} || '' ;
my $h1_flags = $h1_fir_ref->{$h1_msg}->{"FLAGS"} || '' ;
my $h1_idate = $h1_fir_ref->{$h1_msg}->{"INTERNALDATE"} || '' ;
return() if size_filtered( $h1_size, $h1_msg, $h1_fold, $h2_fold ) ;
my $string;
do { print "SLEEP 5\n" and sleep 5 ; } if ( $debugsleep ) ;
print "- msg $h1_fold/$h1_msg S[$h1_size] F[$h1_flags] I[$h1_idate] has RFC822.SIZE null!\n" if ( ! $h1_size ) ;
return( ) if not message_exists( $imap1, $h1_msg ) ;
$string = $imap1->message_string($h1_msg);
my $string_len = defined( $string ) ? length( $string ) : '' ; # length or undef
#print "- msg $h1_fold/$h1_msg {$string_len}\n" ;
unless ( defined( $string ) and $string_len ) { # undef or 0 length
print
"- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] could not be fetched: ",
$imap1->LastError, "\n" ;
$nb_errors++ ;
$total_bytes_error += $h1_size if ( $h1_size ) ;
#relogin1( ) if ( $relogin1 ) ;
return( ) ;
}
if (@regexmess) {
$string = regexmess($string);
}
$debugcontent and print
"=" x80, "\n",
"F message content begin next line\n",
$string,
"F message content ended on previous line\n", "=" x 80, "\n";
my $h1_date = "";
if ($syncinternaldates) {
$h1_date = $h1_idate;
$debug and print "internal date from host1: [$h1_date]\n";
$h1_date = good_date($h1_date);
$debug and print "internal date from host1: [$h1_date] (fixed)\n";
}
if ($idatefromheader) {
$h1_date = $imap1->get_header($h1_msg,"Date");
$debug and print "header date from host1: [$h1_date]\n";
$h1_date = good_date($h1_date);
$debug and print "header date from host1: [$h1_date] (fixed)\n";
}
if ( $addheader and defined $h1_fir_ref->{$h1_msg}->{"NO_HEADER"} ) {
my $header = add_header( $h1_msg ) ;
$debug and print "msg $h1_fold/$h1_msg adding custom header [$header]\n" ;
$string = $header . "\r\n" . $string ;
}
# RFC 2060: This flag can not be altered by any client
$h1_flags =~ s@\\Recent\s?@@gi;
$h1_flags = flags_regex($h1_flags) if @regexflag;
$h1_flags = flagsCase( $h1_flags ) if $flagsCase ;
$h1_flags = flags_filter($h1_flags, $permanentflags2) if ($permanentflags2);
my $new_id;
$debug and print "msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n";
$h1_date = undef if ($h1_date eq "");
unless ($dry) {
$max_msg_size_in_bytes = max($h1_size, $max_msg_size_in_bytes);
$new_id = $imap2->append_string($h2_fold, $string, $h1_flags, $h1_date);
unless($new_id){
no warnings 'uninitialized';
print "- msg $h1_fold/$h1_msg {$string_len} couldn't append (Subject:[".
$imap1->subject($h1_msg)."]) to folder $h2_fold: ",
$imap2->LastError, "\n";
$nb_errors++;
$total_bytes_error += $h1_size;
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+$} ) {
$new_id = lastuid( $imap2, $h2_fold, $h2_uidguess ) ;
}
printf( "msg %s/%-19s copied to %s/%-10s\n", $h1_fold, "$h1_msg {$string_len}", $h2_fold, $new_id );
$h2_uidguess += 1 ;
$total_bytes_transferred += $h1_size;
$nb_msg_transferred += 1;
$debugcache and print "touch $cache_dir/${h1_msg}_$new_id\n" if ( $usecache and $cacheaftercopy and $new_id =~ m{^\d+$} ) ;
touch( "$cache_dir/${h1_msg}_$new_id" ) if ( $usecache and $cacheaftercopy and $new_id =~ m{^\d+$} ) ;
if ( $delete ) {
print "msg $h1_fold/$h1_msg deleted on host1\n";
unless($dry) {
$imap1->delete_message($h1_msg);
$h1_nb_msg_deleted += 1;
$imap1->expunge() if ( $expunge or $expunge1 );
}
}
#print "PRESS ENTER" and my $a = <> ;
}
}
else{
$nb_msg_skipped_dry_mode += 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 print "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 } || -1 ) ;
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' );
#print $c12->{1601}, "\n";
}
sub get_cache {
$debugcache and print "Entering get_cache\n";
my ( $cache_dir, $h1_msgs_ref, $h2_msgs_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_;
-d $cache_dir or return( undef ); # exit if cache directory doesn't exist
$debugcache and print "cache_dir : $cache_dir\n";
#$cache_dir =~ s{\\}{\\\\}g;
$cache_dir =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\])/\\$1/g ;
$debugcache and print "cache_dir fix: $cache_dir\n";
my @cache_files = bsd_glob( "$cache_dir/*" ) ;
#$debugcache and print "cache_files: [@cache_files]\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 ) ;
#print "\n", map { "c12 $_ -> $cache_1_2_ref->{ $_ }\n" } keys %$cache_1_2_ref ;
#print "\n", map { "c21 $_ -> $cache_2_1_ref->{ $_ }\n" } keys %$cache_2_1_ref ;
$debugcache and print "Exiting get_cache\n";
return ( $cache_1_2_ref, $cache_2_1_ref ) ;
}
sub tests_get_cache {
ok( ! get_cache('/cache_no_exist'), 'get_cache: /cache_no_exist' );
ok( ( ! -d 'tmp/cache/F1/F2' or rmtree( 'tmp/cache/F1/F2' )), 'get_cache: rmtree tmp/cache/F1/F2' ) ;
ok( mkpath( 'tmp/cache/F1/F2' ), 'get_cache: mkpath tmp/cache/F1/F2' ) ;
my @test_files_cache = ( qw(
tmp/cache/F1/F2/100_200
tmp/cache/F1/F2/101_201
tmp/cache/F1/F2/120_220
tmp/cache/F1/F2/142_242
tmp/cache/F1/F2/143_243
tmp/cache/F1/F2/177_277
tmp/cache/F1/F2/177_377
tmp/cache/F1/F2/177_777
tmp/cache/F1/F2/155_255
) ) ;
ok( touch( @test_files_cache ), 'get_cache: touch 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 => '', 142 => '', 143 => '', 144 => '', 177 => '' } ;
my $msgs_all_2 = { 242 => '', 243 => '', 299 => '', 377 => '', 777 => '', 255 => '' } ;
my( $c12, $c21 ) ;
ok( ( $c12, $c21 ) = get_cache( '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 'tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242');
ok( -f 'tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243');
ok( ! -f 'tmp/cache/F1/F2/100_200', 'get_cache: file removed 100_200');
ok( ! -f '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 tmp/cache/F1/F2/...' ) ;
ok( ( $c12, $c21 ) = get_cache('tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' );
ok( -f 'tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242');
ok( -f 'tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243');
ok( ! -f 'tmp/cache/F1/F2/100_200', 'get_cache: file NOT removed 100_200');
ok( ! -f 'tmp/cache/F1/F2/101_201', 'get_cache: file NOT removed 101_201');
# strange files
#$debugcache = 1 ;
$maxage = undef ;
ok( ( ! -d 'tmp/cache/rr\uee' or rmtree( 'tmp/cache/rr\uee' )), 'get_cache: rmtree tmp/cache/rr\uee' ) ;
ok( mkpath( 'tmp/cache/rr\uee' ), 'get_cache: mkpath tmp/cache/rr\uee' ) ;
@test_files_cache = ( qw(
tmp/cache/rr\uee/100_200
tmp/cache/rr\uee/101_201
tmp/cache/rr\uee/120_220
tmp/cache/rr\uee/142_242
tmp/cache/rr\uee/143_243
tmp/cache/rr\uee/177_277
tmp/cache/rr\uee/177_377
tmp/cache/rr\uee/177_777
tmp/cache/rr\uee/155_255
) ) ;
ok( touch(@test_files_cache), 'get_cache: touch strange 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 => '', 142 => '', 143 => '', 144 => '', 177 => '' } ;
$msgs_all_2 = { 242 => '', 243 => '', 299 => '', 377 => '', 777 => '', 255 => '' } ;
ok( ( $c12, $c21 ) = get_cache('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 'tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 142_242');
ok( -f 'tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 143_243');
ok( ! -f 'tmp/cache/rr\uee/100_200', 'get_cache: strange path file removed 100_200');
ok( ! -f 'tmp/cache/rr\uee/101_201', 'get_cache: strange path file removed 101_201');
}
sub match_a_cache_file {
my $file = shift ;
my ( $uid1, $uid2 ) ;
return( ( undef, undef ) ) if ( ! $file ) ;
if ( $file =~ m{(?:^|/)(\d+)_(\d+)$} ) {
$uid1 = $1 ;
$uid2 = $2 ;
}
return( $uid1, $uid2 ) ;
}
sub tests_match_a_cache_file {
my ( $uid1, $uid2 ) ;
ok( ( $uid1, $uid2 ) = match_a_cache_file( ), 'match_a_cache_file: no arg' ) ;
ok( ! defined( $uid1 ), 'match_a_cache_file: no arg 1' ) ;
ok( ! defined( $uid2 ), 'match_a_cache_file: no arg 2' ) ;
ok( ( $uid1, $uid2 ) = match_a_cache_file( '' ), 'match_a_cache_file: empty arg' ) ;
ok( ! defined( $uid1 ), 'match_a_cache_file: empty arg 1' ) ;
ok( ! defined( $uid2 ), 'match_a_cache_file: empty arg 2' ) ;
ok( ( $uid1, $uid2 ) = match_a_cache_file( '000_000' ), 'match_a_cache_file: 000_000' ) ;
ok( '000' eq $uid1, 'match_a_cache_file: 000_000 1' ) ;
ok( '000' eq $uid2, 'match_a_cache_file: 000_000 2' ) ;
ok( ( $uid1, $uid2 ) = match_a_cache_file( '123_456' ), 'match_a_cache_file: 123_456' ) ;
ok( '123' eq $uid1, 'match_a_cache_file: 123_456 1' ) ;
ok( '456' eq $uid2, 'match_a_cache_file: 123_456 2' ) ;
ok( ( $uid1, $uid2 ) = match_a_cache_file( '/tmp/truc/123_456' ), 'match_a_cache_file: /tmp/truc/123_456' ) ;
ok( '123' eq $uid1, 'match_a_cache_file: /tmp/truc/123_456 1' ) ;
ok( '456' eq $uid2, 'match_a_cache_file: /tmp/truc/123_456 2' ) ;
ok( ( $uid1, $uid2 ) = match_a_cache_file( '/lala123_456' ), 'match_a_cache_file: NO /lala123_456' ) ;
ok( ! $uid1, 'match_a_cache_file: /lala123_456 1' ) ;
ok( ! $uid2, 'match_a_cache_file: /lala123_456 2' ) ;
ok( ( $uid1, $uid2 ) = match_a_cache_file( 'la123_456' ), 'match_a_cache_file: NO la123_456' ) ;
ok( ! $uid1, 'match_a_cache_file: la123_456 1' ) ;
ok( ! $uid2, 'match_a_cache_file: la123_456 2' ) ;
}
sub clean_cache {
my ( $cache_files_ref, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_ ;
$debugcache and print "Entering clean_cache\n";
$debugcache and print map { "$_ -> " . $cache_1_2_ref->{ $_ } . "\n" } keys %$cache_1_2_ref ;
foreach my $file ( @$cache_files_ref ) {
$debugcache and print "$file\n" ;
my ( $uid1, $uid2 ) = match_a_cache_file( $file ) ;
$debugcache and print "u1: $uid1 u2: $uid2 c12: ", $cache_1_2_ref->{ $uid1 } || '', "\n" ;
# or ( ! exists( $cache_1_2_ref->{ $uid1 } ) )
# or ( ! ( $uid2 == $cache_1_2_ref->{ $uid1 } ) )
if ( ( ! defined( $uid1 ) )
or ( ! defined( $uid2 ) )
or ( ! exists( $h1_msgs_all_hash_ref->{ $uid1 } ) )
or ( ! exists( $h2_msgs_all_hash_ref->{ $uid2 } ) )
) {
$debugcache and print "remove $file\n" ;
unlink( $file ) or print "$!" ;
}
}
$debugcache and print "Exiting clean_cache\n";
return( 1 ) ;
}
sub tests_clean_cache {
ok( ( ! -d 'tmp/cache/G1/G2' or rmtree( 'tmp/cache/G1/G2' )), 'clean_cache: rmtree tmp/cache/G1/G2' ) ;
ok( mkpath( 'tmp/cache/G1/G2' ), 'clean_cache: mkpath tmp/cache/G1/G2' ) ;
my @test_files_cache = ( qw(
tmp/cache/G1/G2/100_200
tmp/cache/G1/G2/101_201
tmp/cache/G1/G2/120_220
tmp/cache/G1/G2/142_242
tmp/cache/G1/G2/143_243
tmp/cache/G1/G2/177_277
tmp/cache/G1/G2/177_377
tmp/cache/G1/G2/177_777
tmp/cache/G1/G2/155_255
) ) ;
ok( touch(@test_files_cache), 'clean_cache: touch tmp/cache/G1/G2/...' ) ;
ok( -f 'tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 before' );
ok( -f 'tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 before' );
ok( -f 'tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 before' );
ok( -f 'tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 before' );
ok( -f 'tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 before' );
ok( -f 'tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 before' );
my $cache = {
142 => 242,
177 => 777,
} ;
my $all_1 = {
142 => '',
177 => '',
} ;
my $all_2 = {
200 => '',
242 => '',
777 => '',
} ;
ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache: ' ) ;
ok( ! -f 'tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 after' );
ok( -f 'tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 after' );
ok( ! -f 'tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 after' );
ok( ! -f 'tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 after' );
ok( -f 'tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 after' );
ok( ! -f 'tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 after' );
}
sub tests_clean_cache_2 {
ok( ( ! -d 'tmp/cache/G1/G2' or rmtree( 'tmp/cache/G1/G2' )), 'clean_cache_2: rmtree tmp/cache/G1/G2' ) ;
ok( mkpath( 'tmp/cache/G1/G2' ), 'clean_cache_2: mkpath tmp/cache/G1/G2' ) ;
my @test_files_cache = ( qw(
tmp/cache/G1/G2/100_200
tmp/cache/G1/G2/101_201
tmp/cache/G1/G2/120_220
tmp/cache/G1/G2/142_242
tmp/cache/G1/G2/143_243
tmp/cache/G1/G2/177_277
tmp/cache/G1/G2/177_377
tmp/cache/G1/G2/177_777
tmp/cache/G1/G2/155_255
) ) ;
ok( touch(@test_files_cache), 'clean_cache_2: touch tmp/cache/G1/G2/...' ) ;
ok( -f 'tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 before' );
ok( -f 'tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 before' );
ok( -f 'tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 before' );
ok( -f 'tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 before' );
ok( -f 'tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 before' );
ok( -f 'tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 before' );
my $cache = {
142 => 242,
177 => 777,
} ;
my $all_1 = {
100 => '',
142 => '',
177 => '',
} ;
my $all_2 = {
200 => '',
242 => '',
777 => '',
} ;
ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache_2: ' ) ;
ok( -f 'tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 after' );
ok( -f 'tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 after' );
ok( ! -f 'tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 after' );
ok( ! -f 'tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 after' );
ok( -f 'tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 after' );
ok( ! -f 'tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 after' );
}
sub tests_touch {
ok( (-d 'tmp/tests/' or mkpath( 'tmp/tests/' )), 'tests_touch: mkpath tmp/tests/' ) ;
ok( 1 == touch( 'tmp/tests/lala'), 'tests_touch: tmp/tests/lala') ;
ok( 1 == touch( 'tmp/tests/\y'), 'tests_touch: tmp/tests/\y') ;
ok( 0 == touch( '/aaa'), 'tests_touch: not /aaa') ;
ok( 2 == touch( 'tmp/tests/lili', 'tmp/tests/lolo'), 'tests_touch: 2 files') ;
ok( 1 == touch( 'tmp/tests/\y', '/aaa'), 'tests_touch: 2 files, 1 fails' ) ;
}
sub tests_mkpath {
my $long_path = "123456789/" x 30 ;
ok( (-d "tmp/tests/long/$long_path" or mkpath( "tmp/tests/long/$long_path" )), 'tests_mkpath: mkpath > 300 char' ) ;
ok( (-d "tmp/tests/long/$long_path" and rmtree( "tmp/tests/long/" )), 'tests_mkpath: rmtree > 300 char' ) ;
ok( 1 == 1, 'tests_mkpath: 1 == 1' ) ;
}
sub touch {
my @files = @_ ;
my @result;
foreach my $file ( @files ) {
my $fh = new IO::File ;
if ($fh->open(">> $file")) {
$fh->close ;
push(@result, $file) ;
}
}
return(@result);
}
sub cache_folder {
my( $cache_dir, $h1_fold, $h2_fold ) = @_ ;
#print "sep1 $h1_sep sep2 $h2_sep\n";
my $sep1 = $h1_sep || '/';
my $sep2 = $h2_sep || '/';
my $h1_fold_slash = convert_sep_to_slash( $h1_fold, $sep1 );
my $h2_fold_slash = convert_sep_to_slash( $h2_fold, $sep2 );
return( "$cache_dir/$h1_fold_slash/$h2_fold_slash" ) ;
}
sub convert_sep_to_slash {
my ($folder, $sep) = @_;
$folder =~ s{\Q$sep\E}{/}g;
return($folder);
}
sub tests_convert_sep_to_slash {
ok('' eq convert_sep_to_slash('', '/'), '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');
}
sub tests_regexmess {
ok("blabla" eq regexmess("blabla"), "regexmess, no regexmess, nothing to do");
@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( ''
eq regexmess(''),
'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( ''
eq regexmess(''),
'From mbox 1 remove, blank');
ok( ''
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');
#print "[", regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), "]";
ok( "" . 'From <tartanpion@machin.truc>'
eq regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'),
'From mbox 4 remove');
ok(
'Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<tartanpion@machin.truc>
Hello,
Bye.'
eq regexmess(
'From zzz
Date: Sat, 10 Jul 2010 05:34:45 -0700
From:<tartanpion@machin.truc>
Hello,
Bye.'
),
'From mbox 5 remove');
}
sub regexmess {
my ($string) = @_;
foreach my $regexmess (@regexmess) {
$debug and print "eval \$string =~ $regexmess\n";
eval("\$string =~ $regexmess");
die_clean("error: eval regexmess '$regexmess': $@\n") if $@;
}
return($string);
}
sub stats {
$timeend = time();
$timediff = $timeend - $timestart;
my $timestart_str = localtime( $timestart ) ;
my $timeend_str = localtime( $timeend ) ;
my $memory_consumption = memory_consumption( ) || 0 ;
my $memory_ratio = ($max_msg_size_in_bytes) ?
sprintf('%.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;
print "++++ Statistics\n";
print "Transfer started on : $timestart_str\n";
print "Transfer ended on : $timeend_str\n";
print "Transfer time : $timediff sec\n";
print "Messages transferred : $nb_msg_transferred ";
print "(could be $nb_msg_skipped_dry_mode without dry mode)" if ($dry);
print "\n";
print "Messages skipped : $nb_msg_skipped\n";
print "Messages found duplicate on host1 : $h1_nb_msg_duplicate\n";
print "Messages found duplicate on host2 : $h2_nb_msg_duplicate\n";
print "Messages void (noheader) on host1 : $h1_nb_msg_noheader\n";
print "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n";
print "Messages deleted on host1 : $h1_nb_msg_deleted\n";
print "Messages deleted on host2 : $h2_nb_msg_deleted\n";
print "Total bytes transferred : $total_bytes_transferred\n";
print "Total bytes duplicate host1 : $h1_total_bytes_duplicate\n";
print "Total bytes duplicate host2 : $h2_total_bytes_duplicate\n";
print "Total bytes skipped : $total_bytes_skipped\n";
print "Total bytes error : $total_bytes_error\n";
$timediff ||= 1; # No division per 0
printf ("Message rate : %.1f messages/s\n", $nb_msg_transferred / $timediff);
printf ("Average bandwidth rate : %.1f KiB/s\n", $total_bytes_transferred / 1024 / $timediff);
print "Reconnections to host1 : $host1_reconnect_count\n";
print "Reconnections to host2 : $host2_reconnect_count\n";
printf ("Memory consumption : %.1f MB\n", $memory_consumption / 1024 / 1024);
print "Biggest message : $max_msg_size_in_bytes bytes\n";
# print "Memory/biggest message ratio : $memory_ratio\n";
print "Detected $nb_errors errors\n\n";
print $warn_release, "\n";
print thank_author();
}
sub thank_author {
return("Homepage: http://imapsync.lamiral.info/\n");
# used to be
return(join("", "Happy with this free, open and gratis DWTFPL software?\n",
"Encourage the author (Gilles LAMIRAL) by giving him a book\n",
"or just money via paypal:\n",
"http://imapsync.lamiral.info/\n"));
}
sub get_options {
my $numopt = scalar(@ARGV);
my $argv = join("¤", @ARGV);
$test_builder = Test::More->builder;
$test_builder->no_ending(1);
if($argv =~ m/-delete¤2/) {
print "May be you mean --delete2 instead of --delete 2\n";
exit 1;
}
my $opt_ret = GetOptions(
"debug!" => \$debug,
"debugLIST!" => \$debugLIST,
"debugcontent!" => \$debugcontent,
"debugsleep!" => \$debugsleep,
"debugflags!" => \$debugflags,
"debugimap!" => \$debugimap,
"debugimap1!" => \$debugimap1,
"debugimap2!" => \$debugimap2,
"host1=s" => \$host1,
"host2=s" => \$host2,
"port1=i" => \$port1,
"port2=i" => \$port2,
"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,
"prefix1=s" => \$prefix1,
"prefix2=s" => \$prefix2,
"regextrans2=s" => \@regextrans2,
"regexmess=s" => \@regexmess,
"regexflag=s" => \@regexflag,
"filterflags!" => \$filterflags,
"flagsCase!" => \$flagsCase,
"delete!" => \$delete,
"delete2!" => \$delete2,
"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,
"foldersizes!" => \$foldersizes,
"dry!" => \$dry,
"expunge!" => \$expunge,
"expunge1!" => \$expunge1,
"expunge2!" => \$expunge2,
"uidexpunge2!" => \$uidexpunge2,
"subscribed!" => \$subscribed,
"subscribe!" => \$subscribe,
"subscribe_all!" => \$subscribe_all,
"justbanner!" => \$justbanner,
"justconnect!"=> \$justconnect,
"justfolders!"=> \$justfolders,
"justfoldersizes!" => \$justfoldersizes,
"fast!" => \$fast,
"version" => \$version,
"help" => \$help,
"timeout=i" => \$timeout,
"skipheader=s" => \$skipheader,
"useheader=s" => \@useheader,
"wholeheaderifneeded!" => \$wholeheaderifneeded,
"skipsize!" => \$skipsize,
"allowsizemismatch!" => \$allowsizemismatch,
"fastio1!" => \$fastio1,
"fastio2!" => \$fastio2,
"ssl1!" => \$ssl1,
"ssl2!" => \$ssl2,
"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,
"relogin1=i" => \$relogin1,
"relogin2=i" => \$relogin2,
"tests" => \$tests,
"tests_debug" => \$tests_debug,
"allow3xx!" => \$allow3xx,
"justlogin!" => \$justlogin,
"tmpdir=s" => \$tmpdir,
"pidfile=s" => \$pidfile,
"releasecheck!" => \$releasecheck,
"modules_version!" => \$modules_version,
"usecache!" => \$usecache,
"cacheaftercopy!" => \$cacheaftercopy,
"debugcache!" => \$debugcache,
"useuid!" => \$useuid,
"addheader!" => \$addheader,
"exitwhenover=i" => \$exitwhenover,
);
$debug and print "get options: [$opt_ret]\n";
# just the version
print imapsync_version(), "\n" and exit if ($version) ;
if ($tests) {
$test_builder->no_ending(0);
tests();
exit;
}
if ($tests_debug) {
$test_builder->no_ending(0);
tests_debug();
exit;
}
$help = 1 if ! $numopt;
load_modules();
# exit with --help option or no option at all
usage() and exit if ($help or ! $numopt) ;
# don't go on if options are not all known.
exit(EX_USAGE()) unless ($opt_ret) ;
}
sub load_modules {
require IO::Socket::SSL if ($ssl1 or $ssl2 or $tls1 or $tls2);
require Term::ReadKey if (
((not($password1 or $passfile1))
or (not($password2 or $passfile2)))
and (not $help));
#require Data::Dumper if ($debug);
}
sub parse_header_msg {
my ($imap, $m_uid, $s_heads, $s_fir, $s, $s_hash) = @_;
my $head = $s_heads->{$m_uid};
my $headnum = scalar(keys(%$head));
$debug and print "$s uid $m_uid head nb pass one: ", $headnum, "\n";
my $headstr;
if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){
print "$s 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;
#print $whole_header;
$head = decompose_header( $whole_header ) ;
$headnum = scalar( keys( %$head ) ) ;
$debug and print "$s uid $m_uid head nb pass two: ", $headnum, "\n";
}
#require Data::Dumper ;
#print Data::Dumper->Dump( [ $head, \%useheader ] ) ;
foreach my $h (sort keys(%$head)){
next if ( ! exists( $useheader{ uc( $h ) } )
and ! exists( $useheader{ 'ALL' } )
) ;
foreach my $val (sort @{$head->{$h}}) {
# no 8-bit data in headers !
$val =~ s/[\x80-\xff]/X/g;
# remove the first blanks (dbmail bug ?)
$val =~ s/^\s*(.+)$/$1/;
# and uppercase header line
# (dbmail and dovecot)
my $H = uc("$h: $val");
# show stuff in debug mode
$debug and print "$s uid $m_uid header [$H]", "\n";
if ($skipheader and $H =~ m/$skipheader/i) {
$debug and print "$s uid $m_uid skipping header [$H]\n";
next;
}
$headstr .= "$H";
}
}
if ( ( ! $headstr) and ( $addheader ) and ( $s eq "Host1" )){
my $header = add_header( $m_uid ) ;
print "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 print "$s uid $m_uid sig $m_md5 size $size\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;
}
sub firstline {
# extract the first line of a file (without \n)
my($file) = @_;
my $line = "";
open FILE, $file or die_clean("error [$file]: $! ");
chomp($line = <FILE>);
close FILE;
$line = ($line) ? $line: "error !EMPTY! [$file]";
return $line;
}
sub file_to_string {
my($file) = @_;
my @string;
open FILE, $file or die_clean("error [$file]: $! ");
@string = <FILE>;
close FILE;
return join("", @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;
}
sub tests_is_a_release_number {
ok(is_a_release_number(1.351), 'is_a_release_number 1.351');
ok(is_a_release_number(42.4242), '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');
}
sub is_a_release_number {
my $number = shift;
$number =~ m{\d\.\d+};
}
sub check_last_release {
my $public_release = not_long('imapsync_version_lfo');
#print "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 current imapsync is up to date");
}
}
sub imapsync_version {
my $rcs = '$Id: imapsync,v 1.488 2012/04/15 17:38:21 gilles Exp gilles $ ';
$rcs =~ m/,v (\d+\.\d+)/;
my $VERSION = ($1) ? $1: "UNKNOWN";
return($VERSION);
}
sub tests_imapsync_basename {
ok('imapsync' eq imapsync_basename(), 'imapsync_basename: imapsync');
ok('blabla' ne imapsync_basename(), '! imapsync_basename: blabla');
}
sub imapsync_basename {
return basename($0);
}
sub imapsync_version_lfo {
my $local_version = imapsync_version();
my $imapsync_basename = imapsync_basename();
my $agent_info = "$OSNAME system, perl "
. sprintf("%vd", $PERL_VERSION)
. ", Mail::IMAPClient $Mail::IMAPClient::VERSION"
. " $imapsync_basename";
my $sock = new IO::Socket::INET (
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[-1];
chomp($last_release);
return($last_release);
}
sub not_long {
#print "Entering not_long\n";
my ($func) = @_;
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 { die "alarm" }))
or print "Error setting SIGALRM handler: $!\n";
}
eval {
alarm(3);
#print $func, "\n";
{
no strict "refs";
#print "Calling $func\n";
$val = &$func();
#print "End of $func\n";
}
alarm(0);
};
if ($@) {
#print "$@";
if ($@ =~ /alarm/) {
# timed out
return('timeout');
}else{
alarm(0);
return('unknown'); # propagate unexpected errors
}
}else {
# didn't
return($val);
}
}
sub localhost_info {
my($infos) = join("",
"Here is a [$OSNAME] system (",
join(" ",
uname(),
),
")\n",
"With perl ",
sprintf("%vd", $PERL_VERSION),
" Mail::IMAPClient $Mail::IMAPClient::VERSION",
);
return($infos);
}
sub usage {
my $localhost_info = localhost_info();
my $thank = thank_author();
my $warn_release ='';
$warn_release = check_last_release() if (not defined($releasecheck));
my $escape_char = ( 'MSWin32' eq $OSNAME ) ? '^' : '\\';
print <<EOF;
usage: $0 [options]
Several options are mandatory.
--host1 <string> : "from" imap server. Mandatory.
--port1 <int> : port to connect on host1. Default is 143.
--user1 <string> : user to login on host1. Mandatory.
--domain1 <string> : domain on host1 (NTLM authentication).
--authuser1 <string> : user to auth with on host1 (admin user).
Avoid using --authmech1 SOMETHING with --authuser1.
--proxyauth1 : Use proxyauth on host1. Requires --authuser1.
Required by Sun/iPlanet/Netscape IMAP servers to
be able to use an administrative user
--password1 <string> : password for the user1. Dangerous, use --passfile1
--passfile1 <string> : password file for the user1. Contains the password.
--host2 <string> : "destination" imap server. Mandatory.
--port2 <int> : port to connect on host2. Default is 143.
--user2 <string> : user to login on host2. Mandatory.
--domain2 <string> : domain on host2 (NTLM authentication).
--authuser2 <string> : user to auth with on host2 (admin user).
--proxyauth2 : Use proxyauth on host2. Requires --authuser2.
Required by Sun/iPlanet/Netscape IMAP servers to
be able to use an administrative user
--password2 <string> : password for the user2. Dangerous, use --passfile2
--passfile2 <string> : password file for the user2. Contains the password.
--authmd51 : Use MD5 authentification for host1.
--authmd52 : Use MD5 authentification for host2.
--authmech1 <string> : auth mechanism to use with host1:
PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE.
--authmech2 <string> : auth mechanism to use with host2. See --authmech1
--ssl1 : use an SSL connection on host1.
--ssl2 : use an SSL connection on host2.
--tls1 : use an TLS connection on host1.
--tls2 : use an TLS connection on host2.
--folder <string> : sync this folder.
--folder <string> : and this one, etc.
--folderrec <string> : sync this folder recursively.
--folderrec <string> : and this one, etc.
--include <regex> : sync folders matching this regular expression
--include <regex> : or this one, etc.
in case both --include --exclude options are
use, include is done before.
--exclude <regex> : skips folders matching this regular expression
Several folders to avoid:
--exclude 'fold1|fold2|f3' skips fold1, fold2 and f3.
--exclude <regex> : or this one, etc.
--tmpdir <string> : where to store temporary files and subdirectories.
Will be created if it doesn't exist.
Default is system specific and should be ok.
--pidfile <string> : the file where imapsync pid is written.
--prefix1 <string> : remove prefix to all destination folders
(usually INBOX. for cyrus imap servers)
you can use --prefix1 if your source imap server
does not have NAMESPACE capability.
--prefix2 <string> : add prefix to all destination folders
(usually INBOX. for cyrus imap servers)
use --prefix2 if your target imap server does not
have NAMESPACE capability.
--regextrans2 <regex> : Apply the whole regex to each destination folders.
--regextrans2 <regex> : 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
--regexmess <regex> : Apply the whole regex to each message before transfer.
Example: 's/\\000/ /g' # to replace null by space.
--regexmess <regex> : and this one.
--regexmess <regex> : and this one, etc.
--regexflag <regex> : Apply the whole regex to each flags list.
Example: 's/\"Junk"//g' # to remove "Junk" flag.
--regexflag <regex> : and this one, etc.
--sep1 <string> : host1 separator in case namespace is not supported.
--sep2 <string> : idem for host2.
--delete : Deletes messages on host1 server after
a successful transfer. Useful in case you
want to migrate from one server to another one.
With imapsync, --delete tags messages as deleted and
they are really deleted unless --noexpunge is used.
--delete2 : delete messages in host2 that are not in
host1 server. Useful for backup or pre-sync.
--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 <regex>: delete only folders matching regex.
--delete2foldersbutnot <regex>: do not delete folders matching regex.
--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
--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 <string> : Select messages returned by this IMAP SEARCH command.
--exitwhenover <int> : Stop syncing when total bytes transferred reached.
Gmail per day allows 2500000000 down 500000000 upload.
--useheader <string> : Use this header to compare messages on both sides.
Ex: Message-ID or Subject or Date.
--useheader <string> and this one, etc.
--dry : do nothing, just print what would be done.
--subscribed : transfers subscribed folders.
--subscribe : subscribe to the folders transferred on the
host2 that are subscribed on host1. On by default.
--subscribe_all : 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.
--justfoldersizes : exit after printed the folder sizes.
--syncacls : synchronises acls (Access Control Lists).
--nosyncacls : does not synchronise acls. This is the default.
--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 sync.
--usecache is then implied unless --nousecache is
used.
--debug : debug mode.
--debugcontent : debug content of the messages transfered.
--debugflags : debug flags.
--debugimap1 : imap debug mode for host1. imap debug is very verbose.
--debugimap2 : imap debug mode for host2.
--debugimap : imap debug mode for host1 and host2.
--version : print software version.
--noreleasecheck : do not check for new imapsync release (a http request).
--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 : just do things about folders (ignore messages).
--fast : be faster, equivalent to --nofoldersizes
--help : print this help.
Example: to synchronise imap account "foo" on "imap.truc.org"
to imap account "bar" on "imap.trac.org"
with foo password "secret1"
and bar password "secret2"
$0 $escape_char
--host1 imap.truc.org --user1 foo --password1 secret1 $escape_char
--host2 imap.trac.org --user2 bar --password2 secret2
$localhost_info
$rcs
$warn_release
$thank
EOF
}
sub usage_complete {
print <<EOF ;
--skipheader <regex> : Don't take into account header keyword
matching <string> 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.
--timeout <int> : imap connect timeout.
EOF
}
sub memory_consumption {
# memory consumed by imapsync until now in bytes
return( ( memory_consumption_of_pids( ) )[0] );
}
sub memory_consumption_of_pids {
my @PID = (@_) ? @_ : ($PROCESS_ID);
#print "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 };
shift @ps; # First line is column name "VSZ"
chomp @ps;
# convert to
@val = map { $_ * 1024 } @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 };
#print "-" x 80, "\n", @ps, "-" x 80, "\n";
my @val;
foreach my $line (@ps) {
my($name, $pid, $mem) = (split(',', $line))[0,1,4];
next if (! $pid);
#print "[$name][$pid][$mem]";
if ($PID{remove_qq($pid)}) {
#print "MATCH !\n";
chomp($mem);
$mem = remove_qq($mem);
$mem = remove_Ko($mem);
$mem = remove_not_num($mem);
#print "[$mem]\n";
push(@val, $mem * 1024);
}
}
return(@val);
}
sub remove_not_num {
my $string = shift;
$string =~ tr/0-9//cd;
#print "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'), "remove_not_num( '123' )");
ok('123' eq remove_not_num('12 3'), "remove_not_num( '12 3' )");
ok('123' eq remove_not_num('a 12 3 Ko'), "remove_not_num( 'a 12 3 Ko' )");
}
sub remove_Ko {
my $string = shift;
if ($string =~ /^(.*) Ko$/) {
return($1);
}else{
return($string);
}
}
sub remove_qq {
my $string = shift;
if ($string =~ /^"(.*)"$/) {
return($1);
}else{
return($string);
}
}
sub memory_consumption_ratio {
my ($base) = @_;
$base ||= 1;
my $consu = memory_consumption();
return($consu / $base);
}
sub tests_memory_consumption {
ok(print join("\n", memory_consumption_of_pids()), "\n");
ok(print join("\n", memory_consumption_of_pids('1')), "\n");
ok(print join("\n", memory_consumption_of_pids('1', $$)), "\n");
ok(print memory_consumption_ratio(), "\n");
ok(print memory_consumption_ratio(1), "\n");
ok(print memory_consumption_ratio(10), "\n");
ok(print memory_consumption(), "\n");
}
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 ('') if not defined($d);
if ( $d =~ m{(\d?)(\d-...-\d{4})( \d{2}:\d{2}:\d{2})( (?:\+|-)\d{4})?}o ) {
#print "internal: [$1][$2][$3][$4]\n";
my ($day_1, $date_rest, $hour, $zone) = ($1,$2,$3,$4);
$day_1 = '0' if ($day_1 eq '');
$zone = ' +0000' if not defined($zone);
$d = $day_1 . $date_rest . $hour . $zone;
}elsif ($d =~ m{(?:\w{3,}, )?(\d{1,2}),?\s+(\w{3,})\s+(\d{2,4})\s+(\d{1,2})(?::|\.)(\d{1,2})(?:(?::|\.)(\d{1,2}))?\s*((?:\+|-)\d{4})?}o ) {
# 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
#print "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 =~ /^[789]/;
$year = '20' . $year if length($year) == 2;
$month = substr $month, 0, 3 if length($month) > 4;
$day = sprintf("%02d", $day);
$hour = sprintf("%02d", $hour);
$min = sprintf("%02d", $min);
$sec = '00' if not defined($sec);
$sec = sprintf("%02d", $sec);
$zone = '+0000' if not defined($zone);
$d = "$day-$month-$year $hour:$min:$sec $zone";
}elsif ($d =~ m{(?:.{3}) (...)\s+(\d{1,2}) (\d{1,2}):(\d{1,2}):(\d{1,2}) (?:\w{3})?\s?(\d{4})}o ) {
# 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
#print "header: [$1][$2][$3][$4][$5][$6]\n";
my ($month, $day, $hour, $min, $sec, $year) = ($1,$2,$3,$4,$5,$6);
$day = sprintf("%02d", $day);
$hour = sprintf("%02d", $hour);
$min = sprintf("%02d", $min);
$sec = sprintf("%02d", $sec);
$d = "$day-$month-$year $hour:$min:$sec +0000";
}elsif ($d =~ m{(\d{2})/(\d{2})/(\d{2}) (\d{2}):(\d{2}):(\d{2})}o ) {
# Handles the following format
# 02/06/09 22:18:08 -- Generated by AVTECH TemPageR devices
#print "header: [$1][$2][$3][$4][$5][$6]\n";
my ($month, $day, $year, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6);
$year = '20' . $year;
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);
$month = $num2mon{$month};
$d = "$day-$month-$year $hour:$min:$sec +0000";
}elsif ($d =~ m{\w{6,}, (\w{3})\w+\s+(\d{1,2}), (\d{4}) (\d{2}):(\d{2}) (AM|PM)}o ) {
# 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 = sprintf("%02d", $day);
$d = "$day-$month-$year $hour:$min:00 +0000";
}elsif ($d =~ m{(\w{3}) (\d{1,2}) (\d{4}) (\d{2}):(\d{2}):(\d{2}) ((?:\+|-)\d{4})}o ) {
# 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 = sprintf("%02d", $day);
$d = "$day-$month-$year $hour:$min:$sec $zone";
}elsif ($d =~ m{(\d{1,2})-(\w{3})-(\d{4})}o ) {
# Handles the following format
# 21-Jun-2001 - register.com domain transfer email circa 2001
my ($day, $month, $year) = ($1,$2,$3);
$day = sprintf("%02d", $day);
$d = "$day-$month-$year 11:11:11 +0000";
}else{
# unknown/unmatch => return same string
return($d);
}
$d = qq("$d");
return($d);
}
sub tests_good_date {
ok('' 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');
}
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}');
}
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_1, %h2_folders_not_in_1);
@h2_folders_not_in_1 = list_keys_in_2_not_in_1( \%h1_folders_all, \%h2_folders_all);
map { $h2_folders_not_in_1{$_} = 1} @h2_folders_not_in_1;
@h2_folders_not_in_1 = list_keys_in_2_not_in_1( \%h2_folders_from_1_all, \%h2_folders_not_in_1);
return( reverse @h2_folders_not_in_1 );
}
sub delete_folders_in_2_not_in_1 {
my $dry_message = '';
$dry_message = "\t(not really since --dry mode)" if $dry;
foreach my $folder (@h2_folders_not_in_1) {
if ( defined( $delete2foldersonly ) and eval( "\$folder !~ $delete2foldersonly" ) ) {
print "Not deleting $folder because of --delete2foldersonly $delete2foldersonly\n";
next;
}
if ( defined( $delete2foldersbutnot ) and eval( "\$folder =~ $delete2foldersbutnot" ) ) {
print "Not deleting $folder because of --delete2foldersbutnot $delete2foldersbutnot\n";
next;
}
my $res = $dry; # always success in dry mode!
$res = $imap2->delete($folder) if ( ! $dry ) ;
if ($res) {
print "Delete $folder", "$dry_message", "\n";
}else{
print "Delete $folder failure", "\n";
}
}
}
sub extract_header {
my $string = shift ;
my ( $header ) = split( /\n\n/, $string ) ;
#print "[$header]\n" ;
return( $header ) ;
}
sub tests_extract_header {
ok(
'Message-Id: <20100428101817.A66CB162474E@plume.est.belle>
Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST)
From: gilles@louloutte.dyndns.org (Gilles LAMIRAL)'
eq extract_header(
'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
' ), 'extract_header: 1') ;
}
sub decompose_header{
my $string = shift ;
my $header = { } ;
my ($key, $val ) ;
my @line = split( /\n|\r\n/, $string ) ;
foreach my $line ( @line ) {
#print "DDD $line\n" ;
if( $line =~ m/(^[^ :]+): (.*)/ ) {
$key = $1 ;
$val = $2 ;
#print "DDD [$key] [$val]\n" ;
push( @{ $header->{ $key } }, $val ) ;
}elsif( $line =~ m/^(\s+)(.*)/ ) {
$val = $2 ;
#print "DDD only [$val]\n" ;
@{ $header->{ $key } }[ -1 ] .= " $val" if $key ;
}else{
next ;
}
}
#require Data::Dumper ;
#print Data::Dumper->Dump( [ $header ] ) ;
return( $header ) ;
}
sub tests_decompose_header{
my $header_dec ;
$header_dec = decompose_header(
'KEY_1: VAL_1
KEY_2: VAL_2
VAL_2_+
VAL_2_++
KEY_3: VAL_3
KEY_1: VAL_1_other
'
) ;
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_++' ) ;
$header_dec = decompose_header(
'Message-Id: <20100428101817.A66CB162474E@plume.est.belle>
Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST)
From: gilles@louloutte.dyndns.org (Gilles LAMIRAL)'
) ;
ok( '<20100428101817.A66CB162474E@plume.est.belle>'
eq $header_dec->{ 'Message-Id' }[0], 'decompose_header: 1' ) ;
$header_dec = decompose_header(
'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'
) ;
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(
'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)'
) ;
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(
' KEY_1: VAL_1
KEY_2: VAL_2
VAL_2_+
VAL_2_++
KEY_3: VAL_3
KEY_1: VAL_1_other
'
) ;
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_++' ) ;
}
sub epoch {
# incoming format:
# internal date 24-Aug-2010 16:00:00 +0200
# outgoing format: epoch
my $d = shift ;
return ('') if not defined($d);
my ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) ;
my $time ;
if ( $d =~ m{(\d{2})-([A-Z][a-z]{2})-(\d{4}) (\d{2}):(\d{2}):(\d{2}) ((?:\+|-))(\d{2})(\d{2})}o ) {
#print "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 ) ;
#print "( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m )\n" ;
$sign = +1 if ( '+' eq $sign ) ;
$sign = -1 if ( '-' eq $sign ) ;
$time = timegm( $sec, $min, $hour, $mday, $month_abrev{$month}, $year )
- $sign * ( 3600 * $zone_h + 60 * $zone_m ) ;
#print( "$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' ) ;
}
sub add_header {
my $uid = shift || 'mistake' ;
my $header = 'Message-Id: <' . $uid . '@imapsync>' ;
return( $header ) ;
}
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' ) ;
}
sub tests_debug {
SKIP: {
skip "No test in normal run" if ( not $tests_debug );
tests_add_header( ) ;
}
}
sub tests {
SKIP: {
skip "No test in normal run" if (not $tests);
tests_folder_routines();
tests_compare_lists();
tests_regexmess();
tests_flags_regex();
tests_permanentflags();
tests_flags_filter( ) ;
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_ucsecond( ) ;
tests_flagsCase( ) ;
tests_mkpath( ) ;
tests_extract_header( ) ;
tests_decompose_header( ) ;
tests_epoch( ) ;
}
}
# IMAPClient 2.2.9 overrides
sub override_imapclient {
no warnings 'redefine';
no strict 'subs';
use constant Unconnected => 0;
use constant Connected => 1; # connected; not logged in
use constant Authenticated => 2; # logged in; no mailbox selected
use constant Selected => 3; # mailbox selected
use constant INDEX => 0; # Array index for output line number
use constant TYPE => 1; # Array index for line type
# (either OUTPUT, INPUT, or LITERAL)
use constant DATA => 2; # Array index for output line data
use constant NonFolderArg => 1; # Value to pass to Massage to
# indicate non-folder argument
*Mail::IMAPClient::_transaction_literals = sub {
my $self = shift;
my $string = "";
foreach my $result (@{$self->{"History"}{$self->Transaction}}) {
$string .= $result->[DATA]
if defined($result) and $self->_is_literal($result) ;
}
return $string;
};
# Got from 3.25
*Mail::IMAPClient::append_string = sub {
my $self = shift;
my $folder = $self->Massage(shift);
my ( $text, $flags, $date ) = @_;
defined $text or $text = '';
if ( defined $flags ) {
$flags =~ s/^\s+//g;
$flags =~ s/\s+$//g;
$flags = "($flags)" if $flags !~ /^\(.*\)$/;
}
if ( defined $date ) {
$date =~ s/^\s+//g;
$date =~ s/\s+$//g;
$date = qq("$date") if $date !~ /^"/;
}
$text =~ s/\r?\n/$CRLF/og;
my $command =
"APPEND $folder "
. ( $flags ? "$flags " : "" )
. ( $date ? "$date " : "" ) . "{"
. length($text)
. "}$CRLF";
$command .= $text . $CRLF;
$self->_imap_command( $command ) or return undef;
my $data = join '', $self->Results;
#print "ZZZ|$data|ZZZ\n";
# look for something like return size or self if no size found:
# <tag> OK [APPENDUID <uid> <size>] APPEND completed
# 18 OK [APPENDUID 1286144680 1539] APPEND Ok.
my $ret = $data =~ m#^\d+ OK \[APPEND.*\s+(\d+)\].*\Z#m ? $1 : $self;
return $ret;
};
*Mail::IMAPClient::fetch_hash = sub {
# taken from above *Mail::IMAPClient::fetch_hash
# if last arg is a ref then the fetch is done only
# on the messages listed as the keys of this hash.
# Init an "empty" $hash_ref by value can be done this way:
# @$hash_ref{2, 3, 4, 55} = (undef);
my $self = shift;
my $hash_ref = ref($_[-1]) ? pop @_ : {};
my @words = @_;
for (@words) {
s/([\( ])FAST([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE$2/i ;
s/([\( ])FULL([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE ENVELOPE BODY$2/i ;
}
my $msgs_ref_all;
if (scalar %$hash_ref) {
$msgs_ref_all = [ sort { $a <=> $b } keys (%$hash_ref) ];
#print "ZZZZ 1 [@$msgs_ref_all]\n";
}else{
$msgs_ref_all = scalar($self->messages);
#print "ZZZZ 2 [@$msgs_ref_all]\n";
}
my $split = $self->Split() || scalar(@$msgs_ref_all);
while(my @msgs = splice(@$msgs_ref_all, 0, $split)) {
#print "SPLIT: @msgs\n";
my $msgs_ref = \@msgs;
my $output = scalar($self->fetch($msgs_ref,"(" . join(" ",@_) . ")"))
; # unless grep(/\b(?:FAST|FULL)\b/i,@words);
my $x;
for ($x = 0; $x <= $#$output ; $x++) {
my $entry = {};
my $l = $output->[$x];
if ($self->Uid) {
my($uid) = $l =~ /\((?:.* )?UID (\d+).*\)/i;
next unless $uid;
if ( defined $hash_ref->{$uid} ) {
$entry = $hash_ref->{$uid} ;
}
else {
$hash_ref->{$uid} ||= $entry;
}
}
else {
my($mid) = $l =~ /^\* (\d+) FETCH/i;
next unless $mid;
if ( defined $hash_ref->{$mid} ) {
$entry = $hash_ref->{$mid} ;
}
else {
$hash_ref->{$mid} ||= $entry;
}
}
foreach my $w (@words) {
if ( $l =~ /\Q$w\E\s*$/i ) {
$entry->{$w} = $output->[$x+1];
$entry->{$w} =~ s/(?:\x0a?\x0d)+$//g;
chomp $entry->{$w};
}
else {
$l =~ /\( # open paren followed by ...
(?:.*\s)? # ...optional stuff and a space
\Q$w\E\s # escaped fetch field<sp>
(?:" # then: a dbl-quote
(\\.| # then bslashed anychar(s) or ...
[^"]+) # ... nonquote char(s)
"| # then closing quote; or ...
\( # ...an open paren
(\\.| # then bslashed anychar or ...
[^\)]*) # ... non-close-paren char
\)| # then closing paren; or ...
(\S+)) # unquoted string
(?:\s.*)? # possibly followed by space-stuff
\) # close paren
/xi;
$entry->{$w}=defined($1)?$1:defined($2)?$2:$3;
}
}
}
}
return wantarray ? %$hash_ref : $hash_ref;
};
*Mail::IMAPClient::login = sub {
my $self = shift;
return $self->authenticate($self->Authmechanism,$self->Authcallback)
if $self->{Authmechanism};
my $id = $self->User;
my $has_quotes = $id =~ /^".*"$/ ? 1 : 0;
my $string = "Login " . ( $has_quotes ? $id : qq("$id") ) .
" " . $self->Password . "\r\n";
$self->_imap_command($string)
and $self->State(Authenticated);
# $self->folders and $self->separator unless $self->NoAutoList;
unless ( $self->IsAuthenticated) {
my($carp) = $self->LastError;
$carp =~ s/^[\S]+ ([^\x0d\x0a]*)\x0d?\x0a/$1/;
carp $carp unless defined wantarray;
return undef;
};
return $self;
};
*Mail::IMAPClient::get_header = sub {
my($self , $msg, $header ) = @_;
my $val;
#eval { $val = $self->parse_headers([$msg],$header)->{$header}[0] };
my $h = $self->parse_headers([$msg],$header);
#require Data::Dumper;
#print Data::Dumper->Dump([$h]);
#$val = $self->parse_headers([$msg],$header)->{$header}[0];
$val = $h->{$msg}{$header}[0];
return defined($val)? $val : undef;
};
*Mail::IMAPClient::parse_headers = sub {
my($self,$msgspec_all,@fields) = @_;
my(%fieldmap) = map { ( lc($_),$_ ) } @fields;
my $msg; my $string; my $field;
#print ref($msgspec_all), "\n";
#if(ref($msgspec_all) eq 'HASH') {
# print ref($msgspec_all), "\n";
#$msgspec_all = [$msgspec_all];
#}
unless(ref($msgspec_all) eq 'ARRAY') {
print "parse_headers want an ARRAY ref\n";
#exit 1;
return undef;
}
my $headers = {}; # hash from message ids to header hash
my $split = $self->Split() || scalar(@$msgspec_all);
while(my @msgs = splice(@$msgspec_all, 0, $split)) {
#$debug and print "SPLIT: @msgs\n";
my $msgspec = \@msgs;
# Make $msg a comma separated list, of messages we want
$msg = $self->Range($msgspec);
if ($fields[0] =~ /^[Aa][Ll]{2}$/ ) {
$string = "$msg body" .
# use ".peek" if Peek parameter is a) defined and true,
# or b) undefined, but not if it's defined and untrue:
( defined($self->Peek) ?
( $self->Peek ? ".peek" : "" ) :
".peek"
) . "[header]" ;
}else {
$string = "$msg body" .
# use ".peek" if Peek parameter is a) defined and true, or
# b) undefined, but not if it's defined and untrue:
( defined($self->Peek) ?
( $self->Peek ? ".peek" : "" ) :
".peek"
) . "[header.fields (" . join(" ",@fields) . ')]' ;
}
my @raw=$self->fetch( $string ) or return undef;
my $h = 0; # reference to hash of current msgid, or 0 between msgs
for my $header (map { split(/(?:\x0d\x0a)/,$_) } @raw) {
no warnings;
if ( $header =~ /^\*\s+\d+\s+FETCH\s+\(.*BODY\[HEADER(?:\]|\.FIELDS)/i) {
if ($self->Uid) {
if ( my($msgid) = $header =~ /UID\s+(\d+)/ ) {
$h = {};
$headers->{$msgid} = $h;
}
else {
$h = {};
}
}
else {
if ( my($msgid) = $header =~ /^\*\s+(\d+)/ ) {
#start of new message header:
$h = {};
$headers->{$msgid} = $h;
}
}
}
next if $header =~ /^\s+$/;
# ( for vi
if ($header =~ /^\)/) { # end of this message
$h = 0; # set to be between messages
next;
}
# check for '<optional_white_space>UID<white_space><UID_number><optional_white_space>)'
# when parsing headers by UID.
if ($self->Uid and my($msgid) = $header =~ /^\s*UID\s+(\d+)\s*\)/) {
$headers->{$msgid} = $h; # store in results against this message
$h = 0; # set to be between messages
next;
}
if ($h != 0) { # do we expect this to be a header?
my $hdr = $header;
chomp $hdr;
$hdr =~ s/\r$//;
#print "W[$hdr]", ref($hdr), "!\n";
#next if ( ! defined($hdr));
#print "X[$hdr]\n";
if (defined($hdr) and ($hdr =~ s/^(\S+):\s*//)) {
# if ($hdr =~ s/^(\S+):\s*//) {
#print "X1\n";
$field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ;
push @{$h->{$field}} , $hdr ;
} elsif ($hdr =~ s/^.*FETCH\s\(.*BODY\[HEADER\.FIELDS.*\)\]\s(\S+):\s*//) {
#print "X2\n";
$field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ;
push @{$h->{$field}} , $hdr ;
} elsif ( ref($h->{$field}) eq 'ARRAY') {
#print "X3\n";
$hdr =~ s/^\s+/ /;
$h->{$field}[-1] .= $hdr ;
}
}
}
use warnings;
# my $candump = 0;
# if ($self->Debug) {
# eval {
# require Data::Dumper;
# Data::Dumper->import;
# };
# $candump++ unless $@;
# }
}
# if we asked for one message, just return its hash,
# otherwise, return hash of numbers => header hash
# if (ref($msgspec) eq 'ARRAY') {
return $headers;
};
*Mail::IMAPClient::authenticate = sub {
my $self = shift;
my $scheme = shift;
my $response = shift;
$scheme ||= $self->Authmechanism;
$response ||= $self->Authcallback;
my $clear = $self->Clear;
$self->Clear($clear)
if $self->Count >= $clear and $clear > 0;
my $count = $self->Count($self->Count+1);
my $string = "$count AUTHENTICATE $scheme";
$self->_record($count,[ $self->_next_index($self->Transaction),
"INPUT", "$string\x0d\x0a"] );
my $feedback = $self->_send_line("$string");
unless ($feedback) {
$self->LastError("Error sending '$string' to IMAP: $!\n");
return undef;
}
my ($code, $output);
until ($code) {
$output = $self->_read_line or return undef;
foreach my $o (@$output) {
$self->_record($count,$o); # $o is a ref
($code) = $o->[DATA] =~ /^\+(.*)$/ ;
if ($o->[DATA] =~ /^\*\s+BYE/) {
$self->State(Unconnected);
return undef ;
}
if ($o->[DATA]=~ /^\d+\s+(NO|BAD)/i) {
return undef ;
}
}
}
if ('CRAM-MD5' eq $scheme && ! $response) {
if ($Mail::IMAPClient::_CRAM_MD5_ERR) {
$self->LastError($Mail::IMAPClient::_CRAM_MD5_ERR);
carp $Mail::IMAPClient::_CRAM_MD5_ERR;
}
else {
$response = \&Mail::IMAPClient::_cram_md5;
}
}
$feedback = $self->_send_line($response->($code, $self));
unless ($feedback) {
$self->LastError("Error sending append msg text to IMAP: $!\n");
return undef;
}
$code = ""; # clear code
until ($code) {
$output = $self->_read_line or return undef;
foreach my $o (@$output) {
$self->_record($count,$o); # $o is a ref
if ( ($code) = $o->[DATA] =~ /^\+ (.*)$/ ) {
$feedback = $self->_send_line($response->($code,$self));
unless ($feedback) {
$self->LastError("Error sending append msg text to IMAP: $!\n");
return undef;
}
$code = "" ; # Clear code; we're still not finished
} else {
$o->[DATA] =~ /^$count (OK|NO|BAD)/ and $code = $1;
if ($o->[DATA] =~ /^\*\s+BYE/) {
$self->State(Unconnected);
return undef ;
}
}
}
}
$code =~ /^OK/ and $self->State(Authenticated) ;
return $code =~ /^OK/ ? $self : undef ;
};
*Mail::IMAPClient::_cram_md5 = sub {
my ($code, $client) = @_;
my $hmac = Digest::HMAC_MD5::hmac_md5_hex(MIME::Base64::decode($code),
$client->Password());
return MIME::Base64::encode($client->User() . " $hmac", "");
};
*Mail::IMAPClient::message_string = sub {
my $self = shift;
my $msg = shift;
my $expected_size = $self->size($msg);
return undef unless(defined $expected_size); # unable to get size
my $cmd = $self->has_capability('IMAP4REV1') ?
"BODY" . ( $self->Peek ? '.PEEK[]' : '[]' ) :
"RFC822" . ( $self->Peek ? '.PEEK' : '' ) ;
#print "Message_string Beg fetch:\n", memory_consumption();
$self->fetch($msg,$cmd) or return undef;
#print "Message_string End fetch:\n", memory_consumption();
my $string = "";
foreach my $result (@{$self->{"History"}{$self->Transaction}}) {
$string .= $result->[DATA]
if defined($result) and $self->_is_literal($result) ;
}
#print "Message_string End string:\n", memory_consumption();
# BUG? should probably return undef if length != expected
# No bug, somme servers are buggy.
if (! $self->Ignoresizeerrors ) {
if ( length($string) != $expected_size ) {
print "message_string: " .
"expected $expected_size bytes but received " .
length($string) . "\n";
$self->LastError("message_string: expected ".
"$expected_size bytes but received " .
length($string)."\n");
}
}
return $string;
};
{
no warnings 'once';
*Mail::IMAPClient::Ssl = sub {
my $self = shift;
if (@_) { $self->{SSL} = shift }
return $self->{SSL};
};
*Mail::IMAPClient::Starttls = sub {
my $self = shift;
if (@_) { $self->{Starttls} = shift }
return $self->{Starttls};
};
*Mail::IMAPClient::exists = sub {
# Bad implementation STATUS fails and can close the connexion
# Exchange does this after 10 failures
my ( $self, $folder ) = @_;
$self->status($folder) ? $self : undef;
};
*Mail::IMAPClient::Authuser = sub {
my $self = shift;
if (@_) { $self->{AUTHUSER} = shift }
return $self->{AUTHUSER};
};
*Mail::IMAPClient::Ignoresizeerrors = sub {
my $self = shift;
if (@_) { $self->{IGNORESIZEERRORS} = shift }
return $self->{IGNORESIZEERRORS};
};
*Mail::IMAPClient::Reconnectretry = sub {
my $self = shift;
if (@_) { $self->{RECONNECTRETRY} = shift }
return $self->{RECONNECTRETRY};
};
*Mail::IMAPClient::reconnect = sub {
my $self = shift;
if ( $self->IsAuthenticated ) {
$self->_debug("reconnect called but already authenticated");
return $self;
}
my $einfo = $self->LastError || "";
$self->_debug( "reconnecting to ", $self->Server, ", last error: $einfo" );
# reconnect and select appropriate folder
$self->connect or return undef;
return ( defined $self->Folder ) ? $self->select( $self->Folder ) : $self;
};
# wrapper for _imap_command_do to enable retrying on lost connections
*Mail::IMAPClient::_imap_command = sub {
my $self = shift;
my $tries = 0;
my $retry = $self->Reconnectretry || 0;
my ( $rc, @err );
#print "@_ Beg _imap_command:\n", memory_consumption();
# LastError (if set) will be overwritten masking any earlier errors
while ( $tries++ <= $retry ) {
# do command on the first try or if Connected (reconnect ongoing)
if ( $tries == 1 or $self->IsConnected ) {
#print "call @_\n";
$rc = $self->_imap_command_do(@_);
push( @err, $self->LastError ) if $self->LastError;
#print "call @_ done [", $rc || '', "] [$tries/$retry][" . $self->IsUnconnected . "]\n";
}
if ( !defined($rc)
and $retry and $self->IsUnconnected
and ( $self->LastIMAPCommand !~ /LOGOUT/ )
) {
print "\nWarning: disconnected. ";
if ( $self->reconnect ) {
print "Reconnect successful on try #$tries\n";
$self->Reconnect_counter($self->Reconnect_counter() + 1);
}
else {
print "Reconnect failed on try #$tries\n";
push( @err, $self->LastError ) if $self->LastError;
}
}
else {
last;
}
}
unless ($rc) {
my ( %seen, @keep, @info );
foreach my $str (@err) {
my ( $sz, $len ) = ( 96, length($str) );
$str =~ s/$CR?$LF$/\\n/omg;
if ( !$self->Debug and $len > $sz * 2 ) {
my $beg = substr( $str, 0, $sz );
my $end = substr( $str, -$sz, $sz );
$str = $beg . "..." . $end;
}
next if $seen{$str}++;
push( @keep, $str );
}
foreach my $msg (@keep) {
push( @info, $msg . ( $seen{$msg} > 1 ? " ($seen{$msg}x)" : "" ) );
}
$self->LastError( join( "; ", @info ) );
}
#print "@_ End _imap_command:\n", memory_consumption();
return $rc;
};
*Mail::IMAPClient::_imap_command_do = sub {
my $self = shift;
my $string = shift or return undef;
my $good = shift || 'GOOD';
my $qgood = quotemeta($good);
my $clear = "";
$clear = $self->Clear;
$self->Clear($clear)
if $self->Count >= $clear and $clear > 0;
my $count = $self->Count($self->Count+1);
$string = "$count $string" ;
#print "$string\n", memory_consumption();
$self->_record($count,[ 0, "INPUT", "$string\x0d\x0a"] );
#print "\n2 $count\n", memory_consumption();
my $feedback = $self->_send_line("$string");
unless ($feedback) {
$self->LastError( "Error sending '$string' to IMAP: $!\n");
$@ = "Error sending '$string' to IMAP: $!";
carp "Error sending '$string' to IMAP: $!";
return undef;
}
my ($code, $output);
$output = "";
READ: until ( $code) {
# escape infinite loop if read_line never returns any data:
$output = $self->_read_line or return undef;
for my $o (@$output) {
$self->_record($count,$o); # $o is a ref
# $self->_debug("Received from readline: ${\($o->[DATA])}<<END OF RESULT>>\n");
next unless $self->_is_output($o);
if ( $good eq '+' ) {
$o->[DATA] =~ /^$count (OK|BAD|NO|$qgood)|^($qgood)/mi ;
$code = $1||$2 ;
} else {
($code) = $o->[DATA] =~ /^$count (OK|BAD|NO|$qgood)/mi ;
}
if ($o->[DATA] =~ /^\*\s+BYE/im) {
$self->State(Unconnected);
return undef ;
}
}
}
#print "$string: returned $code\n", memory_consumption();
# $self->_debug("Command $string: returned $code\n");
return $code =~ /^OK|$qgood/im ? $self : undef ;
};
# capability 2.2.9 is stupid: it caches and return first imap CAPABILITY call
# but call imap CAPABILITY each time.
# Copy/paste from 3.25
*Mail::IMAPClient::capability = sub {
my $self = shift;
if ( $self->{CAPABILITY} ) {
my @caps = keys %{ $self->{CAPABILITY} };
return wantarray ? @caps : \@caps;
}
$self->_imap_command('CAPABILITY')
or return undef;
my @caps = map { split } grep s/^\*\s+CAPABILITY\s+//, $self->History;
foreach (@caps) {
$self->{CAPABILITY}{ uc $_ }++;
$self->{ uc $1 } = uc $2 if /(.*?)\=(.*)/;
}
return wantarray ? @caps : \@caps;
};
*Mail::IMAPClient::_read_line = sub {
my $self = shift;
my $sh = $self->Socket;
my $literal_callback = shift;
my $output_callback = shift;
unless ($self->IsConnected and $self->Socket) {
$self->LastError("NO Not connected.\n");
carp "Not connected" if $^W;
return undef;
}
my $iBuffer = "";
my $oBuffer = [];
my $count = 0;
my $index = $self->_next_index($self->Transaction);
my $rvec = my $ready = my $errors = 0;
my $timeout = $self->Timeout;
my $readlen = 1;
my $fast_io = $self->Fast_io; # Remember setting to reduce future method calls
if ( $fast_io ) {
# set fcntl if necessary:
exists $self->{_fcntl} or $self->Fast_io($fast_io);
$readlen = $self->{Buffer}||4096;
}
until (
# there's stuff in output buffer:
scalar(@$oBuffer) and
# the last thing there has cr-lf:
$oBuffer->[-1][DATA] =~ /\x0d\x0a$/ and
# that thing is an output line:
$oBuffer->[-1][TYPE] eq "OUTPUT" and
# and the input buffer has been MT'ed:
$iBuffer eq ""
) {
#print memory_consumption();
my $transno = $self->Transaction; # used below in several places
if ($timeout) {
vec($rvec, fileno($self->Socket), 1) = 1;
my @ready = $self->{_select}->can_read($timeout) ;
unless ( @ready ) {
$self->LastError("Tag $transno: " .
"Timeout after $timeout seconds " .
"waiting for data from server\n");
$self->_record($transno,
[ $self->_next_index($transno),
"ERROR",
"$transno * NO Timeout after ".
"$timeout seconds " .
"during read from " .
"server\x0d\x0a"
]
);
$self->LastError(
"Timeout after $timeout seconds " .
"during read from server\x0d\x0a"
);
return undef;
}
}
#local($^W) = undef; # Now quiet down warnings
# read "$readlen" bytes (or less):
# need to check return code from $self->_sysread
# in case other end has shut down!!!
my $ret = $self->_sysread( $sh, \$iBuffer, $readlen, length($iBuffer)) ;
# $self->_debug("Read so far: $iBuffer<<END>>\n");
redo if(! defined($ret)) ;
if(($timeout and ! defined($ret))) { # Blocking read error...
my $msg = "Error while reading data from server: $!\x0d\x0a";
$self->LastError('Error while reading data from server');
$self->State(Unconnected);
print $msg;
$self->_record($transno,
[ $self->_next_index($transno),
"ERROR", "$transno * NO $msg "
]);
$@ = "$msg";
return undef;
}
elsif(defined($ret) and $ret == 0) { # Caught EOF...
my $msg="Socket closed while reading data from server [$!]\x0d\x0a";
print "$msg";
$self->LastError('Socket closed while reading data from server');
$self->State(Unconnected);
$self->_record($transno,
[ $self->_next_index($transno),
"ERROR", "$transno * NO $msg "
]);
$@ = "$msg";
return undef;
}
# successfully wrote to other end, keep going...
$count += $ret;
LINES: while ( $iBuffer =~ s/^(.*?\x0d?\x0a)// ) {
my $current_line = $1;
#print memory_consumption();
# $self->_debug("BUFFER: pulled from buffer: <BEGIN>${current_line}<END>\n" .
# "and left with buffer contents of: <BEGIN>${iBuffer}<END>\n");
LITERAL: if ($current_line =~ s/\{(\d+)\}\x0d\x0a$//) {
# This part handles IMAP "Literals",
# which according to rfc2060 look something like this:
# [tag]|* BLAH BLAH {nnn}\r\n
# [nnn bytes of literally transmitted stuff]
# [part of line that follows literal data]\r\n
# Set $len to be length of impending literal:
my $len = $1 ;
$self->_debug("LITERAL: received literal in line ".
"$current_line of length $len; ".
"attempting to ".
"retrieve from the " . length($iBuffer) .
" bytes in: $iBuffer<END_OF_iBuffer>\n");
# Xfer up to $len bytes from front of $iBuffer to $litstring:
my $litstring = substr($iBuffer, 0, $len);
$iBuffer = substr($iBuffer, length($litstring),
length($iBuffer) - length($litstring) ) ;
# Figure out what's left to read (i.e. what part of
# literal wasn't in buffer):
my $remainder_count = $len - length($litstring);
my $callback_value = "";
if ( defined($literal_callback) ) {
if ( $literal_callback =~ /GLOB/) {
print $literal_callback $litstring ;
$litstring = "";
} elsif ($literal_callback =~ /CODE/ ) {
# Don't do a thing
} else {
$self->LastError(
ref($literal_callback) .
" is an invalid callback type; " .
"must be a filehandle or coderef\n"
);
}
}
if ($remainder_count > 0 and $timeout) {
# If we're doing timeouts then here we set up select
# and wait for data from the the IMAP socket.
vec($rvec, fileno($self->Socket), 1) = 1;
unless ( CORE::select( $ready = $rvec,
undef,
$errors = $rvec,
$timeout)
) {
# Select failed; that means bad news.
# Better tell someone.
$self->LastError("Tag " . $transno .
": Timeout waiting for literal data " .
"from server\n");
carp "Tag " . $transno .
": Timeout waiting for literal data " .
"from server\n"
if $self->Debug or $^W;
return undef;
}
}
fcntl($sh, F_SETFL, $self->{_fcntl})
if $fast_io and defined($self->{_fcntl});
while ( $remainder_count > 0 ) { # As long as not done,
$self->_debug("Still need $remainder_count to " .
"complete literal string\n");
my $ret = $self->_sysread( # bytes read
$sh, # IMAP handle
\$litstring, # place to read into
$remainder_count, # bytes left to read
length($litstring) # offset to read into
) ;
$self->_debug("Received ret=$ret and buffer = " .
"\n$litstring<END>\nwhile processing LITERAL\n");
if ( $timeout and !defined($ret)) { # possible timeout
$self->_record($transno, [
$self->_next_index($transno),
"ERROR",
"$transno * NO Error reading data " .
"from server: $!\n"
]
);
return undef;
} elsif ( $ret == 0 and eof($sh) ) {
$self->_record($transno, [
$self->_next_index($transno),
"ERROR",
"$transno * ".
"BYE Server unexpectedly " .
"closed connection: $!\n"
]
);
$self->State(Unconnected);
return undef;
}
# decrement remaining bytes by amt read:
$remainder_count -= $ret;
if ( length($litstring) > $len ) {
# copy the extra struff into the iBuffer:
$iBuffer = substr(
$litstring,
$len,
length($litstring) - $len
);
$litstring = substr($litstring, 0, $len) ;
}
if ( defined($literal_callback) ) {
if ( $literal_callback =~ /GLOB/ ) {
print $literal_callback $litstring;
$litstring = "";
}
}
}
$literal_callback->($litstring)
if defined($litstring) and
defined($literal_callback) and $literal_callback =~ /CODE/;
$self->Fast_io($fast_io) if $fast_io;
# Now let's make sure there are no IMAP server output lines
# (i.e. [tag|*] BAD|NO|OK Text) embedded in the literal string
# (There shouldn't be but I've seen it done!), but only if
# EnableServerResponseInLiteral is set to true
my $embedded_output = 0;
my $lastline = ( split(/\x0d?\x0a/,$litstring))[-1]
if $litstring;
if ( $self->EnableServerResponseInLiteral and
$lastline and
$lastline =~ /^(?:\*|(\d+))\s(BAD|NO|OK)/i
) {
$litstring =~ s/\Q$lastline\E\x0d?\x0a//;
$embedded_output++;
$self->_debug("Got server output mixed in " .
"with literal: $lastline\n"
) if $self->Debug;
}
# Finally, we need to stuff the literal onto the
# end of the oBuffer:
push @$oBuffer, [ $index++, "OUTPUT" , $current_line],
[ $index++, "LITERAL", $litstring ];
push @$oBuffer, [ $index++, "OUTPUT", $lastline ]
if $embedded_output;
} else {
push @$oBuffer, [ $index++, "OUTPUT" , $current_line ];
}
}
#$self->_debug("iBuffer is now: $iBuffer<<END OF BUFFER>>\n");
}
# _debug $self, "Buffer is now $buffer\n";
_debug $self, "Read: " . join("",map {$_->[DATA]} @$oBuffer) ."\n"
if $self->Debug;
return scalar(@$oBuffer) ? $oBuffer : undef ;
};
}
# End of sub override_imapclient (yes, very bad indentation)
}
# IMAPClient 2.2.9 3.xx ads
package Mail::IMAPClient;
sub Split {
my $self = shift;
if (@_) {
$self->{SPLIT} = shift;
$self->{Maxcommandlength} = 10 * $self->{SPLIT};
}
return $self->{SPLIT};
}
sub Tls {
my $self = shift;
if (@_) { $self->{TLS} = shift }
return $self->{TLS};
}
sub Reconnect_counter {
my $self = shift;
$self->{Reconnect_counter} = 0 if ( not defined( $self->{Reconnect_counter} ) ) ;
if (@_) { $self->{Reconnect_counter} = shift }
return $self->{Reconnect_counter};
}
sub Banner {
my $self = shift;
if (@_) { $self->{BANNER} = shift }
return $self->{BANNER};
}
sub RawSocket2 {
my ( $self, $sock ) = @_;
defined $sock
or return $self->{Socket};
$self->{Socket} = $sock;
$self->{_select} = IO::Select->new($sock);
delete $self->{_fcntl};
#$self->Fast_io( $self->Fast_io );
$sock;
}
sub capability_update {
my $self = shift;
delete $self->{CAPABILITY};
$self->capability;
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment