diff --git a/CREDITS b/CREDITS index 3275cb3..bb21e8b 100644 --- a/CREDITS +++ b/CREDITS @@ -1,5 +1,5 @@ #!/bin/cat -# $Id: CREDITS,v 1.155 2011/01/23 23:39:54 gilles Exp gilles $ +# $Id: CREDITS,v 1.156 2011/03/15 00:51:57 gilles Exp gilles $ If you want to make a donation to the author, Gilles LAMIRAL, use any of the following ways: @@ -30,6 +30,21 @@ I thank very much all of these people. I thank also very much all people who bought imapsync from the homepage but I don't cite them here. +Khalid Shakir +Contributed by giving the book +75.00 "Selected Papers on Fun and Games [Hardcover]" + +Alexander J. Stein +Contributed by giving the book +22.00 "Weinberg on Writing: The Fieldstone Method" + +Doug Ferguson +Contributed by giving the books +35.16 "Test Driven Development: By Example" +13.86 "Gödel, Escher, Bach: An Eternal Golden Braid" +14.49 "The Mind's I: Fantasies and Reflections on Self & Soul" +46.42 "Memory" + Timothy Jay Chambers Contributed by giving the book 27.32 "Mathematics and Plausible Reasoning: Volume II Patterns of Plausible Inference" @@ -981,6 +996,13 @@ Eric Yung Total amount of book prices : c \ +75.00+\ +\ +35.16+\ +13.86+\ +14.49+\ +46.42+\ +\ 27.32+\ 40.90+\ \ @@ -1102,4 +1124,4 @@ c \ 31.20+\ 40.00 = -2779.03 +2963.96 diff --git a/ChangeLog b/ChangeLog index 3021928..24f3c03 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,17 +1,49 @@ RCS file: RCS/imapsync,v Working file: imapsync -head: 1.404 +head: 1.411 branch: locks: strict - gilles: 1.404 + gilles: 1.411 access list: symbolic names: keyword substitution: kv -total revisions: 404; selected revisions: 404 +total revisions: 411; selected revisions: 411 description: ---------------------------- -revision 1.404 locked by: gilles; +revision 1.411 locked by: gilles; +date: 2011/04/19 23:34:30; author: gilles; state: Exp; lines: +19 -11 +Bugfix for "Folders in host2 not in host1" list when folders are given by --folder option or equivalent. +The old list listed too many folders with --folder INBOX for example. +---------------------------- +revision 1.410 +date: 2011/04/19 23:11:42; author: gilles; state: Exp; lines: +9 -8 +Updated success list. +---------------------------- +revision 1.409 +date: 2011/04/16 20:15:05; author: gilles; state: Exp; lines: +7 -6 +Added --takebody option. +---------------------------- +revision 1.408 +date: 2011/04/11 01:37:34; author: gilles; state: Exp; lines: +9 -8 +Added Gimap (Gmail imap) success. +Added IMail 11.03 [host1] success +---------------------------- +revision 1.407 +date: 2011/04/02 23:07:09; author: gilles; state: Exp; lines: +21 -12 +Made --delete2 works with --uselib or --usecache +---------------------------- +revision 1.406 +date: 2011/03/10 01:35:57; author: gilles; state: Exp; lines: +15 -13 +No longer --useuid with --fast +Debug output with permanentflags. +---------------------------- +revision 1.405 +date: 2011/03/07 13:41:54; author: gilles; state: Exp; lines: +13 -11 +Added isync url. +Sleep 2 seconds after foldersizes calls. +---------------------------- +revision 1.404 date: 2011/02/21 03:35:39; author: gilles; state: Exp; lines: +7 -7 typo ---------------------------- diff --git a/FAQ b/FAQ index 8914cc1..10ffef0 100644 --- a/FAQ +++ b/FAQ @@ -1,5 +1,5 @@ #!/bin/cat -# $Id: FAQ,v 1.83 2011/01/28 05:14:12 gilles Exp gilles $ +# $Id: FAQ,v 1.85 2011/02/28 16:02:17 gilles Exp gilles $ +------------------+ | FAQ for imapsync | @@ -24,7 +24,7 @@ R. http://www.linux-france.org/prj/imapsync/FAQ Q. How can I have commercial support? R. Ask the imapsync author and expert: Gilles LAMIRAL -Rates per hour (2010) : 81 euros (111 USD) +Rates per hour (2011) : 84 euros (111 USD) ======================================================================= Q. How can I have gratis support? @@ -81,7 +81,7 @@ http://www.faqs.org/rfcs/rfc4549.html ======================================================================= Q. Where I can find old imapsync releases? -R. ftp://www.linux-france.org/pub/prj/imapsync/ +R. Search the internet. ======================================================================= Q. How can I try imapsync with the new Mail::IMAPClient 3.xx perl library? @@ -103,8 +103,7 @@ R. - Download latest Mail::IMAPClient 3.xx at perl -I./Mail-IMAPClient-3.23/lib /path/imapsync ... ======================================================================= -Q. imapsync does not work with Mail::IMAPClient 3.xx - How can I downgrade to 2.2.9 release? +Q. How can I use imapsync with Mail::IMAPClient 2.2.9 perl module? R. - Download Mail::IMAPClient 2.2.9 at http://search.cpan.org/~djkernen/Mail-IMAPClient-2.2.9/ @@ -119,12 +118,18 @@ R. - Download Mail::IMAPClient 2.2.9 at perl -I./Mail-IMAPClient-2.2.9 /path/imapsync [...] ======================================================================= -Q. Can I use imapsync to migrate emails from pop server to imap server? +Q. Can I use imapsync to migrate emails from pop3 server to imap server? -R. No. +R1. No. You can migrate emails from pop server to imap server with pop2imap: http://www.linux-france.org/prj/pop2imap/ +R2. Yes +Many pop3 servers runs in parallel with an imap server on the +exactly the same mailboxes. They serve the same INBOX +(imap serves INBOX and several other folders, pop3 serves only INBOX) +So have a try with imapsync on the same host1. + ======================================================================= Q. I am interested in creating a local clone of the IMAP on a LAN server for faster synchronisations, email will always be delivered @@ -178,18 +183,35 @@ d) Use the --syncinternaldates option and keep using Eudora. Q. imapsync calculates 479 messages in a folder but only transfers 400 messages. What's happen? -R. imapsync considers the header part of a message (as a whole or +R1. imapsync considers the header part of a message (as a whole or only specific lines depending on --useheader --skipheader) to identify a message on both sides. -Two consequences: +Consequences: - 1) Messages with no header are not transferred. - 2) Duplicate messages (identical header) are not transferred + 1) Duplicate messages (identical header) are not transferred several times. The result is that you can have more messages on host1 than on host2. +R2. With option --useuid imapsync doesn't use headers to identify +messages on both sides but it uses their imap uid. In than case +duplicates are transfered and --delete2 won't work. + +======================================================================= +Q. I run multiple imapsync applications at the same time then get a + warning "imapsync.pid already exists, overwriting it". + Is this a potential problem when trying to sync multiple + IMAP account in parallel? + +R1. No issue with the file imapsync.pid if you don't use its content. +This file can help you to manage multiple runs by sending +signals to the processes (sigterm or sigkill) using their PID, +each run can have its own pid file with --pidfile option. +The file imapsync.pid contains the PID of the imapsync process. +This file is removed at the end of a normal run. +You can saafely ignore the warning if you don't use imapsync.pid. + ======================================================================= Q. Couldn't create [INBOX.Ops/foo/bar]: NO Invalid mailbox name: INBOX.Ops/foo/bar @@ -208,7 +230,7 @@ Sometimes the sep1 character is not valid on host2 (character "/" usualy) R. Try : - --regextrans2 's,/,X,g' + --regextrans2 "s,/,X,g" It'll convert / character to X Choose X as you wish: _ or SEP or @@ -267,7 +289,7 @@ R. For some servers, flags have to begin with a \ character. The flag "NonJunk" may be a invalid flag for your server so use for example: -imapsync ... --regexflag 's/NonJunk//g' +imapsync ... --regexflag "s/NonJunk//g" Remark (thanks to Arnt Gulbrandsen): IMAP system flags have to begin with \ character. @@ -1157,19 +1179,3 @@ Q: How can I write an .rpm with imapsync R: I don't know but Neil Brown wrote one rpm package and you'll find his .spec file here : http://www.linux-france.org/prj/imapsync/learn/rpm/ - -====================================================================== -Q: Problems on win32, Timezone and Date::Manip -R: Comment the code like the following - - if ($syncinternaldates) { - $d = $f_idate; - $debug and print "internal date from 1: [$d]\n"; - #require Date::Manip; - #Date::Manip->import(qw(ParseDate Date_Cmp UnixDate)); - #$d = UnixDate(ParseDate($d), "%d %b %Y %H:%M:%S %z"); - #$d = "\"$d\""; - #$debug and print "internal date from 1: [$d] (fixed)\n"; - } - - diff --git a/Mail-IMAPClient-3.27/Changes b/Mail-IMAPClient-3.28/Changes similarity index 99% rename from Mail-IMAPClient-3.27/Changes rename to Mail-IMAPClient-3.28/Changes index 267d807..137a4c7 100644 --- a/Mail-IMAPClient-3.27/Changes +++ b/Mail-IMAPClient-3.28/Changes @@ -5,6 +5,21 @@ Changes from 2.99_01 to 3.16 made by Mark Overmeer Changes from 0.09 to 2.99_01 made by David Kernen - Potential compatibility issues from 3.17+ highlighted with '*' +version 3.28_04: Fri Mar 4 00:17:38 EST 2011 + - rt.cpan.org#66004: internaldate() return undef if no internaldate in reply + [Jason Long] + - rt.cpan.org#66367: fetch_hash uses Escaped_results() in 3.26/3.27 + (redo) rt.cpan.org#63524: fetch_hash() parse errors + [Mathias Reitinger] + + fetch_hash: only Escape() data in parenthesized list + + update fetch_hash test and add a new test + - do not touch CRLF in Escape()/Unescape() + - added Escape() method + - rt.cpan.org#66287: flags results truncated due to Maxcommandlength + [Erik Colson] + - rt.cpan.org#65694: SASL PLAIN: bad order of login data + [Willi Mann] + version 3.27: Sun Feb 13 14:37:27 EST 2011 - rt.cpan.org#65694: migrate fails [Erik Colson] diff --git a/Mail-IMAPClient-3.27/MANIFEST b/Mail-IMAPClient-3.28/MANIFEST similarity index 100% rename from Mail-IMAPClient-3.27/MANIFEST rename to Mail-IMAPClient-3.28/MANIFEST diff --git a/Mail-IMAPClient-3.27/META.yml b/Mail-IMAPClient-3.28/META.yml similarity index 97% rename from Mail-IMAPClient-3.27/META.yml rename to Mail-IMAPClient-3.28/META.yml index 39692f1..e10d446 100644 --- a/Mail-IMAPClient-3.27/META.yml +++ b/Mail-IMAPClient-3.28/META.yml @@ -1,6 +1,6 @@ --- #YAML:1.0 name: Mail-IMAPClient -version: 3.27 +version: 3.28 abstract: IMAP4 client library author: - Phil Pearl (Lobbes) diff --git a/Mail-IMAPClient-3.27/Makefile.PL b/Mail-IMAPClient-3.28/Makefile.PL similarity index 100% rename from Mail-IMAPClient-3.27/Makefile.PL rename to Mail-IMAPClient-3.28/Makefile.PL diff --git a/Mail-IMAPClient-3.27/README b/Mail-IMAPClient-3.28/README similarity index 100% rename from Mail-IMAPClient-3.27/README rename to Mail-IMAPClient-3.28/README diff --git a/Mail-IMAPClient-3.27/examples/build_dist.pl b/Mail-IMAPClient-3.28/examples/build_dist.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/build_dist.pl rename to Mail-IMAPClient-3.28/examples/build_dist.pl diff --git a/Mail-IMAPClient-3.27/examples/build_ldif.pl b/Mail-IMAPClient-3.28/examples/build_ldif.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/build_ldif.pl rename to Mail-IMAPClient-3.28/examples/build_ldif.pl diff --git a/Mail-IMAPClient-3.27/examples/cleanTest.pl b/Mail-IMAPClient-3.28/examples/cleanTest.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/cleanTest.pl rename to Mail-IMAPClient-3.28/examples/cleanTest.pl diff --git a/Mail-IMAPClient-3.27/examples/copy_folder.pl b/Mail-IMAPClient-3.28/examples/copy_folder.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/copy_folder.pl rename to Mail-IMAPClient-3.28/examples/copy_folder.pl diff --git a/Mail-IMAPClient-3.27/examples/cyrus_expire.pl b/Mail-IMAPClient-3.28/examples/cyrus_expire.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/cyrus_expire.pl rename to Mail-IMAPClient-3.28/examples/cyrus_expire.pl diff --git a/Mail-IMAPClient-3.27/examples/cyrus_expunge.pl b/Mail-IMAPClient-3.28/examples/cyrus_expunge.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/cyrus_expunge.pl rename to Mail-IMAPClient-3.28/examples/cyrus_expunge.pl diff --git a/Mail-IMAPClient-3.27/examples/find_dup_msgs.pl b/Mail-IMAPClient-3.28/examples/find_dup_msgs.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/find_dup_msgs.pl rename to Mail-IMAPClient-3.28/examples/find_dup_msgs.pl diff --git a/Mail-IMAPClient-3.27/examples/idle.pl b/Mail-IMAPClient-3.28/examples/idle.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/idle.pl rename to Mail-IMAPClient-3.28/examples/idle.pl diff --git a/Mail-IMAPClient-3.27/examples/imap_to_mbox.pl b/Mail-IMAPClient-3.28/examples/imap_to_mbox.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/imap_to_mbox.pl rename to Mail-IMAPClient-3.28/examples/imap_to_mbox.pl diff --git a/Mail-IMAPClient-3.27/examples/imtestExample.pl b/Mail-IMAPClient-3.28/examples/imtestExample.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/imtestExample.pl rename to Mail-IMAPClient-3.28/examples/imtestExample.pl diff --git a/Mail-IMAPClient-3.27/examples/migrate_mail2.pl b/Mail-IMAPClient-3.28/examples/migrate_mail2.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/migrate_mail2.pl rename to Mail-IMAPClient-3.28/examples/migrate_mail2.pl diff --git a/Mail-IMAPClient-3.27/examples/migrate_mbox.pl b/Mail-IMAPClient-3.28/examples/migrate_mbox.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/migrate_mbox.pl rename to Mail-IMAPClient-3.28/examples/migrate_mbox.pl diff --git a/Mail-IMAPClient-3.27/examples/populate_mailbox.pl b/Mail-IMAPClient-3.28/examples/populate_mailbox.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/populate_mailbox.pl rename to Mail-IMAPClient-3.28/examples/populate_mailbox.pl diff --git a/Mail-IMAPClient-3.27/examples/sharedFolder.pl b/Mail-IMAPClient-3.28/examples/sharedFolder.pl similarity index 100% rename from Mail-IMAPClient-3.27/examples/sharedFolder.pl rename to Mail-IMAPClient-3.28/examples/sharedFolder.pl diff --git a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient.pm b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient.pm similarity index 98% rename from Mail-IMAPClient-3.27/lib/Mail/IMAPClient.pm rename to Mail-IMAPClient-3.28/lib/Mail/IMAPClient.pm index b465dbe..cebb696 100644 --- a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient.pm +++ b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient.pm @@ -7,7 +7,7 @@ use strict; use warnings; package Mail::IMAPClient; -our $VERSION = '3.27'; +our $VERSION = '3.28'; use Mail::IMAPClient::MessageSet; @@ -1708,7 +1708,7 @@ sub Escaped_results { # literal is appended to previous data if ( $self->_is_literal($line) ) { - $data =~ s/([\\\(\)"$CRLF])/\\$1/og; + $data = $self->Escape($data); $a[-1] .= qq( "$data"); $prevwasliteral = 1; } @@ -1726,10 +1726,16 @@ sub Escaped_results { return wantarray ? @a : \@a; } +sub Escape { + my $data = $_[1]; + $data =~ s/([\\\"])/\\$1/og; + return $data; +} + sub Unescape { - my $whatever = $_[1]; - $whatever =~ s/\\([\\\(\)"$CRLF])/$1/og; - $whatever; + my $data = $_[1]; + $data =~ s/\\([\\\"])/$1/og; + return $data; } sub logout { @@ -2001,7 +2007,7 @@ s/([\( ])FULL([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE ENVELOPE BODY$2/i; } my %words = map { uc($_) => 1 } @words; - my $output = $self->fetch( { escaped => 1 }, $msgs, "($what)" ) + my $output = $self->fetch( $msgs, "($what)" ) or return undef; while ( my $l = shift @$output ) { @@ -2025,7 +2031,7 @@ s/([\( ])FULL([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE ENVELOPE BODY$2/i; $l = shift @$output; next ATTR; } - elsif ( $l =~ m/\G(?:"([^"]+)"|([^()\s]+))\s*/gc ) { + elsif ( $l =~ m/\G(?:"(.*?)(?:(?{$key} = $value; next ATTR; @@ -2050,6 +2056,13 @@ s/([\( ])FULL([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE ENVELOPE BODY$2/i; else { $value .= $stuff; } + + # consume literal data if any + if ( $l =~ m/\G\s*$/gc and scalar(@$output) ) { + my $elit = $self->Escape( shift @$output ); + $l = shift @$output; + $value .= ( length($value) ? " " : "" ) . qq{"$elit"}; + } } $l =~ m/\G\s*/gc; } @@ -2207,13 +2220,13 @@ sub flags { $msg->cat(@_) if @_; # Send command - $self->fetch( $msg, "FLAGS" ) or return undef; + my $ref = $self->fetch( $msg, "FLAGS" ) or return undef; my $u_f = $self->Uid; my $flagset = {}; # Parse results, setting entry in result hash for each line - foreach my $line ( $self->Results ) { + foreach my $line (@$ref) { $self->_debug("flags: line = '$line'"); if ( $line =~ /\* \s+ (\d+) \s+ FETCH \s+ # * nnn FETCH @@ -2661,10 +2674,8 @@ sub internaldate { my ( $self, $msg ) = @_; $self->_imap_uid_command( FETCH => $msg, 'INTERNALDATE' ) or return undef; - my $internalDate = join '', $self->History; - $internalDate =~ s/^.*INTERNALDATE "//si; - $internalDate =~ s/\".*$//s; - $internalDate; + my $hist = join '', $self->History; + return $hist =~ /\bINTERNALDATE "([^"]*)"/i ? $1 : undef; } sub is_parent { @@ -2973,13 +2984,14 @@ sub authenticate { elsif ( $scheme eq 'PLAIN' ) { # PLAIN SASL $response ||= sub { my ( $code, $client ) = @_; - encode_base64( - $client->User - . chr(0) - . $client->Proxy - . chr(0) - . $client->Password, - '' + encode_base64( # [authname] user password + join( + chr(0), + defined $client->Proxy + ? ( $client->User, $client->Proxy ) + : ( "", $client->User ), + defined $client->Password ? $client->Password : "", + ), ); }; } diff --git a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient.pod b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient.pod similarity index 99% rename from Mail-IMAPClient-3.27/lib/Mail/IMAPClient.pod rename to Mail-IMAPClient-3.28/lib/Mail/IMAPClient.pod index f03cc89..6a4b12c 100644 --- a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient.pod +++ b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient.pod @@ -94,7 +94,13 @@ CRAM-MD5 requires the L module. =item PLAIN (SASL) -PLAIN (SASL) authentication requires the use of the L parameter. +PLAIN (SASL) authentication allows the optional use of the L +parameter. RFC 4616 documents this syntax for SASL PLAIN: + + message = [authzid] UTF8NUL authcid UTF8NUL passwd + +When L is defined, L is used as 'authzid' and L +is used as 'authcid'. Otherwise, L is used as 'authcid'. =item NTLM @@ -1056,16 +1062,14 @@ This would result in L output similar to the following: } }; -By itself this method may be useful for, say, speeding up programs that -want the size of every message in a folder. It issues one command and -receives one (possibly long!) response from the server. However, it's -true power lies in the as-yet-unwritten methods that will rely on this -method to deliver even more powerful result hashes. Look for more new -function in later releases. +By itself this method may be useful for tasks like obtaining the size +of every message in a folder. It issues one command and receives one +(possibly long!) response from the server. -This method is new with version 2.2.3 and is thus still experimental. -If you decide to try this method and run into problems, please see the -section on L. +If the fetch request causes the server to return data in a +parenthesized list, the data within the parenthesized list may be +escaped via the Escape() method. Use the Unescape() method to get the +raw values back in this case. =head2 flags @@ -1308,7 +1312,8 @@ Example: or die "Could not internaldate: $@\n"; B accepts one argument, a message id (or UID if the -L parameter is true), and returns that message's internal date. +L parameter is true), and returns that message's internal date +or undef if the call fails or internal date is not returned. =head2 get_bodystructure diff --git a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient/BodyStructure.pm b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient/BodyStructure.pm similarity index 100% rename from Mail-IMAPClient-3.27/lib/Mail/IMAPClient/BodyStructure.pm rename to Mail-IMAPClient-3.28/lib/Mail/IMAPClient/BodyStructure.pm diff --git a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient/BodyStructure/Parse.grammar b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient/BodyStructure/Parse.grammar similarity index 100% rename from Mail-IMAPClient-3.27/lib/Mail/IMAPClient/BodyStructure/Parse.grammar rename to Mail-IMAPClient-3.28/lib/Mail/IMAPClient/BodyStructure/Parse.grammar diff --git a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient/BodyStructure/Parse.pm b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient/BodyStructure/Parse.pm similarity index 100% rename from Mail-IMAPClient-3.27/lib/Mail/IMAPClient/BodyStructure/Parse.pm rename to Mail-IMAPClient-3.28/lib/Mail/IMAPClient/BodyStructure/Parse.pm diff --git a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient/BodyStructure/Parse.pod b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient/BodyStructure/Parse.pod similarity index 100% rename from Mail-IMAPClient-3.27/lib/Mail/IMAPClient/BodyStructure/Parse.pod rename to Mail-IMAPClient-3.28/lib/Mail/IMAPClient/BodyStructure/Parse.pod diff --git a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient/MessageSet.pm b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient/MessageSet.pm similarity index 100% rename from Mail-IMAPClient-3.27/lib/Mail/IMAPClient/MessageSet.pm rename to Mail-IMAPClient-3.28/lib/Mail/IMAPClient/MessageSet.pm diff --git a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient/Thread.grammar b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient/Thread.grammar similarity index 100% rename from Mail-IMAPClient-3.27/lib/Mail/IMAPClient/Thread.grammar rename to Mail-IMAPClient-3.28/lib/Mail/IMAPClient/Thread.grammar diff --git a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient/Thread.pm b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient/Thread.pm similarity index 100% rename from Mail-IMAPClient-3.27/lib/Mail/IMAPClient/Thread.pm rename to Mail-IMAPClient-3.28/lib/Mail/IMAPClient/Thread.pm diff --git a/Mail-IMAPClient-3.27/lib/Mail/IMAPClient/Thread.pod b/Mail-IMAPClient-3.28/lib/Mail/IMAPClient/Thread.pod similarity index 100% rename from Mail-IMAPClient-3.27/lib/Mail/IMAPClient/Thread.pod rename to Mail-IMAPClient-3.28/lib/Mail/IMAPClient/Thread.pod diff --git a/Mail-IMAPClient-3.27/prepare_dist b/Mail-IMAPClient-3.28/prepare_dist similarity index 100% rename from Mail-IMAPClient-3.27/prepare_dist rename to Mail-IMAPClient-3.28/prepare_dist diff --git a/Mail-IMAPClient-3.27/t/basic.t b/Mail-IMAPClient-3.28/t/basic.t similarity index 100% rename from Mail-IMAPClient-3.27/t/basic.t rename to Mail-IMAPClient-3.28/t/basic.t diff --git a/Mail-IMAPClient-3.27/t/body_string.t b/Mail-IMAPClient-3.28/t/body_string.t similarity index 100% rename from Mail-IMAPClient-3.27/t/body_string.t rename to Mail-IMAPClient-3.28/t/body_string.t diff --git a/Mail-IMAPClient-3.27/t/bodystructure.t b/Mail-IMAPClient-3.28/t/bodystructure.t similarity index 100% rename from Mail-IMAPClient-3.27/t/bodystructure.t rename to Mail-IMAPClient-3.28/t/bodystructure.t diff --git a/Mail-IMAPClient-3.27/t/fetch_hash.t b/Mail-IMAPClient-3.28/t/fetch_hash.t similarity index 81% rename from Mail-IMAPClient-3.27/t/fetch_hash.t rename to Mail-IMAPClient-3.28/t/fetch_hash.t index 5ce15a0..c998887 100644 --- a/Mail-IMAPClient-3.27/t/fetch_hash.t +++ b/Mail-IMAPClient-3.28/t/fetch_hash.t @@ -9,7 +9,7 @@ use strict; use warnings; -use Test::More tests => 19; +use Test::More tests => 20; BEGIN { use_ok('Mail::IMAPClient') or exit; } @@ -100,26 +100,56 @@ my @tests = ( ], [ "BODY.PEEK[] requests match BODY[] responses", - [ q{* 1 FETCH (BODY[] foo)} ], + [q{* 1 FETCH (BODY[] foo)}], [ [1], qw(BODY.PEEK[]) ], { "1" => { "BODY[]" => q{foo}, }, }, ], [ "BODY.PEEK[] requests match BODY.PEEK[] responses also", - [ q{* 1 FETCH (BODY.PEEK[] foo)} ], + [q{* 1 FETCH (BODY.PEEK[] foo)}], [ [1], qw(BODY.PEEK[]) ], { "1" => { "BODY.PEEK[]" => q{foo}, }, }, ], [ - "escaped subject", - [ q{* 1 FETCH (UID 1 X-SAVEDATE "28-Jan-2011 16:52:31 -0500" FLAGS (\Seen) ENVELOPE ("Fri, 28 Jan 2011 00:03:30 -0500" "foo \\"bar\\" baz\'s" (("Phil Pearl" NIL "phil" "dom.loc")) (("Phil Pearl" NIL "phil" "dom.loc")) (("Phil Pearl" NIL "phil" "dom.loc")) ((NIL NIL "phil" "dom.loc")) NIL NIL NIL "")) } ], + "escaped ENVELOPE subject", + [ +q{* 1 FETCH (UID 1 X-SAVEDATE "28-Jan-2011 16:52:31 -0500" FLAGS (\Seen) ENVELOPE ("Fri, 28 Jan 2011 00:03:30 -0500"}, + q{foo "bar\\" (baz\\)}, +q{ (("Phil Pearl" NIL "phil" "dom.loc")) (("Phil Pearl" NIL "phil" "dom.loc")) (("Phil Pearl" NIL "phil" "dom.loc")) ((NIL NIL "phil" "dom.loc")) NIL NIL NIL "")) } + ], [ [1], qw(UID X-SAVEDATE FLAGS ENVELOPE) ], { "1" => { 'X-SAVEDATE' => '28-Jan-2011 16:52:31 -0500', - 'UID' => '1', - 'FLAGS' => '\\Seen', - 'ENVELOPE' => q{"Fri, 28 Jan 2011 00:03:30 -0500" "foo \\"bar\\" baz\'s" (("Phil Pearl" NIL "phil" "dom.loc")) (("Phil Pearl" NIL "phil" "dom.loc")) (("Phil Pearl" NIL "phil" "dom.loc")) ((NIL NIL "phil" "dom.loc")) NIL NIL NIL ""} + 'UID' => '1', + 'FLAGS' => '\\Seen', + 'ENVELOPE' => +q{"Fri, 28 Jan 2011 00:03:30 -0500" "foo \\"bar\\\\\\" (baz\\\\)" (("Phil Pearl" NIL "phil" "dom.loc")) (("Phil Pearl" NIL "phil" "dom.loc")) (("Phil Pearl" NIL "phil" "dom.loc")) ((NIL NIL "phil" "dom.loc")) NIL NIL NIL ""} + }, + }, + ], + [ + "non-escaped BODY[HEADER.FIELDS (...)]", + [ +q{* 1 FETCH (UID 1 FLAGS () BODY[HEADER.FIELDS (TO FROM SUBJECT DATE)]}, + 'From: Phil Pearl (Lobbes) +To: phil+to@perkpartners.com +Subject: foo "bar\" (baz\) +Date: Sat, 22 Jan 2011 20:43:58 -0500 + +' + ], + [ [1], ( qw(FLAGS), 'BODY[HEADER.FIELDS (TO FROM SUBJECT DATE)]' ) ], + { + '1' => { + 'BODY[HEADER.FIELDS (TO FROM SUBJECT DATE)]' => + 'From: Phil Pearl (Lobbes) +To: phil+to@perkpartners.com +Subject: foo "bar\" (baz\) +Date: Sat, 22 Jan 2011 20:43:58 -0500 + +', + 'FLAGS' => '', }, }, ], @@ -225,6 +255,7 @@ sub fetch { my ( $self, @args ) = @_; return $self->{_next_fetch_response} || []; } + sub Escaped_results { my ( $self, @args ) = @_; return $self->{_next_fetch_response} || []; diff --git a/Mail-IMAPClient-3.27/t/messageset.t b/Mail-IMAPClient-3.28/t/messageset.t similarity index 100% rename from Mail-IMAPClient-3.27/t/messageset.t rename to Mail-IMAPClient-3.28/t/messageset.t diff --git a/Mail-IMAPClient-3.27/t/pod.t b/Mail-IMAPClient-3.28/t/pod.t similarity index 100% rename from Mail-IMAPClient-3.27/t/pod.t rename to Mail-IMAPClient-3.28/t/pod.t diff --git a/Mail-IMAPClient-3.27/t/simple.t b/Mail-IMAPClient-3.28/t/simple.t similarity index 100% rename from Mail-IMAPClient-3.27/t/simple.t rename to Mail-IMAPClient-3.28/t/simple.t diff --git a/Mail-IMAPClient-3.27/t/thread.t b/Mail-IMAPClient-3.28/t/thread.t similarity index 100% rename from Mail-IMAPClient-3.27/t/thread.t rename to Mail-IMAPClient-3.28/t/thread.t diff --git a/Mail-IMAPClient-3.27/test_template.txt b/Mail-IMAPClient-3.28/test_template.txt similarity index 100% rename from Mail-IMAPClient-3.27/test_template.txt rename to Mail-IMAPClient-3.28/test_template.txt diff --git a/Makefile b/Makefile index 494c6c5..61c8a80 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -# $Id: Makefile,v 1.60 2011/02/21 02:20:38 gilles Exp gilles $ +# $Id: Makefile,v 1.67 2011/04/20 01:20:06 gilles Exp gilles $ .PHONY: help usage all @@ -90,7 +90,7 @@ test_quick_229: imapsync tests.sh CMD_PERL='perl -I./Mail-IMAPClient-2.2.9' /usr/bin/time sh tests.sh locallocal 1>/dev/null test_quick_3xx: imapsync tests.sh - CMD_PERL='perl -I./Mail-IMAPClient-3.27/lib' /usr/bin/time sh tests.sh locallocal 1>/dev/null + CMD_PERL='perl -I./Mail-IMAPClient-3.28/lib' /usr/bin/time sh tests.sh locallocal 1>/dev/null testv: nice -40 sh -x tests.sh @@ -108,19 +108,13 @@ test229: .test_229 touch .test_229 .test_3xx: imapsync tests.sh - CMD_PERL='perl -I./Mail-IMAPClient-3.27/lib' /usr/bin/time sh tests.sh 1>/dev/null + CMD_PERL='perl -I./Mail-IMAPClient-3.28/lib' /usr/bin/time sh tests.sh 1>/dev/null touch .test_3xx testf: clean_test test .PHONY: lfo upload_lfo niouze_lfo niouze_fm public imapsync_cidone -upload_index: index.shtml - rcsdiff index.shtml - rsync -avH index.shtml \ - ../../public_html/www.linux-france.org/html/prj/imapsync/ - sh $(HOME)/memo/lfo-rsync - .dosify_bat: build_exe.bat test_exe.bat test.bat test2.bat unix2dos build_exe.bat test.bat test_exe.bat test2.bat touch .dosify_bat @@ -164,14 +158,14 @@ imapsync.exe: imapsync build_exe.bat test_exe.bat .dosify_bat imapsync_elf_x86.bin: imapsync rcsdiff imapsync { test 'vadrouille' = "`hostname`" && \ - pp -o imapsync_elf_x86.bin -I Mail-IMAPClient-3.27/lib \ + pp -o imapsync_elf_x86.bin -I Mail-IMAPClient-3.28/lib \ -M Mail::IMAPClient -M IO::Socket -M IO::Socket::SSL \ -M Digest::MD5 -M Digest::HMAC_MD5 -M Term::ReadKey \ -M Authen::NTLM \ imapsync ; \ } || : { test 'petite' = "`hostname`" && \ - pp -o imapsync_elf_x86.bin -I Mail-IMAPClient-3.27/lib \ + pp -o imapsync_elf_x86.bin -I Mail-IMAPClient-3.28/lib \ -M Mail::IMAPClient -M IO::Socket -M IO::Socket::SSL \ -M Digest::MD5 -M Digest::HMAC_MD5 -M Term::ReadKey \ -M Authen::NTLM \ @@ -180,7 +174,7 @@ imapsync_elf_x86.bin: imapsync imapsync ; \ } || : { test 'ks200821.kimsufi.com' = "`hostname`" && \ - pp -o imapsync_elf_x86.bin -I Mail-IMAPClient-3.27/lib \ + pp -o imapsync_elf_x86.bin -I Mail-IMAPClient-3.28/lib \ -M Mail::IMAPClient -M IO::Socket -M IO::Socket::SSL \ -M Digest::MD5 -M Digest::HMAC_MD5 -M Term::ReadKey \ -M Authen::NTLM \ @@ -195,7 +189,7 @@ lfo: cidone niouze_lfo upload_lfo dist: cidone test clean all INSTALL tarball -tarball: cidone all imapsync_elf_x86.bin imapsync.exe +tarball: cidone all imapsync.exe echo making tarball $(DIST_FILE) mkdir -p dist mkdir -p ../prepa_dist/$(DIST_NAME) @@ -208,24 +202,43 @@ tarball: cidone all imapsync_elf_x86.bin imapsync.exe ls -l ../prepa_dist/$(DIST_FILE) ks: - rsync -av . imapsync@ks.lamiral.info:public_html/imapsync + rsync -avz . imapsync@ks.lamiral.info:public_html/imapsync { cd /g/var/paypal_reply/ &&\ rsync -av url_exe url_release url_source imapsync@ks.lamiral.info:/g/var/paypal_reply/ \ ; } + +PUBLIC_FILES = ./ChangeLog ./COPYING ./CREDITS ./FAQ \ +./index.shtml ./INSTALL ./TIME \ +./logo_imapsync.png ./logo_imapsync_s.png \ +./paypal.shtml ./paypal_return.shtml ./paypal_return_support.shtml \ +./README ./style.css ./TODO ./VERSION ./VERSION_EXE + +upload_ks: + rsync -lptvHz $(PUBLIC_FILES) \ + root@ks.lamiral.info:/var/www/imapsync/ + rsync -lptvHz ./dist/index.shtml \ + root@ks.lamiral.info:/var/www/imapsync/dist/ + upload_lfo: #rm -rf /home/gilles/public_html/www.linux-france.org/html/prj/imapsync/ #rm -rf /home/gilles/public_html/www.linux-france.org/ftp/prj/imapsync/ - rsync -avH ./ChangeLog ./COPYING ./CREDITS ./FAQ \ - ./index.shtml ./INSTALL ./TIME \ - ./logo_imapsync.png ./logo_imapsync_s.png \ - ./paypal.shtml ./README ./style.css ./TODO ./VERSION ./VERSION_EXE \ + rsync -avH $(PUBLIC_FILES) \ /home/gilles/public_html/www.linux-france.org/html/prj/imapsync/ rsync -avH ./dist/index.shtml \ /home/gilles/public_html/www.linux-france.org/html/prj/imapsync/dist/ sh ~/memo/lfo-rsync -niouze_lfo : VERSION +upload_index: index.shtml + validate --verbose index.shtml + rcsdiff index.shtml + rsync -avH index.shtml \ + ../../public_html/www.linux-france.org/html/prj/imapsync/ + sh $(HOME)/memo/lfo-rsync + + + +niouze_lfo : echo "CORRECT ME: . ./memo && lfo_announce" niouze_fm: VERSION diff --git a/README b/README index 1242f65..e24a4e1 100644 --- a/README +++ b/README @@ -3,7 +3,7 @@ NAME Synchronise mailboxes between two imap servers. Good at IMAP migration. More than 36 different IMAP server softwares supported with success. - $Revision: 1.404 $ + $Revision: 1.411 $ SYNOPSIS To synchronise imap account "foo" on "imap.truc.org" to imap account @@ -270,13 +270,15 @@ BUG REPORT GUIDELINES - 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. - - virtual software context (vmware, xen etc.) - Most of those values can be found as a copy/paste at the begining of the output. @@ -287,12 +289,12 @@ BUG REPORT GUIDELINES IMAP SERVERS Failure stories reported with the following 3 imap servers: - - MailEnable 1.54 (Proprietary) http://www.mailenable.com/ - - DBMail 0.9, 2.0.7 (GPL). But DBMail 1.2.1 works. + - 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). - Success stories reported with the following 40 imap servers (software + Success stories reported with the following 41 imap servers (software names are in alphabetic order): - 1und1 H mimap1 84498 [host1] @@ -323,11 +325,13 @@ IMAP SERVERS - 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 + - IMail 7.15 (Ipswitch/Win2003), 8.12, 11.03 [host1] + - MailEnable 4.23 [host1] [host2] - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform) - Mercury 4.1 (Windows server 2000 platform) - Microsoft Exchange Server 5.5, 6.0.6249.0[host1], 6.0.6487.0[host1], @@ -413,9 +417,10 @@ SIMILAR SOFTWARES imapmigrate : http://sourceforge.net/projects/cyrus-utils/ wonko_imapsync: http://wonko.com/article/554 see also tools/wonko_ruby_imapsync + isync : http://isync.sourceforge.net/ pop2imap : http://www.linux-france.org/prj/pop2imap/ Feedback (good or bad) will often be welcome. - $Id: imapsync,v 1.404 2011/02/21 03:35:39 gilles Exp gilles $ + $Id: imapsync,v 1.411 2011/04/19 23:34:30 gilles Exp gilles $ diff --git a/TIME b/TIME index 72c75d7..833c036 100644 --- a/TIME +++ b/TIME @@ -1,3 +1,11 @@ + 40 Groupwize and authuser. Does not work. +540 Invoices build. + 35 Bug bug_zero_byte() tests.sh No bug found here. email. +200 Prepared change site to ks (apache2 logrotate etc.). + 63 "\Forwarded" flag bug in courier. DJ dj@blu... + 30 Debug "BAD Command Argument Error. 12" on imapsync mailing-list. +120 Building invoices. + 60 Added imapsync on adwords for 75 euros, 1 euro per day max. Free promotional offer from Google Adwords. 200 Added --useuid. 110 Started to allow copy by uid. Added --notakebody 60 Fixed cache, dealing with filenames containing \ characters. diff --git a/TODO b/TODO index 834d856..e1bf2ba 100644 --- a/TODO +++ b/TODO @@ -1,5 +1,5 @@ #!/bin/cat -# $Id: TODO,v 1.92 2011/01/18 02:38:48 gilles Exp gilles $ +# $Id: TODO,v 1.95 2011/04/16 20:16:47 gilles Exp gilles $ TODO file for imapsync ---------------------- @@ -25,6 +25,16 @@ Evaluate http://www.rackspace.com/apps/email_hosting/migrations http://www.yippiemove.com/ +Make --delete2 works with --useuid + +Fix "\Forwarded" flag bug in courier. +Does \lalala can be forbidden (courier does a +"16 NO Error in IMAP command received by server" +with +* OK [PERMANENTFLAGS (\* \Draft \Answered \Flagged \Deleted \Seen)] Limited + + + Suggestion: it's very difficult to track down messages which are behaving funny during the sync. It would be great - and presumably easy to code - to have an option to have imapsync display e.g. the subject of an @@ -148,6 +158,13 @@ http://asg.web.cmu.edu/cyrus/download/imapd/altnamespace.html =========================================================================== +DONE. Read http://bugs.gentoo.org/show_bug.cgi?id=354831 + Nice conversation. + +DONE. Look https://fedorahosted.org/released/imapsync/ + +DONE. Take a look at https://bitbucket.org/imapsync/imapsync + DONE. Explain expunge behavior in help message. DONE. Add --authmd51 --authmd52 to permit authmd5 by host. diff --git a/VERSION b/VERSION index c0d870c..f812671 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -1.404 +1.411 diff --git a/VERSION_EXE b/VERSION_EXE index 4449725..fa83683 100644 --- a/VERSION_EXE +++ b/VERSION_EXE @@ -1 +1 @@ -1.404 +1.411 diff --git a/adwords b/adwords new file mode 100644 index 0000000..b4503f3 --- /dev/null +++ b/adwords @@ -0,0 +1,6 @@ +IMAP migration tool +Buy imapsync.exe + source for 30 € +30 days money-back guarantee +linux-france.org/prj/imapsync/ +www.linux-france.org/prj/imapsync/ + diff --git a/i2 b/i2 index b78ed27..39074b5 100755 --- a/i2 +++ b/i2 @@ -1,4 +1,7 @@ #!/bin/sh -perl -IMail-IMAPClient-2.2.9 ./imapsync "$@" +# $Id: i2,v 1.2 2011/03/15 01:14:15 gilles Exp gilles $ + +BASE=`dirname $0` +perl -I${BASE}/Mail-IMAPClient-2.2.9 ${BASE}/imapsync "$@" diff --git a/i3 b/i3 index d60b776..1a9d84c 100755 --- a/i3 +++ b/i3 @@ -1,4 +1,7 @@ #!/bin/sh -perl -IMail-IMAPClient-3.27/lib ./imapsync "$@" +# $Id: i3,v 1.7 2011/03/15 01:15:48 gilles Exp gilles $ + +BASE=`dirname $0` +perl -I${BASE}/Mail-IMAPClient-3.28/lib ${BASE}/imapsync "$@" diff --git a/imapsync b/imapsync index 00682b8..c97dadb 100755 --- a/imapsync +++ b/imapsync @@ -15,12 +15,12 @@ =head1 NAME -imapsync - IMAP synchronisation, sync, copy or migration -tool. Synchronise mailboxes between two imap servers. Good -at IMAP migration. More than 36 different IMAP server softwares +imapsync - IMAP synchronisation, sync, copy or migration tool. +Synchronise mailboxes between two imap servers. +Good at IMAP migration. More than 36 different IMAP server softwares supported with success. -$Revision: 1.404 $ +$Revision: 1.411 $ =head1 SYNOPSIS @@ -317,13 +317,15 @@ Help us to help you: in your report, please include: - 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. - - virtual software context (vmware, xen etc.) - 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 @@ -335,12 +337,12 @@ and then forget it. Failure stories reported with the following 3 imap servers: - - MailEnable 1.54 (Proprietary) http://www.mailenable.com/ - - DBMail 0.9, 2.0.7 (GPL). But DBMail 1.2.1 works. + - 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). -Success stories reported with the following 40 imap servers +Success stories reported with the following 41 imap servers (software names are in alphabetic order): - 1und1 H mimap1 84498 [host1] @@ -371,11 +373,13 @@ Success stories reported with the following 40 imap servers - 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 + - IMail 7.15 (Ipswitch/Win2003), 8.12, 11.03 [host1] + - MailEnable 4.23 [host1] [host2] - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform) - Mercury 4.1 (Windows server 2000 platform) - Microsoft Exchange Server 5.5, 6.0.6249.0[host1], 6.0.6487.0[host1], @@ -486,12 +490,13 @@ Entries for imapsync: imapmigrate : http://sourceforge.net/projects/cyrus-utils/ wonko_imapsync: http://wonko.com/article/554 see also tools/wonko_ruby_imapsync + isync : http://isync.sourceforge.net/ pop2imap : http://www.linux-france.org/prj/pop2imap/ Feedback (good or bad) will often be welcome. -$Id: imapsync,v 1.404 2011/02/21 03:35:39 gilles Exp gilles $ +$Id: imapsync,v 1.411 2011/04/19 23:34:30 gilles Exp gilles $ =cut @@ -599,7 +604,7 @@ my( # global variables initialisation -$rcs = '$Id: imapsync,v 1.404 2011/02/21 03:35:39 gilles Exp gilles $ '; +$rcs = '$Id: imapsync,v 1.411 2011/04/19 23:34:30 gilles Exp gilles $ '; $total_bytes_transferred = 0; $total_bytes_skipped = 0; @@ -644,7 +649,7 @@ $allow3xx = defined($allow3xx) ? $allow3xx : 1; $takebody = defined($takebody) ? $takebody : 1; if ( $fast ) { - $useuid = 1 ; + # $useuid = 1 ; $foldersizes = 0 ; } @@ -833,7 +838,8 @@ $split2 and $imap2->Split($split2); my ( @h1_folders_all, %h1_folders_all, @h1_folders_wanted, %requested_folder, %subscribed_folder, -@h2_folders_all, %h2_folders_all, @h2_folders_from_1, %h2_folders_from_1, +@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, ); @@ -929,14 +935,22 @@ 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{$h2_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); -@h2_folders_from_1 = sort keys(%h2_folders_from_1); if ($foldersizes) { - foldersizes("Host1", $imap1, @h1_folders_wanted); - foldersizes("Host2", $imap2, @h2_folders_from_1); + foldersizes( "Host1", $imap1, @h1_folders_wanted ) ; + foldersizes( "Host2", $imap2, @h2_folders_from_1_wanted ) ; + sleep( 2 ) ; } @@ -983,7 +997,7 @@ FOLDER: foreach my $h1_fold (@h1_folders_wanted) { #print "%%% @select_results\n"; my $permanentflags2 = permanentflags(@select_results); - + $debug and print "permanentflags: $permanentflags2\n" ; if ($expunge){ print "Expunging host1 $h1_fold\n"; unless($dry) { $imap1->expunge() }; @@ -1018,9 +1032,6 @@ FOLDER: foreach my $h1_fold (@h1_folders_wanted) { 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"; - #print "CACHE h2 h1: ", scalar( keys %$cache_2_1_ref ), " files\n" ; - #$debug and print '[', - # map ( { "$_->$cache_2_1_ref->{$_} " } keys %$cache_2_1_ref ), " ]\n"; } #sleep 4 ; @@ -1043,11 +1054,16 @@ FOLDER: foreach my $h1_fold (@h1_folders_wanted) { my @h1_msgs_no_cache = keys %h1_msgs_no_cache ; my @h2_msgs_no_cache = keys %h2_msgs_no_cache ; + my @h2_msgs_delete2_no_cache = () ; if ( $useuid ) { + # use uid so we have to avoid getting header @h1_msgs_copy_by_uid{ @h1_msgs_no_cache } = ( ) ; + @h2_msgs_delete2_no_cache = @h2_msgs_no_cache if $usecache ; @h1_msgs_no_cache = ( ) ; @h2_msgs_no_cache = ( ) ; + + #print "delete2: @h2_msgs_delete2_no_cache\n"; } $debug and print "Host1 folder [$h1_fold] parsing headers\n"; @@ -1136,7 +1152,7 @@ FOLDER: foreach my $h1_fold (@h1_folders_wanted) { 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 deleted on host2 [$m_id]\n" + 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) { @@ -1146,14 +1162,20 @@ FOLDER: foreach my $h1_fold (@h1_folders_wanted) { } } foreach my $h2_msg (@h2_msgs_duplicate) { - print "msg $h2_fold/$h2_msg deleted [duplicate] on host2\n"; + 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_no_cache ) { + print "msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2\n"; + unless ($dry) { + $imap2->delete_message($h2_msg); + $h2_nb_msg_deleted += 1; + } + } my $cnt = scalar @h2_expunge; if(@h2_expunge and !$imap2->can("uidexpunge")) { warn "uidexpunge not supported (< IMAPClient 3.17)\n"; @@ -1273,7 +1295,7 @@ sub sync_flags { # we need most of the time. if ( ! $dry and $diff and ! $imap2->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) { - warn "- msg $h2_fold/$h2_msg could not add flags @h1_flags", + warn "- msg $h2_fold/$h2_msg could not add flags [@h1_flags]: ", $imap2->LastError, "\n"; #$nb_errors++; } @@ -1632,8 +1654,8 @@ sub banner_imapsync { my @argv_copy = @_; my $banner_imapsync = join("", '$RCSfile: imapsync,v $ ', - '$Revision: 1.404 $ ', - '$Date: 2011/02/21 03:35:39 $ ', + '$Revision: 1.411 $ ', + '$Date: 2011/04/19 23:34:30 $ ', "\n",localhost_info(), "\n", "Command line used:\n", "$0 ", command_line_nopassword(@argv_copy), "\n", @@ -2227,7 +2249,7 @@ sub permanentflags { foreach my $line (@lines) { if ($line =~ m{\[PERMANENTFLAGS \(([^)]+?)\)\]}) { - #print "%%%$1%%%\n"; + $debug and print "permanentflags: $line"; my $permanentflags = $1; if ($permanentflags =~ m{\\\*}) { $permanentflags = ''; @@ -2534,6 +2556,7 @@ sub get_cache { return ( $cache_1_2_ref, $cache_2_1_ref ) ; } + sub tests_get_cache { ok( ! get_cache('/cache_no_exist'), 'get_cache: /cache_no_exist' ); @@ -2989,6 +3012,7 @@ sub get_options { "timeout=i" => \$timeout, "skipheader=s" => \$skipheader, "useheader=s" => \@useheader, + "takebody!" => \$takebody, "skipsize!" => \$skipsize, "allowsizemismatch!" => \$allowsizemismatch, "fastio1!" => \$fastio1, @@ -3198,7 +3222,7 @@ sub check_last_release { } sub imapsync_version { - my $rcs = '$Id: imapsync,v 1.404 2011/02/21 03:35:39 gilles Exp gilles $ '; + my $rcs = '$Id: imapsync,v 1.411 2011/04/19 23:34:30 gilles Exp gilles $ '; $rcs =~ m/,v (\d+\.\d+)/; my $VERSION = ($1) ? $1: "UNKNOWN"; return($VERSION); @@ -3455,7 +3479,7 @@ Several options are mandatory. --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 --useuid --nofoldersizes +--fast : be faster, equivalent to --nofoldersizes --reconnectretry1 : reconnect to host1 if connection is lost up to times per imap command (default is 3) --reconnectretry2 : same as --reconnectretry1 but for host2 @@ -3674,7 +3698,7 @@ 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, \%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 ); } diff --git a/imapsync-1.366 b/imapsync-1.366 new file mode 100755 index 0000000..7ae5354 --- /dev/null +++ b/imapsync-1.366 @@ -0,0 +1,4310 @@ +#!/usr/bin/perl + +# 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 36 different IMAP server softwares +supported with success. + +$Revision: 1.366 $ + +=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 is already available directly on the following distributions +(at least): +FreeBSD, Debian, Ubuntu, Gentoo, Fedora, +NetBSD, Darwin, Mandriva and OpenBSD (yeah!). + + Get imapsync at + http://www.linux-france.org/prj/imapsync/ + + You'll find 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://www.linux-france.org/prj/imapsync/INSTALL + + The freshmeat record is at http://freshmeat.net/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 ] + [--user1 ] [--passfile1 ] + [--host2 server2] [--port2 ] + [--user2 ] [--passfile2 ] + [--ssl1] [--ssl2] + [--tls1] [--tls2] + [--authmech1 ] [--authmech2 ] + [--noauthmd5] + [--folder --folder ...] + [--folderrec --folderrec ...] + [--include ] [--exclude ] + [--prefix2 ] [--prefix1 ] + [--regextrans2 --regextrans2 ...] + [--sep1 ] + [--sep2 ] + [--justfolders] [--justfoldersizes] [--justconnect] [--justbanner] + [--syncinternaldates] + [--idatefromheader] + [--buffersize ] + [--syncacls] + [--regexmess ] [--regexmess ] + [--maxsize ] + [--minsize ] + [--maxage ] + [--minage ] + [--skipheader ] + [--useheader ] [--useheader ] + [--skipsize] [--allowsizemismatch] + [--delete] [--delete2] + [--expunge] [--expunge1] [--expunge2] [--uidexpunge2] + [--subscribed] [--subscribe] [--subscribe_all] + [--nofoldersizes] + [--dry] + [--debug] [--debugimap][--debugimap1][--debugimap2] + [--timeout ] [--fast] + [--split1] [--split2] + [--reconnectretry1 ] [--reconnectretry2 ] + [--pidfile ] + [--tmpdir ] + [--version] [--help] + +=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. imapsync is CPU hungry so nice and renice +commands can be a good help. imapsync can be memory hungry too, +especially with large messages. + +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 --expunge1 options. + +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) + +=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. + + +=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, gratis and open source 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: + + +To subscribe, send any message (even empty) to: + +then just reply to the confirmation message. + +To unsubscribe, send a message to: + + +To contact the person in charge for the list: + + +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 + +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 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://www.linux-france.org/prj/imapsync/ + +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(tm) and you haven't read the 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. + + - operating system running imapsync. + + - operating systems on both sides and the third side in case + you run imapsync on a foreign host from the both. + + - virtual software context (vmware, xen etc.) + +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 4 imap servers: + + - MailEnable 1.54 (Proprietary) http://www.mailenable.com/ + - DBMail 0.9, 2.0.7 (GPL). But DBMail 1.2.1 works. + Patient and confident testers are welcome. + - dkimap4 2.39 + - Imail 7.04 (maybe). + +Success stories reported with the following 36 imap servers +(software names are in alphabetic order): + + - 1und1 H mimap1 84498 [host1] + - Archiveopteryx 2.03, 2.04, 2.09, 2.10 [host2], 3.0.0 [host2] + (OSL 3.0) http://www.archiveopteryx.org/ + - 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] + - Domino (Notes) 4.61[host1], 6.5, 5.0.6, 5.0.7, 7.0.2, 6.0.2CF1, 7.0.1[host1], 8.0.1[host1] + - 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 + - GMX IMAP4 StreamProxy. + - Groupwise IMAP (Novell) 6.x and 7.0. Buggy so see the FAQ. + - iPlanet Messaging server 4.15, 5.1, 5.2 + - IMail 7.15 (Ipswitch/Win2003), 8.12 + - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform) + - 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], Exchange 2007 SP1 (with Update Rollup 2), + Exchange2007-EP-SP2, + Exchange 2010 RTM (Release to Manufacturing) [host2] + - Netscape Mail Server 3.6 (Wintel !) + - Netscape Messaging Server 4.15 Patch 7 + - OpenMail IMAP server B.07.00.k0 (Samsung Contact ?) + - OpenWave + - 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. + - 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 + - Sun Messaging Server 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 + - Imap part of TCP/IP suite of VMS 7.3.2 + - Zimbra-IMAP 3.0.1 GA 160, 3.1.0 Build 279, 4.0.5, 4.5.2, 4.5.6, 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 + +Please rate imapsync at http://freshmeat.net/projects/imapsync/ +or better give the author a book, he likes books: +http://www.amazon.com/gp/registry/wishlist/1C9UNDIH3P7R7/ +(or its paypal account gilles.lamiral@laposte.net) + +=head1 HUGE MIGRATION + +Pay special attention to options +--subscribed +--subscribe +--delete +--delete2 +--expunge +--expunge1 +--expunge2 +--uidexpunge2 +--maxage +--minage +--maxsize +--useheader +--fast + +If you have many mailboxes to migrate think about a little +shell program. Write a file called file.csv (for example) +containing users and passwords. +The separator used in this example is ';' + +The file.csv file contains: + +user0001;password0001;user0002;password0002 +user0011;password0011;user0012;password0012 +... + +And the shell program is just: + + { while IFS=';' read u1 p1 u2 p2; do + imapsync --user1 "$u1" --password1 "$p1" --user2 "$u2" --password2 "$p2" ... + done ; } < file.csv + +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 : http://software.complete.org/offlineimap + mailsync : http://mailsync.sourceforge.net/ + imapxfer : http://www.washington.edu/imap/ + part of the imap-utils from UW. + mailutil : replace imapxfer in + part of the imap-utils from UW. + http://www.gsp.com/cgi-bin/man.cgi?topic=mailutil + imaprepl : http://www.bl0rg.net/software/ + http://freshmeat.net/projects/imap-repl/ + imap_migrate : http://freshmeat.net/projects/imapmigration/ + 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 tools/wonko_ruby_imapsync + pop2imap : http://www.linux-france.org/prj/pop2imap/ + + +Feedback (good or bad) will often be welcome. + +$Id: imapsync,v 1.366 2010/10/25 17:15:52 gilles Exp $ + +=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 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, $nb_errors, + $host1, $host2, $port1, $port2, + $user1, $user2, $password1, $password2, $passfile1, $passfile2, + @folder, @include, @exclude, @folderrec, + $prefix1, $prefix2, + @regextrans2, @regexmess, @regexflag, + $sep1, $sep2, + $syncinternaldates, + $idatefromheader, + $usedatemanip, + $syncacls, + $fastio1, $fastio2, + $maxsize, $minsize, $maxage, $minage, + $skipheader, @useheader, + $skipsize, $allowsizemismatch, $foldersizes, $buffersize, + $delete, $delete2, + $expunge, $expunge1, $expunge2, $uidexpunge2, $dry, + $justfoldersizes, + $authmd5, + $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, + $authuser1, $authuser2, + $authmech1, $authmech2, + $split1, $split2, + $reconnectretry1, $reconnectretry2, + $tests, $test_builder, $tests_debug, + $allow3xx, $justlogin, + $tmpdir, + $releasecheck, + $max_msg_size_in_bytes, + $modules_version, + $delete2folders, +); + +# main program + +# global variables initialisation + +$rcs = '$Id: imapsync,v 1.366 2010/10/25 17:15:52 gilles Exp $ '; + +$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; + +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; + +$releasecheck = defined($releasecheck) ? $releasecheck : 1; +my $warn_release = ($releasecheck) ? check_last_release() : ''; + +# default values + +$tmpdir ||= File::Spec->tmpdir(); +$pidfile ||= $tmpdir . '/imapsync.pid'; + +# allow Mail::IMAPClient 3.0.xx by default +$allow3xx = defined($allow3xx) ? $allow3xx : 1; + +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.0.25 or superior \n"; + +exit_clean(0) if ($justbanner); + +# By default, 1000 at a time, not more. +$split1 ||= 1000; +$split2 ||= 1000; + +$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); + +# By default, don't take size to compare +$skipsize = (defined $skipsize) ? $skipsize : 1; + + +if ($justconnect) { + justconnect(); + exit_clean(0); +} + +$user1 || missing_option("--user1"); +$user2 || missing_option("--user2"); + +$syncinternaldates = defined($syncinternaldates) ? $syncinternaldates : 1; + +if($idatefromheader) { + print "Turned ON idatefromheader, ", + "will set the internal dates on host2 from the 'Date:' header line.\n"; + $syncinternaldates = 0; + +} +if ($syncinternaldates) { + print "Turned ON syncinternaldates, ", + "will set the internal dates (arrival dates) on host2 same as host1.\n"; +}else{ + print "Turned OFF syncinternaldates\n"; +} + + +if(defined($authmd5) and not($authmd5)) { + $authmech1 ||= 'LOGIN'; + $authmech2 ||= 'LOGIN'; +} +else{ + $authmech1 ||= $authuser1 ? 'PLAIN' : 'CRAM-MD5'; + $authmech2 ||= $authuser2 ? 'PLAIN' : 'CRAM-MD5'; +} + +$authmech1 = uc($authmech1); +$authmech2 = uc($authmech2); + +$authuser1 ||= $user1; +$authuser2 ||= $user2; + +print "Will try to use $authmech1 authentication on host1\n"; +print "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 = ("ALL") unless (@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; + +my $imap1 = (); +my $imap2 = (); + +$timestart = time(); +$timebefore = $timestart; + +$debugimap1 and print "Host1 connection\n"; +$imap1 = login_imap($host1, $port1, $user1, $password1, + $debugimap1, $timeout, $fastio1, $ssl1, $tls1, + $authmech1, $authuser1, $reconnectretry1); + +$debugimap2 and print "Host2 connection\n"; +$imap2 = login_imap($host2, $port2, $user2, $password2, + $debugimap2, $timeout, $fastio2, $ssl2, $tls2, + $authmech2, $authuser2, $reconnectretry2); + +# history + +$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); + +$split1 and $imap1->Split($split1); +$split2 and $imap2->Split($split2); + +# +# Folder stuff +# + +my ( +@h1_folders_all, %h1_folders_all, @h1_folders_wanted, %requested_folder, %subscribed_folder, +@h2_folders_all, %h2_folders_all, @h2_folders_from_1, %h2_folders_from_1, +); + + +# Make a hash of subscribed folders in source server. +map { $subscribed_folder{$_} = 1 } $imap1->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 (%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_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_namespace = $imap1->namespace(); +#my $h2_namespace = $imap2->namespace(); +#$debug and print "Host1 namespace:\n", Data::Dumper->Dump([$h1_namespace]); +#$debug and print "Host2 namespace:\n", Data::Dumper->Dump([$h2_namespace]); + +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{$h2_fold}++; +} + +@h2_folders_from_1 = sort keys(%h2_folders_from_1); + +if ($foldersizes) { + foldersizes("Host1", $imap1, @h1_folders_wanted); + foldersizes("Host2", $imap2, @h2_folders_from_1); +} + + +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(%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) { + + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + + my $h2_fold = imap2_folder_name($h1_fold); + + printf("%-35s -> %-35s\n", "[$h1_fold]", "[$h2_fold]"); + unless ($imap1->select($h1_fold)) { + warn + "Host1 folder $h1_fold: Could not select: ", + $imap1->LastError, "\n"; + $nb_errors++; + next FOLDER; + } + + if ( ! exists($h2_folders_all{$h2_fold})) { + print "Host2 folder $h2_fold does not exist\n"; + print "Creating folder [$h2_fold]\n"; + unless ($dry){ + unless ($imap2->create($h2_fold)){ + warn "Couldn't create [$h2_fold]: ", + $imap2->LastError,"\n"; + $nb_errors++; + next FOLDER; + } + } + else{ + next FOLDER; + } + } + + acls_sync($h1_fold, $h2_fold); + + unless ($imap2->select($h2_fold)) { + warn + "Host2 folder $h2_fold: Could not select: ", + $imap2->LastError, "\n"; + $nb_errors++; + next FOLDER; + } + my @select_results = $imap2->Results(); + + #print "%%% @select_results\n"; + my $permanentflags2 = permanentflags(@select_results); + + if ($expunge){ + print "Expunging host1 $h1_fold\n"; + unless($dry) { $imap1->expunge() }; + #print "Expunging host2 $h2_fold\n"; + #unless($dry) { $imap2->expunge() }; + } + + if (($subscribe and exists $subscribed_folder{$h1_fold}) or $subscribe_all) { + print "Subscribing to folder $h2_fold on destination server\n"; + unless($dry) { $imap2->subscribe($h2_fold) }; + } + + next FOLDER if ($justfolders); + + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + + my @h1_msgs = select_msgs($imap1); + + $debug and print "LIST Host1: ", scalar(@h1_msgs), " messages [@h1_msgs]\n"; + # internal dates on host2 are after the ones on host1 + # normally... + my @h2_msgs = select_msgs($imap2); + + $debug and print "LIST Host2: ", scalar(@h2_msgs), " messages [@h2_msgs]\n"; + + my %h1_hash = (); + my %h2_hash = (); + + $debug and print "Host1 folder [$h1_fold] parsing headers\n"; + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + + my ($h1_heads_ref, $h1_fir_ref) = ({}, {}); + $h1_heads_ref = $imap1->parse_headers([@h1_msgs], @useheader) if (@h1_msgs); + $debug and print "Time headers: ", timenext(), " s\n"; + last FOLDER if $imap1->IsUnconnected(); + + @$h1_fir_ref{@h1_msgs} = (undef); + $h1_fir_ref = $imap1->fetch_hash_2("FLAGS", "INTERNALDATE", "RFC822.SIZE", $h1_fir_ref) + if (@h1_msgs); + $debug and print "Time fir: ", timenext(), " s\n"; + unless ($h1_fir_ref) { + warn + "Host1 folder $h1_fold: Could not fetch_hash_2 ", + scalar(@h1_msgs), " msgs: ", $imap1->LastError, "\n"; + $nb_errors++; + next FOLDER; + } + last FOLDER if $imap1->IsUnconnected(); + + + my @h1_msgs_duplicate; + foreach my $m (@h1_msgs) { + my $rc = parse_header_msg($imap1, $m, $h1_heads_ref, $h1_fir_ref, "F", \%h1_hash); + if (! defined($rc)) { + my $h1_size = $h1_fir_ref->{$m}->{"RFC822.SIZE"} || 0; + print "+ Skipping msg #$m:$h1_size on host1 folder $h1_fold (no header 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; + } + } + $debug and print "Time parsing headers on host1: ", timenext(), " s\n"; + + $debug and print "Host2 folder [$h2_fold] parsing headers\n"; + + my ($h2_heads_ref, $h2_fir_ref) = ({}, {}); + $h2_heads_ref = $imap2->parse_headers([@h2_msgs], @useheader) if (@h2_msgs); + $debug and print "Time headers: ", timenext(), " s\n"; + last FOLDER if $imap2->IsUnconnected(); + + @$h2_fir_ref{@h2_msgs} = (undef); # fetch_hash_2 can select by uid with last arg as ref + $h2_fir_ref = $imap2->fetch_hash_2("FLAGS", "INTERNALDATE", "RFC822.SIZE", $h2_fir_ref) + if (@h2_msgs); + $debug and print "Time fir: ", timenext(), " s\n"; + last FOLDER if $imap2->IsUnconnected(); + + my @h2_msgs_duplicate; + foreach my $m (@h2_msgs) { + my $rc = parse_header_msg($imap2, $m, $h2_heads_ref, $h2_fir_ref, "T", \%h2_hash); + if (! defined($rc)) { + my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; + print "+ Skipping msg #$m:$h2_size in host2 folder $h2_fold (no header so we ignore this message)\n"; + $h2_nb_msg_noheader += 1 ; + } elsif(0 == $rc) { + # duplicate + my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; + $h2_nb_msg_duplicate += 1; + $h2_total_bytes_duplicate += $h2_size; + push(@h2_msgs_duplicate, $m); + } + } + $debug and print "Time parsing headers on host2: ", 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($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 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 deleted [duplicate] 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 and !$imap2->can("uidexpunge")) { + warn "uidexpunge not supported (< IMAPClient 3.17)\n"; + } + elsif(@h2_expunge) { + print "uidexpunge $cnt message(s)\n"; + $imap2->uidexpunge(\@h2_expunge) if !$dry; + } + } + + 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'}; + + if (defined $maxsize and $h1_size >= $maxsize) { + print "msg $h1_fold/$h1_msg skipping ($h1_size exceeds maxsize limit $maxsize bytes)\n"; + $total_bytes_skipped += $h1_size; + $nb_msg_skipped += 1; + next MESS; + } + if (defined $minsize and $h1_size <= $minsize) { + print "msg $h1_fold/$h1_msg skipping ($h1_size smaller than minsize $minsize bytes)\n"; + $total_bytes_skipped += $h1_size; + $nb_msg_skipped += 1; + next MESS; + } + + unless (exists($h2_hash{$m_id})) { + # copy + $debug and print "msg $h1_fold/$h1_msg copying to $h2_fold\n"; + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + my $string; + #print "Message_string Beg\n", memory_consumption(); + $string = $imap1->message_string($h1_msg); + #print "Message_string End\n", memory_consumption(); + unless (defined($string)) { + warn + "- msg $h1_fold/$h1_msg could not fetch [$m_id $h1_size]: ", + $imap1->LastError, "\n"; + $nb_errors++; + $total_bytes_error += $h1_size; + next MESS; + } + + #my $message_file = "tmp_imapsync_$$"; + #$imap1->select($h1_fold); + #unlink($message_file); + #$imap1->message_to_file($message_file, $h1_msg) or do { + # warn "Could not put message #$h1_msg to file $message_file", + # $imap1->LastError; + # $nb_errors++; + # $total_bytes_error += $h1_size; + # next MESS; + #}; + #$string = file_to_string($message_file); + #print "AAA1[$string]ZZZ\n"; + #unlink($message_file); + if (@regexmess) { + $string = regexmess($string); + + #string_to_file($string, $message_file); + } + + + $debug 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"; + } + + my $h1_flags = $h1_hash{$m_id}{'F'} || ""; + # 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 = 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"; + last FOLDER if $imap1->IsUnconnected(); + last FOLDER if $imap2->IsUnconnected(); + $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'; + warn "- msg $h1_fold/$h1_msg couldn't append (Subject:[". + $imap1->subject($h1_msg)."]) to folder $h2_fold: ", + $imap2->LastError, "\n"; + $nb_errors++; + $total_bytes_error += $h1_size; + next MESS; + } + else{ + # good + # $new_id is an id if the IMAP server has the + # UIDPLUS capability else just a ref + print "msg $h1_fold/$h1_msg copied to $h2_fold/$new_id\n"; + $total_bytes_transferred += $h1_size; + $nb_msg_transferred += 1; + if($delete) { + print "msg $h1_fold/$h1_msg deleted on host1\n"; + unless($dry) { + $imap1->delete_message($h1_msg); + $h1_nb_msg_deleted += 1; + last FOLDER if $imap1->IsUnconnected(); + $imap1->expunge() if ($expunge); + last FOLDER if $imap1->IsUnconnected(); + } + } + } + } + else{ + $nb_msg_skipped_dry_mode += 1; + } + #unlink($message_file); + next MESS; + } + else{ + #my $h2_size = $h2_hash{$m_id}{'s'}; + my $h2_msg = $h2_hash{$m_id}{'m'}; + #my $h2_idate = $h2_hash{$m_id}{'D'}; + $debug and print "msg $h1_fold/$h1_msg equals $h2_fold/$h2_msg\n"; + $total_bytes_skipped += $h1_size; + $nb_msg_skipped += 1; + } + + $fast and next MESS; + #$debug and print "MESSAGE $m_id\n"; + my $h2_size = $h2_hash{$m_id}{'s'}; + my $h2_msg = $h2_hash{$m_id}{'m'}; + + # used cached flag values for efficiency + my $h1_flags = $h1_hash{$m_id}{'F'} || ""; + my $h2_flags = $h2_hash{$m_id}{'F'} || ""; + + # 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 = flags_filter($h1_flags, $permanentflags2) if ($permanentflags2); + + + # 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 and $debug and print "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)") ) { + warn "- msg $h2_fold/$h2_msg could not add flags @h1_flags", + $imap2->LastError, "\n"; + #$nb_errors++; + } + last FOLDER if $imap2->IsUnconnected(); + + $debug and do { + my @h2_flags = @{ $imap2->flags($h2_msg) || [] }; + last FOLDER if $imap2->IsUnconnected(); + + print "host1 flags: $h1_flags\n", + "host2 flags: @h2_flags\n"; + + print "Looking dates\n"; + #my $h1_idate = $imap1->internaldate($h1_msg); + #my $h2_idate = $imap2->internaldate($h2_msg); + my $h1_idate = $h1_hash{$m_id}{'D'}; + my $h2_idate = $h2_hash{$m_id}{'D'}; + print + "host1 internal date: $h1_idate\n", + "host2 internal date: $h2_idate\n"; + + #unless ($h1_idate eq $h2_idate) { + # print "!!! Dates differs !!!\n"; + #} + }; + unless ($skipsize or ($h1_size == $h2_size)) { + # Bad size + print + "- msg $h1_fold/$h1_msg size diff $h1_size != $h2_size $h2_fold/$h2_msg\n"; + $nb_errors++; + } + else { + # Good + $debug and print + "msg $h1_fold/$h1_msg sizes ok $h1_size <=> $h2_size $h2_fold/$h2_msg\n"; + 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); + } + } + } + } + if ($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"; +} + +print "++++ End looping on each folder\n"; +#print memory_consumption(); + +my $memory_consumption = memory_consumption(); +my $memory_ratio = ($max_msg_size_in_bytes) ? + sprintf('%.1f', $memory_consumption / $max_msg_size_in_bytes) : "NA"; + + +$imap1->logout(); +$imap2->logout(); + +my $host1_reconnect_count = $imap1->Reconnect_counter() || 0; +my $host2_reconnect_count = $imap2->Reconnect_counter() || 0; + + +$timeend = time(); +$timediff = $timeend - $timestart; + +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 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::SSL +Digest::MD5 +Digest::HMAC_MD5 +Term::ReadKey)) + { + 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 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 ($self->Tls) { + starttls($self); + } + + $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 login_imap { + my($host, $port, $user, $password, + $debugimap, $timeout, $fastio, + $ssl, $tls, $authmech, $authuser, $reconnectretry) = @_; + 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(1); + $imap->Peek(1); + $imap->Debug($debugimap); + $timeout and $imap->Timeout($timeout); + + $imap->Reconnectretry($reconnectretry) if ($reconnectretry); + + #$imap->connect() + myconnect($imap) + or die_clean("Can not open imap connection on [$host] with user [$user]: $@\n"); + + print "Banner: ", server_banner($imap); + + if ($imap->has_capability("AUTH=$authmech") + or $imap->has_capability($authmech) + ) { + printf("Host %s says it has CAPABILITY for AUTHENTICATE %s\n", + $imap->Server, $authmech); + } + else { + printf("Host %s says it has NO CAPABILITY for AUTHENTICATE %s\n", + $imap->Server, $authmech); + if ($authmech eq 'PLAIN') { + print "Frequently PLAIN is only supported with SSL, ", + "try --ssl1 or --ssl2 option\n"; + } + } + + $imap->Authmechanism($authmech) unless ($authmech eq 'LOGIN'); + $imap->Authcallback(\&plainauth) if $authmech eq "PLAIN"; + + + $imap->User($user); + $imap->Authuser($authuser); + $imap->Password($password); + unless ($imap->login()) { + my $info = "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 "Trying LOGIN Auth mechanism on [$host] with user [$user]\n"; + $imap->Authmechanism(""); + $imap->login() or + die_clean("$info [LOGIN]: ", $imap->LastError, "\n"); + } + print "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.366 $ ', + '$Date: 2010/10/25 17:15:52 $ ', + "\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) { + warn "$pidfile already exists, overwriting it\n"; + } + open(PIDFILE, ">$pidfile") or do { + warn "Could not open $pidfile for writing"; + return undef; + }; + + print PIDFILE $PROCESS_ID; + close PIDFILE; + return($PROCESS_ID); +} + +sub exit_clean { + my $status = shift; + + 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 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", + "Give the prefix namespace with the $prefix_opt option\n"; + exit_clean(1); + } +} + + +sub get_separator { + my($imap, $sep_in, $sep_opt) = @_; + my($sep_out); + + + if ($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; + warn + "NAMESPACE request failed for ", + $imap->Server(), ": ", $imap->LastError, "\n"; + exit_clean(1); + } + else{ + warn + "No NAMESPACE capability in imap server ", + $imap->Server(),"\n", + "Give the separator character with the $sep_opt option\n"; + exit_clean(1); + } +} + +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 $tot = 0; + my $tmess = 0; + + print "++++ Calculating sizes\n"; + foreach my $folder (@folders) { + my $stot = 0; + my $smess = 0; + printf("$side folder %-35s", "[$folder]"); + unless($imap->exists($folder)) { + print("does not exist yet\n"); + next; + } + unless ($imap->examine($folder)) { + warn + "$side Folder $folder: Could not examine: ", + $imap->LastError, "\n"; + $nb_errors++; + next; + } + + my $hash_ref = {}; + my @msgs = select_msgs($imap); + $smess = scalar(@msgs); + @$hash_ref{@msgs} = (undef); + unless ($smess == 0) { + $imap->fetch_hash_2("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; + } + + printf(" Size: %9s", $stot); + printf(" Messages: %5s\n", $smess); + $tot += $stot; + $tmess += $smess; + } + print "Total size: $tot\n"; + print "Total messages: $tmess\n"; + print "Time: ", timenext(), " s\n"; +} + +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; + $debug and print "eval \$h1_flags =~ $regexflag\n"; + eval("\$h1_flags =~ $regexflag"); + die_clean("error: eval regexflag '$regexflag': $@\n") if $@; + $debug 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 warn "Could not getacl for $h1_fold: $@\n"; + my $h2_hash = $imap2->getacl($h2_fold) + or warn "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 warn "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 \(([^)]+?)\)\]}) { + #print "%%%$1%%%\n"; + 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 select_msgs { + my ($imap) = @_; + my (@msgs,@max,@min,@union,@inter); + + unless (defined($maxage) or defined($minage)) { + @msgs = $imap->search("ALL"); + return(@msgs); + } + if (defined($maxage)) { + @max = $imap->sentsince(time - 86400 * $maxage); + } + if (defined($minage)) { + @min = $imap->sentbefore(time - 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 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:' + eq regexmess('From '), + 'From mbox 2 add colo'); + + ok( "\n" . 'From ' + eq regexmess("\n" . 'From '), + 'From mbox 3 add colo'); + + ok( "From: zzz\n" . 'From ' + eq regexmess("From zzz\n" . 'From '), + 'From mbox 4 add colo'); + + @regexmess = 's{\AFrom\ [^\n]*(\n)?}{}gxms'; + ok( '' + eq regexmess(''), + 'From mbox 1 remove, blank'); + + ok( '' + eq regexmess('From '), + 'From mbox 2 remove'); + + ok( "\n" . 'From ' + eq regexmess("\n" . 'From '), + 'From mbox 3 remove'); + + #print "[", regexmess("From zzz\n" . 'From '), "]"; + ok( "" . 'From ' + eq regexmess("From zzz\n" . 'From '), + 'From mbox 4 remove'); + + + ok( +'Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye.' + eq regexmess( +'From zzz +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +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 { + print "++++ Statistics\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 "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(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://www.linux-france.org/prj/imapsync/\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, + "debugimap!" => \$debugimap, + "debugimap1!" => \$debugimap1, + "debugimap2!" => \$debugimap2, + "host1=s" => \$host1, + "host2=s" => \$host2, + "port1=i" => \$port1, + "port2=i" => \$port2, + "user1=s" => \$user1, + "user2=s" => \$user2, + "password1=s" => \$password1, + "password2=s" => \$password2, + "passfile1=s" => \$passfile1, + "passfile2=s" => \$passfile2, + "authmd5!" => \$authmd5, + "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, + "delete!" => \$delete, + "delete2!" => \$delete2, + "delete2folders!" => \$delete2folders, + "syncinternaldates!" => \$syncinternaldates, + "idatefromheader!" => \$idatefromheader, + "syncacls!" => \$syncacls, + "maxsize=i" => \$maxsize, + "minsize=i" => \$minsize, + "maxage=i" => \$maxage, + "minage=i" => \$minage, + "buffersize=i" => \$buffersize, + "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, + "skipsize!" => \$skipsize, + "allowsizemismatch!" => \$allowsizemismatch, + "fastio1!" => \$fastio1, + "fastio2!" => \$fastio2, + "ssl1!" => \$ssl1, + "ssl2!" => \$ssl2, + "tls1!" => \$tls1, + "tls2!" => \$tls2, + "authmech1=s" => \$authmech1, + "authmech2=s" => \$authmech2, + "authuser1=s" => \$authuser1, + "authuser2=s" => \$authuser2, + "split1=i" => \$split1, + "split2=i" => \$split2, + "reconnectretry1=i" => \$reconnectretry1, + "reconnectretry2=i" => \$reconnectretry2, + "tests" => \$tests, + "tests_debug" => \$tests_debug, + "allow3xx!" => \$allow3xx, + "justlogin!" => \$justlogin, + "tmpdir=s" => \$tmpdir, + "pidfile=s" => \$pidfile, + "releasecheck!" => \$releasecheck, + "modules_version!" => \$modules_version, + ); + + $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 "Head NUM:", $headnum, "\n"; + unless($headnum) { print "Warning: no header used or found for message $m_uid\n"; } + my $headstr; + + foreach my $h (sort keys(%$head)){ + 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}H $H", "\n"; + + if ($skipheader and $H =~ m/$skipheader/i) { + $debug and print "Skipping header $H\n"; + next; + } + $headstr .= "$H"; + } + } + #return unless ($headstr); + unless ($headstr){ + # taking everything is too heavy, + # should take only 1 Ko + #print "no header so taking everything\n"; + #$headstr = $imap->message_string($m_uid); + + print "no header so we ignore this message\n"; + return undef; + } + 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 msg $m_uid:$m_md5:$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 = ); + 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 = ; + 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'); + return('unknown') if ($public_release eq 'unknown'); + return('unknown') if (! is_a_release_number($public_release)); + return('timeout') if ($public_release eq 'timeout'); + + 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.366 2010/10/25 17:15:52 gilles Exp $ '; + $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 => 'linux-france.org', + 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: www.linux-france.org\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 warn "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 ($@) { + 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)); + print < : "from" imap server. Mandatory. +--port1 : port to connect on host1. Default is 143. +--user1 : user to login on host1. Mandatory. +--authuser1 : user to auth with on host1 (admin user). + Avoid using --authmech1 SOMETHING with --authuser1. +--password1 : password for the user1. Dangerous, use --passfile1 +--passfile1 : password file for the user1. Contains the password. +--host2 : "destination" imap server. Mandatory. +--port2 : port to connect on host2. Default is 143. +--user2 : user to login on host2. Mandatory. +--authuser2 : user to auth with on host2 (admin user). +--password2 : password for the user2. Dangerous, use --passfile2 +--passfile2 : password file for the user2. Contains the password. +--noauthmd5 : don't use MD5 authentification. +--authmech1 : auth mechanism to use with host1: + PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE. +--authmech2 : 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 : sync this folder. +--folder : and this one, etc. +--folderrec : sync this folder recursively. +--folderrec : and this one, etc. +--include : sync folders matching this regular expression +--include : or this one, etc. + in case both --include --exclude options are + use, include is done before. +--exclude : skips folders matching this regular expression + Several folders to avoid: + --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3. +--exclude : or this one, etc. +--tmpdir : where to store temporary files and subdirectories. + Will be created if it doesn't exist. + Default is system specific and should be ok. +--pidfile : the file where imapsync pid is written. +--prefix1 : 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 : 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 : Apply the whole regex to each destination folders. +--regextrans2 : 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 : Apply the whole regex to each message before transfer. + Example: 's/\\000/ /g' # to replace null by space. +--regexmess : and this one. +--regexmess : and this one, etc. +--regexflag : Apply the whole regex to each flags list. + Example: 's/\"Junk"//g' # to remove "Junk" flag. +--regexflag : and this one, etc. +--sep1 : separator in case namespace is not supported. +--sep2 : idem. +--delete : delete messages on host1 server after + a successful transfer. Useful in case you + want to migrate from one server to another one. + With imap, "delete" tags messages as deleted, they + are not really deleted. See expunge. +--delete2 : delete messages in host2 that are not in + host1 server. +--delete2folders : delete folders in host2 that are not in + host1 server. For safety try it like this: + --delete2folders --dry --justfolders --nofoldersizes +--expunge : expunge messages on host1. + expunge really deletes messages marked deleted. + expunge is made at the beginning, on host1 only. + Newly transferred messages are expunged if + option --expunge is given. + No expunge is done on destination account + (see --expunge2) but it may change in future releases. +--expunge1 : expunge messages on host1. +--expunge2 : expunge messages on host2. +--uidexpunge2 : uidexpunge messages on the destination imap server + that are not on the source server, 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. +--buffersize : sets the size of a block of I/O. +--maxsize : skip messages larger (or equal) than bytes +--minsize : skip messages smaller (or equal) than bytes +--maxage : skip messages older than days. + final stats (skipped) don't count older messages + see also --minage +--minage : skip messages newer than 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) +--skipheader : Don't take into account header keyword + matching ex: --skipheader 'X.*' +--useheader : Use this header to compare messages on both sides. + Ex: Message-ID or Subject or Date. +--useheader and this one, etc. +--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 +--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. +--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. +--debug : debug mode. +--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 (just does not sync flags of messages + already transfered). +--reconnectretry1 : reconnect to host1 if connection is lost up to + times per imap command (default is 3) +--reconnectretry2 : same as --reconnectretry1 but for host2 +--split1 : split the requests in several parts on host1. + is the number of messages handled per request. + default is like --split1 1000. +--split2 : same thing on host2. +--fastio1 : use fastio with host1. +--fastio2 : use fastio with host2. +--timeout : imap connect timeout. +--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 \\ + --host1 imap.truc.org --user1 foo --password1 secret1 \\ + --host2 imap.trac.org --user2 bar --password2 secret2 + +$localhost_info +$rcs +$warn_release + +$thank +EOF +} + + +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) = @_; + 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 = '' if not defined($zone); + $d = $day_1 . $date_rest . $hour . $zone; + + + }elsif ($d =~ m{(?:.{3}, )(\d?)(\d) (...) (\d{4})( \d{2}:\d{2}:\d{2})( (?:\+|-)\d{4})?}o ) { + #print "header: [$1][$2][$3][$4][$5][$6]\n"; + my ($day_1, $day_rest, $month, $year, $hour, $zone) = ($1,$2,$3,$4,$5,$6); + $day_1 = '0' if ($day_1 eq ''); + $zone = '' if not defined($zone); + $d = $day_1 . "$day_rest-$month-$year" . $hour . $zone; + + }else{ + # unknown/unmatch => return same string + return($d); + } + + $d = qq("$d"); + return($d); +} + +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 @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 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"' 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"' 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'); + +} + + +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, \%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) { + + 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 tests_debug { + + SKIP: { + skip "No test in normal run" if (not $tests_debug); + tests_list_keys_in_2_not_in_1(); + } +} + +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(); + } +} + +# 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::append_file = sub { + + my $self = shift; + my $folder = $self->Massage(shift); + my $file = shift; + my $control = shift || undef; + my $count = $self->Count($self->Count+1); + my $flags = shift || undef; + my $date = shift || undef; + + if (defined($flags)) { + $flags =~ s/^\s+//g; + $flags =~ s/\s+$//g; + } + + if (defined($date)) { + $date =~ s/^\s+//g; + $date =~ s/\s+$//g; + } + + $flags = "($flags)" if $flags and $flags !~ /^\(.*\)$/ ; + $date = qq/"$date"/ if $date and $date !~ /^"/ ; + + + unless ( -f $file ) { + $self->LastError("File $file not found.\n"); + return undef; + } + + my $fh = IO::File->new($file) ; + + unless ($fh) { + $self->LastError("Unable to open $file: $!\n"); + $@ = "Unable to open $file: $!" ; + carp "unable to open $file: $!"; + return undef; + } + + my $bare_nl_count = scalar grep { /^\x0a$|[^\x0d]\x0a$/} <$fh>; + + seek($fh,0,0); + + my $clear = $self->Clear; + + $self->Clear($clear) + if $self->Count >= $clear and $clear > 0; + + my $length = ( -s $file ) + $bare_nl_count; + + my $string = "$count APPEND $folder " . + ( $flags ? "$flags " : "" ) . + ( $date ? "$date " : "" ) . + "{" . $length . "}\x0d\x0a" ; + + $self->_record($count,[ $self->_next_index($count), "INPUT", "$string" ] ); + + my $feedback = $self->_send_line("$string"); + + unless ($feedback) { + $self->LastError("Error sending '$string' to IMAP: $!\n"); + $fh->close; + return undef; + } + + my ($code, $output) = ("",""); + + until ( $code ) { + $output = $self->_read_line or $fh->close, return undef; + foreach my $o (@$output) { + $self->_record($count,$o); # $o is already an array ref + ($code) = $o->[DATA] =~ /(^\+|^\d+\sNO|^\d+\sBAD)/i; + if ($o->[DATA] =~ /^\*\s+BYE/) { + carp $o->[DATA]; + $self->State(Unconnected); + $fh->close; + return undef ; + } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) { + carp $o->[DATA]; + $fh->close; + return undef; + } + } + } + + { # Narrow scope + # Slurp up headers: later we'll make this more efficient I guess + local $/ = "\x0d\x0a\x0d\x0a"; + my $text = <$fh>; + $text =~ s/\x0d?\x0a/\x0d\x0a/g; + $self->_record($count,[ $self->_next_index($count), "INPUT", "{From file $file}" ] ) ; + $feedback = $self->_send_line($text); + + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + $fh->close; + return undef; + } + _debug($self, "control points to $$control\n") if ref($control) and $self->Debug; + $/ = ref($control) ? "\x0a" : $control ? $control : "\x0a"; + while (defined($text = <$fh>)) { + $text =~ s/\x0d?\x0a/\x0d\x0a/g; + $self->_record( $count, + [ $self->_next_index($count), "INPUT", "{from $file}\x0d\x0a" ] + ); + $feedback = $self->_send_line($text,1); + + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + $fh->close; + return undef; + } + } + $feedback = $self->_send_line("\x0d\x0a"); + + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + $fh->close; + return undef; + } + } + + # Now for the crucial test: Did the append work or not? + ($code, $output) = ("",""); + + my $uid = undef; + until ( $code ) { + $output = $self->_read_line or return undef; + foreach my $o (@$output) { + $self->_record($count,$o); # $o is already an array ref + $self->_debug("append_file: Deciding if " . $o->[DATA] . " has the code.\n") + if $self->Debug; + ($code) = $o->[DATA] =~ /^\d+\s(NO|BAD|OK)/i; + # try to grab new msg's uid from o/p + $o->[DATA] =~ m#UID\s+\d+\s+(\d+)\]# and $uid = $1; + if ($o->[DATA] =~ /^\*\s+BYE/) { + carp $o->[DATA]; + $self->State(Unconnected); + $fh->close; + return undef ; + } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) { + carp $o->[DATA]; + $fh->close; + return undef; + } + } + } + $fh->close; + + if ($code !~ /^OK/i) { + return undef; + } + + + return defined($uid) ? $uid : $self; +}; + + + + +*Mail::IMAPClient::fetch_hash = sub { + # taken from original lib, + # just added split code. + my $self = shift; + my $hash = 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 = scalar($self->messages); + 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 ( exists $hash->{$uid} ) { + $entry = $hash->{$uid} ; + } + else { + $hash->{$uid} ||= $entry; + } + } + else { + my($mid) = $l =~ /^\* (\d+) FETCH/i; + next unless $mid; + if ( exists $hash->{$mid} ) { + $entry = $hash->{$mid} ; + } + else { + $hash->{$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 + (?:" # 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 : $hash; +}; + + + +*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 'UID)' + # 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 ) { + warn "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::exists = sub { + 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])}<>\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<>\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: ${current_line}\n" . + # "and left with buffer contents of: ${iBuffer}\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\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\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<>\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; + 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; +} + +sub fetch_hash_2 { + # 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 + (?:" # 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; +} diff --git a/imapsync-1.404 b/imapsync-1.404 new file mode 100755 index 0000000..f75d4b5 --- /dev/null +++ b/imapsync-1.404 @@ -0,0 +1,4830 @@ +#!/usr/bin/perl + +# 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 36 different IMAP server softwares +supported with success. + +$Revision: 1.404 $ + +=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 is already available directly on the following distributions +(at least): +FreeBSD, Debian, Ubuntu, Gentoo, Fedora, +NetBSD, Darwin, Mandriva and OpenBSD. + + Get imapsync at + http://www.linux-france.org/prj/imapsync/ + + 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://www.linux-france.org/prj/imapsync/INSTALL + + The freshmeat record is at http://freshmeat.net/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 ] + [--user1 ] [--passfile1 ] + [--host2 server2] [--port2 ] + [--user2 ] [--passfile2 ] + [--ssl1] [--ssl2] + [--tls1] [--tls2] + [--authmech1 ] [--authmech2 ] + [--proxyauth1] [--proxyauth2] + [--domain1] [--domain2] + [--authmd51] [--authmd52] + [--folder --folder ...] + [--folderrec --folderrec ...] + [--include ] [--exclude ] + [--prefix2 ] [--prefix1 ] + [--regextrans2 --regextrans2 ...] + [--sep1 ] + [--sep2 ] + [--justfolders] [--justfoldersizes] [--justconnect] [--justbanner] + [--syncinternaldates] + [--idatefromheader] + [--syncacls] + [--regexmess ] [--regexmess ] + [--maxsize ] + [--minsize ] + [--maxage ] + [--minage ] + [--skipheader ] + [--useheader ] [--useheader ] + [--nouid1] [--nouid1] + [--usecache] + [--skipsize] [--allowsizemismatch] + [--delete] [--delete2] + [--expunge] [--expunge1] [--expunge2] [--uidexpunge2] + [--delete2folders] [--delete2foldersonly] [--delete2foldersbutnot] + [--subscribed] [--subscribe] [--subscribe_all] + [--nofoldersizes] + [--dry] + [--debug] [--debugimap][--debugimap1][--debugimap2] + [--timeout ] [--fast] + [--split1] [--split2] + [--reconnectretry1 ] [--reconnectretry2 ] + [--noreleasecheck] + [--pidfile ] + [--tmpdir ] + [--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. imapsync is CPU hungry so nice and renice +commands can be a good help. imapsync can be memory hungry too, +especially with large messages. + +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) + +=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: + + +To subscribe, send any message (even empty) to: + +then just reply to the confirmation message. + +To unsubscribe, send a message to: + + +To contact the person in charge for the list: + + +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 + +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://www.linux-france.org/prj/imapsync/ + +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. + + - operating system running imapsync. + + - operating systems on both sides and the third side in case + you run imapsync on a foreign host from the both. + + - virtual software context (vmware, xen etc.) + +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) http://www.mailenable.com/ + - DBMail 0.9, 2.0.7 (GPL). But DBMail 1.2.1 works. + Patient and confident testers are welcome. + - Imail 7.04 (maybe). + +Success stories reported with the following 40 imap servers +(software names are in alphabetic order): + + - 1und1 H mimap1 84498 [host1] + - a1.net imap.a1.net IMAP4 Ready WARSBL614 00029c23 [host1] + - Archiveopteryx 2.03, 2.04, 2.09, 2.10 [host2], 3.0.0 [host2] + (OSL 3.0) http://www.archiveopteryx.org/ + - 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 + - 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 + - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform) + - 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], Exchange 2007 SP1 (with Update Rollup 2), + Exchange2007-EP-SP2, + Exchange 2010 RTM (Release to Manufacturing) [host2] + - Mirapoint + - 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 + - Imap part of TCP/IP suite of VMS 7.3.2 + - Zimbra-IMAP 3.0.1 GA 160, 3.1.0 Build 279, 4.0.5, 4.5.2, 4.5.6, 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.csv (for example) +containing users and passwords. +The separator used in this example is ';' + +The file.csv file contains: + +user0001;password0001;user0002;password0002 +user0011;password0011;user0012;password0012 +... + +And the shell program is just: + + { while IFS=';' read u1 p1 u2 p2; do + imapsync --user1 "$u1" --password1 "$p1" --user2 "$u2" --password2 "$p2" ... + done ; } < file.csv + +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 : http://software.complete.org/offlineimap + mailsync : http://mailsync.sourceforge.net/ + imapxfer : http://www.washington.edu/imap/ + part of the imap-utils from UW. + mailutil : replace imapxfer in + part of the imap-utils from UW. + http://www.gsp.com/cgi-bin/man.cgi?topic=mailutil + imaprepl : http://www.bl0rg.net/software/ + http://freshmeat.net/projects/imap-repl/ + imap_migrate : http://freshmeat.net/projects/imapmigration/ + 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 tools/wonko_ruby_imapsync + pop2imap : http://www.linux-france.org/prj/pop2imap/ + + +Feedback (good or bad) will often be welcome. + +$Id: imapsync,v 1.404 2011/02/21 03:35:39 gilles Exp $ + +=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 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, $nb_errors, + $host1, $host2, $port1, $port2, + $user1, $user2, $domain1, $domain2, + $password1, $password2, $passfile1, $passfile2, + @folder, @include, @exclude, @folderrec, + $prefix1, $prefix2, + @regextrans2, @regexmess, @regexflag, + $sep1, $sep2, + $syncinternaldates, + $idatefromheader, + $usedatemanip, + $syncacls, + $fastio1, $fastio2, + $maxsize, $minsize, $maxage, $minage, + $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, + $tests, $test_builder, $tests_debug, + $allow3xx, $justlogin, + $tmpdir, + $releasecheck, + $max_msg_size_in_bytes, + $modules_version, + $delete2folders, $delete2foldersonly, $delete2foldersbutnot, + $usecache, $debugcache, + $takebody, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess, +); + +# main program + +# global variables initialisation + +$rcs = '$Id: imapsync,v 1.404 2011/02/21 03:35:39 gilles Exp $ '; + +$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; + +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; + +$takebody = defined($takebody) ? $takebody : 1; + +if ( $fast ) { + $useuid = 1 ; + $foldersizes = 0 ; +} + +# Activate --usecache if --useuid is set and no --nousecache +$usecache = 1 if ( $useuid and ( ! defined( $usecache ) ) ) ; + + + +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 ||= 1000; +$split2 ||= 1000; + +$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; + +# 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($idatefromheader) { + print "Turned ON idatefromheader, ", + "will set the internal dates on host2 from the 'Date:' header line.\n"; + $syncinternaldates = 0; + +} +if ($syncinternaldates) { + print "Turned ON syncinternaldates, ", + "will set the internal dates (arrival dates) on host2 same as host1.\n"; +}else{ + print "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 "Will try to use $authmech1 authentication on host1\n"; +print "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") unless (@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; + +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); + +$debugimap2 and print "Host2 connection\n"; +$imap2 = login_imap($host2, $port2, $user2, $domain2, $password2, + $debugimap2, $timeout, $fastio2, $ssl2, $tls2, + $authmech2, $authuser2, $reconnectretry2, + $proxyauth2, $uid2); + +# history + +$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); + +$split1 and $imap1->Split($split1); +$split2 and $imap2->Split($split2); + +# +# Folder stuff +# + +my ( +@h1_folders_all, %h1_folders_all, @h1_folders_wanted, %requested_folder, %subscribed_folder, +@h2_folders_all, %h2_folders_all, @h2_folders_from_1, %h2_folders_from_1, +); + + +# Make a hash of subscribed folders in source server. +map { $subscribed_folder{$_} = 1 } $imap1->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 (%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_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_namespace = $imap1->namespace(); +#my $h2_namespace = $imap2->namespace(); +#$debug and print "Host1 namespace:\n", Data::Dumper->Dump([$h1_namespace]); +#$debug and print "Host2 namespace:\n", Data::Dumper->Dump([$h2_namespace]); + +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{$h2_fold}++; +} + +@h2_folders_from_1 = sort keys(%h2_folders_from_1); + +if ($foldersizes) { + foldersizes("Host1", $imap1, @h1_folders_wanted); + foldersizes("Host2", $imap2, @h2_folders_from_1); +} + + +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(%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); + + printf("%-35s -> %-35s\n", "[$h1_fold]", "[$h2_fold]"); + + select_folder($imap1, $h1_fold, 'Host1') or next FOLDER; + + + if ( ! exists($h2_folders_all{$h2_fold})) { + create_folder($imap2, $h2_fold, 'Host2') or next FOLDER; + } + + acls_sync($h1_fold, $h2_fold); + + select_folder($imap2, $h2_fold, 'Host2') or next FOLDER; + my @select_results = $imap2->Results(); + + #print "%%% @select_results\n"; + my $permanentflags2 = permanentflags(@select_results); + + if ($expunge){ + print "Expunging host1 $h1_fold\n"; + unless($dry) { $imap1->expunge() }; + #print "Expunging host2 $h2_fold\n"; + #unless($dry) { $imap2->expunge() }; + } + + if (($subscribe and exists $subscribed_folder{$h1_fold}) or $subscribe_all) { + print "Subscribing to folder $h2_fold on destination server\n"; + unless($dry) { $imap2->subscribe($h2_fold) }; + } + + next FOLDER if ($justfolders); + + my @h1_msgs = select_msgs($imap1); + + $debug and print "LIST Host1: ", scalar(@h1_msgs), " messages [@h1_msgs]\n"; + # internal dates on host2 are after the ones on host1 + # normally... + my @h2_msgs = select_msgs($imap2); + + $debug and print "LIST Host2: ", scalar(@h2_msgs), " 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) if ($usecache) ; + 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"; + #print "CACHE h2 h1: ", scalar( keys %$cache_2_1_ref ), " files\n" ; + #$debug and print '[', + # map ( { "$_->$cache_2_1_ref->{$_} " } keys %$cache_2_1_ref ), " ]\n"; + } + #sleep 4 ; + + my %h1_hash = (); + my %h2_hash = (); + + my ( %h1_msgs_all, %h2_msgs_all ) ; + @h1_msgs_all{ @h1_msgs } = (); + @h2_msgs_all{ @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_no_cache, %h2_msgs_no_cache ) ; + %h1_msgs_no_cache = %h1_msgs_all ; + %h2_msgs_no_cache = %h2_msgs_all ; + delete @h1_msgs_no_cache{ @h1_msgs_in_cache } ; + delete @h2_msgs_no_cache{ @h2_msgs_in_cache } ; + + my @h1_msgs_no_cache = keys %h1_msgs_no_cache ; + my @h2_msgs_no_cache = keys %h2_msgs_no_cache ; + + + if ( $useuid ) { + @h1_msgs_copy_by_uid{ @h1_msgs_no_cache } = ( ) ; + @h1_msgs_no_cache = ( ) ; + @h2_msgs_no_cache = ( ) ; + } + + $debug and print "Host1 folder [$h1_fold] parsing headers\n"; + + my ($h1_heads_ref, $h1_fir_ref) = ({}, {}); + $h1_heads_ref = $imap1->parse_headers([@h1_msgs_no_cache], @useheader) if (@h1_msgs_no_cache); + $debug and print "Time headers: ", timenext(), " s\n"; + + @$h1_fir_ref{@h1_msgs} = (undef); + $h1_fir_ref = $imap1->fetch_hash_2("FLAGS", "INTERNALDATE", "RFC822.SIZE", $h1_fir_ref) + if (@h1_msgs); + $debug and print "Time fir: ", timenext(), " s\n"; + unless ($h1_fir_ref) { + warn + "Host1 folder $h1_fold: Could not fetch_hash_2 ", + scalar(@h1_msgs), " msgs: ", $imap1->LastError, "\n"; + $nb_errors++; + next FOLDER; + } + + my @h1_msgs_duplicate; + foreach my $m (@h1_msgs_no_cache) { + my $rc = parse_header_msg($imap1, $m, $h1_heads_ref, $h1_fir_ref, "F", \%h1_hash); + if (! defined($rc)) { + my $h1_size = $h1_fir_ref->{$m}->{"RFC822.SIZE"} || 0; + print "+ Skipping msg #$m:$h1_size on host1 folder $h1_fold (no header 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; + } + } + $debug and print "Time parsing headers on host1: ", timenext(), " s\n"; + + $debug and print "Host2 folder [$h2_fold] parsing headers\n"; + + my ($h2_heads_ref, $h2_fir_ref) = ( {}, {} ); + $h2_heads_ref = $imap2->parse_headers([@h2_msgs_no_cache], @useheader) if (@h2_msgs_no_cache); + $debug and print "Time headers: ", timenext(), " s\n"; + + @$h2_fir_ref{@h2_msgs} = ( ); # fetch_hash_2 can select by uid with last arg as ref + $h2_fir_ref = $imap2->fetch_hash_2("FLAGS", "INTERNALDATE", "RFC822.SIZE", $h2_fir_ref) + if (@h2_msgs); + $debug and print "Time fir: ", timenext(), " s\n"; + + my @h2_msgs_duplicate; + foreach my $m (@h2_msgs_no_cache) { + my $rc = parse_header_msg($imap2, $m, $h2_heads_ref, $h2_fir_ref, "T", \%h2_hash); + my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; + if (! defined($rc)) { + print "+ Skipping msg #$m:$h2_size in host2 folder $h2_fold (no header 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); + } + } + $debug and print "Time parsing headers on host2: ", 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($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 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 deleted [duplicate] 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 and !$imap2->can("uidexpunge")) { + warn "uidexpunge not supported (< IMAPClient 3.17)\n"; + } + elsif(@h2_expunge) { + print "uidexpunge $cnt message(s)\n"; + $imap2->uidexpunge(\@h2_expunge) if !$dry; + } + } + + my $h2_uidnext = $imap2->uidnext( $h2_fold ) ; + $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'}; + + if (defined $maxsize and $h1_size >= $maxsize) { + print "msg $h1_fold/$h1_msg skipping ($h1_size exceeds maxsize limit $maxsize bytes)\n"; + $total_bytes_skipped += $h1_size; + $nb_msg_skipped += 1; + next MESS; + } + if (defined $minsize and $h1_size <= $minsize) { + print "msg $h1_fold/$h1_msg skipping ($h1_size smaller than minsize $minsize bytes)\n"; + $total_bytes_skipped += $h1_size; + $nb_msg_skipped += 1; + next MESS; + } + + unless (exists($h2_hash{$m_id})) { + # copy + copy_message( $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; + next MESS; + } + else{ + # already on host2 + my $h2_msg = $h2_hash{$m_id}{'m'} ; + $debug and print "msg $h1_fold/$h1_msg equals $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_msg, $h2_msg, $h2_fold, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; + + # Good + my $h2_size = $h2_hash{$m_id}{'s'}; + $debug and print + "msg $h1_fold/$h1_msg sizes $h1_size <> $h2_size $h2_fold/$h2_msg\n"; + 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 ); + } + } + + } + # 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 $h1_msg->$h2_msg\n"; + sync_flags( $h1_msg, $h2_msg, $h2_fold, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; + my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } ; + $total_bytes_skipped += $h1_size; + $nb_msg_skipped += 1; + } + + MESS_BY_UID: foreach my $h1_msg ( sort { $a <=> $b } keys %h1_msgs_copy_by_uid ) { + # copy_message + #print "Copy by uid $h1_fold/$h1_msg\n" ; + copy_message( $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; + + } + + if ($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 sync_flags { + my ( $h1_msg, $h2_msg, $h2_fold, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ; + $debug and print "sync flags $h1_msg->$h2_msg\n"; + + # used cached flag values for efficiency + my $h1_flags = $h1_fir_ref->{ $h1_msg }->{ "FLAGS" } ; + my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ "FLAGS" } ; + + # 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 = flags_filter($h1_flags, $permanentflags2) if ( $permanentflags2 ); + + # 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 ; + $diff and $debug and print "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)" ) ) { + warn "- 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 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::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 ($self->Tls) { + starttls($self); + } + + $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 login_imap { + my($host, $port, $user, $domain, $password, + $debugimap, $timeout, $fastio, + $ssl, $tls, $authmech, $authuser, $reconnectretry, + $proxyauth, $uid) = @_; + 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("Can not open imap connection on [$host] with user [$user]: $@\n"); + + print "Banner: ", server_banner($imap); + + if ($imap->has_capability("AUTH=$authmech") + or $imap->has_capability($authmech) + ) { + printf("Host %s says it has CAPABILITY for AUTHENTICATE %s\n", + $imap->Server, $authmech); + } + else { + printf("Host %s says it has NO CAPABILITY for AUTHENTICATE %s\n", + $imap->Server, $authmech); + if ($authmech eq 'PLAIN') { + print "Frequently PLAIN is only supported with SSL, ", + "try --ssl1 or --ssl2 option\n"; + } + } + + if ($proxyauth) { + $imap->Authmechanism(""); + } else { + $imap->Authmechanism($authmech) unless ($authmech eq 'LOGIN'); + } + + $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 ($imap->login()) { + my $info = "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 "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); + + print "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.404 $ ', + '$Date: 2011/02/21 03:35:39 $ ', + "\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) { + warn "$pidfile already exists, overwriting it\n"; + } + open(PIDFILE, ">$pidfile") or do { + warn "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)) { + warn + "$hostside folder $folder: Could not select: ", + $imap->LastError, "\n"; + $nb_errors++; + return(0); + }else{ + # ok select succeeded + return(1); + } +} + + +sub create_folder { + my ($imap, $folder, $hostside) = @_; + print "$hostside folder $folder does not exist\n"; + print "Creating folder [$folder]\n"; + if ( ! $dry){ + if ( ! $imap->create($folder)){ + warn "Couldn't create [$folder] on $hostside: ", + $imap->LastError,"\n"; + $nb_errors++; + 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 ($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"; + 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 $tot = 0; + my $tmess = 0; + my $biggest = 0 ; + + print "++++ Calculating sizes\n"; + foreach my $folder (@folders) { + my $stot = 0; + my $smess = 0; + printf("$side folder %-35s", "[$folder]"); + unless($imap->exists($folder)) { + print("does not exist yet\n"); + next; + } + unless ($imap->examine($folder)) { + warn + "$side Folder $folder: Could not examine: ", + $imap->LastError, "\n"; + $nb_errors++; + next; + } + + my $hash_ref = {}; + my @msgs = select_msgs($imap); + $smess = scalar(@msgs); + my $smax = 0 ; + @$hash_ref{@msgs} = (undef); + unless ($smess == 0) { + $imap->fetch_hash_2("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", $smess); + printf(" Biggest: %9s\n", $smax); + $tot += $stot; + $tmess += $smess; + } + printf ("Nb messages: %11s\n", $tmess ) ; + printf ("Total size: %11s bytes\n", $tot ) ; + printf ("Biggest message: %11s bytes\n", $biggest ) ; + printf ("Time: %11s secondes\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; + $debug and print "eval \$h1_flags =~ $regexflag\n"; + eval("\$h1_flags =~ $regexflag"); + die_clean("error: eval regexflag '$regexflag': $@\n") if $@; + $debug 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 warn "Could not getacl for $h1_fold: $@\n"; + my $h2_hash = $imap2->getacl($h2_fold) + or warn "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 warn "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 \(([^)]+?)\)\]}) { + #print "%%%$1%%%\n"; + 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 select_msgs { + my ($imap) = @_; + my (@msgs,@max,@min,@union,@inter); + + unless (defined($maxage) or defined($minage)) { + #@msgs = $imap->search("ALL"); + @msgs = $imap->messages(); + return(@msgs); + } + if (defined($maxage)) { + @max = $imap->sentsince(time - 86400 * $maxage); + } + if (defined($minage)) { + @min = $imap->sentbefore(time - 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 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"}; + + my $string; + $string = $imap1->message_string($h1_msg); + unless (defined($string)) { + warn + "- msg $h1_fold/$h1_msg could not be fetched: ", + $imap1->LastError, "\n"; + $nb_errors++; + $total_bytes_error += $h1_size; + return( ) ; + } + + if (@regexmess) { + $string = regexmess($string); + } + + $debug 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"; + } + + # 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 = 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'; + warn "- msg $h1_fold/$h1_msg 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/%-10s copied to %s/%-10s\n", $h1_fold, $h1_msg, $h2_fold, $new_id ); + $h2_uidguess++; + $total_bytes_transferred += $h1_size; + $nb_msg_transferred += 1; + $debugcache and print "touch $cache_dir/${h1_msg}_$new_id\n" if ( $usecache ) ; + touch( "$cache_dir/${h1_msg}_$new_id" ) if ( $usecache 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); + } + } + } + } + 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->{ $uid1 } ) + and exists( $h2_msgs_hash_ref->{ $uid2 } ) ) { + # 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) = @_; + + -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; + 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 ) + if ( ! ( defined( $maxsize ) + or defined( $minsize ) + or defined( $maxage ) + or defined( $minage ) ) ); + + #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( $c12, $c21 ) ; + ok( ( $c12, $c21 ) = get_cache('tmp/cache/F1/F2', $msgs_1, $msgs_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 not 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), '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 ]; + + ok( ( $c12, $c21 ) = get_cache('tmp/cache/rr\uee', $msgs_1, $msgs_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 = shift ; + my $cache_1_2_ref = shift ; + + $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" ; + if ( ( ! defined( $uid1 ) ) + or ( ! defined( $uid2 ) ) + or ( ! exists( $cache_1_2_ref->{ $uid1 } ) ) + or ( ! ( $uid2 == $cache_1_2_ref->{ $uid1 } ) ) ) { + $debugcache and print "remove $file\n" ; + unlink( $file ) or warn "$!" ; + } + } + + $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, + } ; + + ok( clean_cache( \@test_files_cache, $cache ), '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_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 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:' + eq regexmess('From '), + 'From mbox 2 add colo'); + + ok( "\n" . 'From ' + eq regexmess("\n" . 'From '), + 'From mbox 3 add colo'); + + ok( "From: zzz\n" . 'From ' + eq regexmess("From zzz\n" . 'From '), + 'From mbox 4 add colo'); + + @regexmess = 's{\AFrom\ [^\n]*(\n)?}{}gxms'; + ok( '' + eq regexmess(''), + 'From mbox 1 remove, blank'); + + ok( '' + eq regexmess('From '), + 'From mbox 2 remove'); + + ok( "\n" . 'From ' + eq regexmess("\n" . 'From '), + 'From mbox 3 remove'); + + #print "[", regexmess("From zzz\n" . 'From '), "]"; + ok( "" . 'From ' + eq regexmess("From zzz\n" . 'From '), + 'From mbox 4 remove'); + + + ok( +'Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye.' + eq regexmess( +'From zzz +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +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 $memory_consumption = memory_consumption(); + 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 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://www.linux-france.org/prj/imapsync/\n"); + + my $basename = imapsync_basename(); + $debug and print "[$basename]\n"; + return("Homepage: http://www.linux-france.org/prj/imapsync/\n") + if ( $basename =~ /\.exe$|\.bin$/ ); + + 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://www.linux-france.org/prj/imapsync/\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, + "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, + "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, + "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, + "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" => \$proxyauth1, + "split1=i" => \$split1, + "split2=i" => \$split2, + "buffersize=i" => \$buffersize, + "reconnectretry1=i" => \$reconnectretry1, + "reconnectretry2=i" => \$reconnectretry2, + "tests" => \$tests, + "tests_debug" => \$tests_debug, + "allow3xx!" => \$allow3xx, + "justlogin!" => \$justlogin, + "tmpdir=s" => \$tmpdir, + "pidfile=s" => \$pidfile, + "releasecheck!" => \$releasecheck, + "modules_version!" => \$modules_version, + "usecache!" => \$usecache, + "debugcache!" => \$debugcache, + "useuid!" => \$useuid, + ); + + $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 "Head NUM:", $headnum, "\n"; + unless($headnum) { print "Warning: no header used or found for message $m_uid\n"; } + my $headstr; + + foreach my $h (sort keys(%$head)){ + 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}H $H", "\n"; + + if ($skipheader and $H =~ m/$skipheader/i) { + $debug and print "Skipping header $H\n"; + next; + } + $headstr .= "$H"; + } + } + + if ( ( ! $headstr) and ( $takebody ) ){ + print "no header so taking body first 2Ko\n"; + $imap->fetch($m_uid, "BODY.PEEK[TEXT]<0.2048>"); + $headstr = $imap->_transaction_literals; + + if ( 4048 <= length( $headstr ) ) { + # the imap server might reply the whole message + # this is bad for memory on huge mailboxes + $takebody = 0 ; + $headstr = '' ; + $h1_msgs_copy_by_uid{ $m_uid } = 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 msg $m_uid:$m_md5:$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 = ); + 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 = ; + 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.404 2011/02/21 03:35:39 gilles Exp $ '; + $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: www.linux-france.org\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 warn "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)); + print < : "from" imap server. Mandatory. +--port1 : port to connect on host1. Default is 143. +--user1 : user to login on host1. Mandatory. +--domain1 : domain on host1 (NTLM authentication). +--authuser1 : 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 : password for the user1. Dangerous, use --passfile1 +--passfile1 : password file for the user1. Contains the password. +--host2 : "destination" imap server. Mandatory. +--port2 : port to connect on host2. Default is 143. +--user2 : user to login on host2. Mandatory. +--domain2 : domain on host2 (NTLM authentication). +--authuser2 : 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 : password for the user2. Dangerous, use --passfile2 +--passfile2 : password file for the user2. Contains the password. +--authmd51 : Use MD5 authentification for host1. +--authmd52 : Use MD5 authentification for host2. +--authmech1 : auth mechanism to use with host1: + PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE. +--authmech2 : 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 : sync this folder. +--folder : and this one, etc. +--folderrec : sync this folder recursively. +--folderrec : and this one, etc. +--include : sync folders matching this regular expression +--include : or this one, etc. + in case both --include --exclude options are + use, include is done before. +--exclude : skips folders matching this regular expression + Several folders to avoid: + --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3. +--exclude : or this one, etc. +--tmpdir : where to store temporary files and subdirectories. + Will be created if it doesn't exist. + Default is system specific and should be ok. +--pidfile : the file where imapsync pid is written. +--prefix1 : 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 : 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 : Apply the whole regex to each destination folders. +--regextrans2 : 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 : Apply the whole regex to each message before transfer. + Example: 's/\\000/ /g' # to replace null by space. +--regexmess : and this one. +--regexmess : and this one, etc. +--regexflag : Apply the whole regex to each flags list. + Example: 's/\"Junk"//g' # to remove "Junk" flag. +--regexflag : and this one, etc. +--sep1 : separator in case namespace is not supported. +--sep2 : idem. +--delete : delete 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. +--delete2folders : delete folders in host2 that are not in + host1 server. For safety, please try it like this (safe): + --delete2folders --dry --justfolders --nofoldersizes +--delete2foldersonly : delete only folders matching regex. +--delete2foldersbutnot : 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 the transfer of messages. +--expunge2 : expunge messages on host2 after the transfer of messages. +--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 : skip messages larger (or equal) than bytes +--minsize : skip messages smaller (or equal) than bytes +--maxage : skip messages older than days. + final stats (skipped) don't count older messages + see also --minage +--minage : skip messages newer than 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) +--skipheader : Don't take into account header keyword + matching ex: --skipheader 'X.*' +--useheader : Use this header to compare messages on both sides. + Ex: Message-ID or Subject or Date. +--useheader and this one, etc. +--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 +--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. +--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. +--useuid : Use uid instead of header as a criterium to sync. + --usecache is then implied unless --nousecache +--debug : debug mode. +--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 --useuid --nofoldersizes +--reconnectretry1 : reconnect to host1 if connection is lost up to + times per imap command (default is 3) +--reconnectretry2 : same as --reconnectretry1 but for host2 +--split1 : split the requests in several parts on host1. + is the number of messages handled per request. + default is like --split1 1000. +--split2 : same thing on host2. +--timeout : imap connect timeout. +--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 \\ + --host1 imap.truc.org --user1 foo --password1 secret1 \\ + --host2 imap.trac.org --user2 bar --password2 secret2 + +$localhost_info +$rcs +$warn_release + +$thank +EOF +} + + +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) = @_; + 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 = '' if not defined($zone); + $d = $day_1 . $date_rest . $hour . $zone; + + + }elsif ($d =~ m{(?:.{3}, )(\d?)(\d) (...) (\d{4})( \d{2}:\d{2}:\d{2})( (?:\+|-)\d{4})?}o ) { + #print "header: [$1][$2][$3][$4][$5][$6]\n"; + my ($day_1, $day_rest, $month, $year, $hour, $zone) = ($1,$2,$3,$4,$5,$6); + $day_1 = '0' if ($day_1 eq ''); + $zone = '' if not defined($zone); + $d = $day_1 . "$day_rest-$month-$year" . $hour . $zone; + + }else{ + # unknown/unmatch => return same string + return($d); + } + + $d = qq("$d"); + return($d); +} + +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 @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 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"' 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"' 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'); + +} + + +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, \%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 tests_debug { + + SKIP: { + skip "No test in normal run" if ( not $tests_debug ); + tests_clean_cache( ) ; + tests_match_a_cache_file( ) ; + tests_touch( ) ; + tests_cache_map( ) ; + tests_get_cache( ) ; + } +} + +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_cache_map( ) ; + tests_get_cache( ) ; + tests_clean_cache( ) ; + tests_match_a_cache_file( ) ; + tests_touch( ) ; + } +} + +# 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: + # OK [APPENDUID ] 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 original lib, + # just added split code. + my $self = shift; + my $hash = 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 = scalar($self->messages); + 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 ( exists $hash->{$uid} ) { + $entry = $hash->{$uid} ; + } + else { + $hash->{$uid} ||= $entry; + } + } + else { + my($mid) = $l =~ /^\* (\d+) FETCH/i; + next unless $mid; + if ( exists $hash->{$mid} ) { + $entry = $hash->{$mid} ; + } + else { + $hash->{$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 + (?:" # 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 : $hash; +}; + + + +*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 'UID)' + # 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 ) { + warn "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::exists = sub { + 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])}<>\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<>\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: ${current_line}\n" . + # "and left with buffer contents of: ${iBuffer}\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\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\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<>\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; +} + +sub fetch_hash_2 { + # 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 + (?:" # 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; +} diff --git a/imapsync.exe b/imapsync.exe index c6ed57f..f5b8ec3 100755 Binary files a/imapsync.exe and b/imapsync.exe differ diff --git a/index.shtml b/index.shtml index a709048..784dd31 100644 --- a/index.shtml +++ b/index.shtml @@ -2,10 +2,10 @@ -imapsync <!--#exec cmd="cat VERSION" --> +Imapsync: an IMAP migration tool ( release <!--#exec cmd="cat VERSION"--> ) - + @@ -33,6 +33,7 @@ @@ -59,6 +60,27 @@ where the user plays independently on both sides. Use offlineimap

+

Latest release is imapsync + +

+ +

Written on

+ +

See ChangeLog to know what's new in details.

+ +

New features since previous releases 1.404:

+ +
    +
  • Updated imapsync.exe to last Mail-IMAPClient 3.28 (thanks to Phil Pearl Lobbes)
    • +
  • Option --useuid now works also with --delete2 option.
    • +
+ + +

The next imapsync release should see:

+
    +
  • An option to sync to and from files (local backup)
    • +
+

Who is the author?

Gilles LAMIRAL
@@ -72,32 +94,6 @@ where the user plays independently on both sides. Use offlineimap imapsync mailing-list (see below section Mailing-List).

-

Latest release is imapsync - -

- -

Written on

- -

See ChangeLog to know what's new.

- - - -

New features since previous release 1.383:

- -
    -
  • new option --usecache to speedup transfers when using multiple runs.
    • -
  • new option --delete2foldersonly to select which host2 folder hierarchy can be removed if it is away from host1.
    • -
  • new option --delete2foldersbutnot to avoid removing host2 folder hierarchy even if it is away from host1.
    • -
  • Added info about the biggest messages (imapsync uses about 18 times in RAM the size of the biggest transfered message)
    • -
- - -

The next imapsync release should see:

-
    -
  • An option to sync to and from files (local backup)
    • -
- -

Buy imapsync source code

@@ -107,22 +103,28 @@ The Perl imapsync source code will run anywhere a Perl interpreter can

Buy latest imapsync Perl source code for 30 EUR

-30 EUR is about 40 USD, no problem to pay in USD with paypal: +30 EUR is equal to around 45 USD, no problem to pay in USD (or any currency) with paypal:

-imapsync usage +
+ +

-

You will receive a download link in few minutes (contact me if the delay is over a couple of hours).
-30 days money-back guarantee.

+

You will receive a download link just after the payment.
+30 days money-back guarantee!

Standalone imapsync.exe for win32

@@ -130,30 +132,61 @@ The Perl imapsync source code will run anywhere a Perl interpreter can buying the latest win32 standalone imapsync.exe for 30 EUR

-30 EUR is about 40 USD, no problem to pay in USD with paypal: +30 EUR is equal to around 45 USD, no problem to pay in USD (or any currency) with paypal:

+

-imapsync usage +
+ - +

- -

You will receive a download link in few minutes (contact me if the delay is over a couple of hours).
-30 days money-back guarantee.

+

You will receive a download link just after the payment.
+30 days money-back guarantee!

+

Support for imapsync

+ +

For 90 EUR buy imapsync support by the developper who wrote and maintains imapsync. +

+

+90 EUR is equal to around 125 USD, no problem to pay in USD (or any currency) with paypal: +

+ +
+

+ + + + + +

+
+ + +

Then you will be able to expose your issues by email or phone and to converse until your issues are solved. +

+

Documentation

Read the INSTALL file to know how to install imapsync on your system. @@ -231,7 +264,7 @@ If you really want a feature or a fix you can donate money and my next developme will be to code it or fix it.

-

On february 2011: 1 EUR ~ 1.3 USD.

+

On april 2011: 1 EUR ~ 1.48 USD.

@@ -251,6 +284,7 @@ will be to code it or fix it.
DONEFeature Time guessedTime spentMoney receivedMoney needed NoBackup to files 20 hours 60 min 0 $ 800 $ NoEfficient Gmail backup 20 hours 80 min 0 $ 800 $ + NoBetter error reporting 5 hours 0 min 0 $ 200 $ YesAdd cache 10 hours 1310 min 400 $ 400 $ YesSpeedup 50% 10 hours 80 min 10 $ 400 $ Yes--delete2folders 3 hours 270 min 90 $ 0 $ @@ -270,14 +304,13 @@ will be to code it or fix it.

    -
  • DBMail 0.9, 2.0.7 (GPL). But most other DBMail releases work (see below)
    • +
  • DBMail 0.9, 2.0.7 (GPL). But most other DBMail releases are supported (see below)
  • Imail 7.04 (maybe).
    • -
  • MailEnable 1.54 (Proprietary) http://www.mailenable.com/
    • +
  • MailEnable 1.54 (Proprietary) but MailEnable 4.23 is supported.
-

Now the long reported success stories list -([host1] means "source server", -[host2] means "destination server"): +

Now the long reported success stories list (41 different imap server softwares) +([host1] means "source server", [host2] means "destination server"):

    @@ -309,11 +342,14 @@ will be to code it or fix it.
  • 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) [host1] [host2]
  • GMX IMAP4 StreamProxy.
    • +
  • Goddy IMAP (since Goddy runs Courier)
  • Groupwise IMAP (Novell) 6.x and 7.0. Buggy so see the FAQ.
  • hMailServer 5.3.3 [host2], 4.4.1 [host1], HMAILSERVER 5.3.2-B1769 on windows 2003 [hsot2]
  • iPlanet Messaging server 4.15, 5.1, 5.2
    • -
  • IMail 7.15 (Ipswitch/Win2003), 8.12
    • +
  • IMail 7.15 (Ipswitch/Win2003), 8.12, 11.03 [host1]
    • +
  • MailEnable 4.23 [host1] [host2]
  • MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform)
  • Mercury 4.1 (Windows server 2000 platform)
  • Microsoft Exchange Server 5.5, 6.0.6249.0[host1], 6.0.6487.0[host1], @@ -368,7 +404,7 @@ alt="Viewable With Any Browser" /> This document last modified on -($Id: index.shtml,v 1.55 2011/02/21 02:16:36 gilles Exp gilles $) +($Id: index.shtml,v 1.63 2011/04/19 23:51:09 gilles Exp gilles $)

    diff --git a/memo b/memo index 077a5cf..d261ed7 100644 --- a/memo +++ b/memo @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: memo,v 1.29 2010/12/14 15:14:46 gilles Exp gilles $ +# $Id: memo,v 1.30 2011/03/23 19:14:37 gilles Exp gilles $ software_version() { @@ -13,11 +13,11 @@ statistics_lfo() { #grep prj/imapsync/VERSION /usr/local/apache/logs/access_log | sort -n | cut -d ' ' -f 1,12,13|uniq -c | sort -n # list ip cat < "$f1" + + /g/public_html/imapsync/paypal_reply/paypal_bilan \ + --bnc --debug --debug_csv "$f" \ + > "$f2" + + echo diff "$f1" "$f2" + diff "$f1" "$f2" +done + +for f in /g/paypal/paypal_201?_??_complet.csv; do + fb=`basename "$f"` + f1=/g/var/paypal_bilan/tests/${fb}_tva.out1 + f2=/g/var/paypal_bilan/tests/${fb}_tva.out2 + rm "$f2" + /g/public_html/imapsync/paypal_reply/paypal_bilan_1.22 \ + "$f" \ + > "$f1" + + /g/public_html/imapsync/paypal_reply/paypal_bilan \ + "$f" \ + > "$f2" + + echo diff "$f1" "$f2" + diff "$f1" "$f2" +done + + + +) +} + + + +#echo paypal_bilan_tests_refact_1 +paypal_bilan_tests_refact_1() { +# DID output no diff between paypal_bilan_1.11 and 1.13 +( +#set -x +for f in /g/paypal/paypal_201?_??.csv; do + fb=`basename "$f"` + f1=/g/var/paypal_bilan/tests/$fb.out1 + f2=/g/var/paypal_bilan/tests/$fb.out2 + rm "$f2" + /g/public_html/imapsync/paypal_reply/paypal_bilan_1.11 \ + --bnc --debug "$f" \ + > "$f1" + + /g/public_html/imapsync/paypal_reply/paypal_bilan \ + --bnc --debug "$f" \ + > "$f2" + + echo diff "$f1" "$f2" + diff "$f1" "$f2" +done + +for f in /g/paypal/paypal_201?_??.csv; do + fb=`basename "$f"` + f1=/g/var/paypal_bilan/tests/$fb.out1 + f2=/g/var/paypal_bilan/tests/$fb.out2_usd_eur + rm "$f2" + /g/public_html/imapsync/paypal_reply/paypal_bilan_1.11 \ + --bnc --debug "$f" \ + > "$f1" + + /g/public_html/imapsync/paypal_reply/paypal_bilan \ + --bnc --debug --usdeur 1.2981 "$f" \ + > "$f2" + + echo diff "$f1" "$f2" + diff "$f1" "$f2" +done + +for f in /g/paypal/paypal_201?_??.csv; do + fb=`basename "$f" .csv` + + #echo $fb + + f1i=/g/paypal/$fb.csv + f2i=/g/paypal/${fb}_complet.csv + + f1o=/g/var/paypal_bilan/tests/t03_$fb.out1 + f2o=/g/var/paypal_bilan/tests/t03_$fb.out2 + + #echo $f1i + #echo $f2i + #echo $f1o + #echo $f2o + + rm -f "$f1o" "$f2o" + /g/public_html/imapsync/paypal_reply/paypal_bilan \ + --bnc --debug "$f1i" \ + > "$f1o" + + /g/public_html/imapsync/paypal_reply/paypal_bilan \ + --bnc --debug "$f2i" \ + > "$f2o" + + echo diff "$f1o" "$f2o" + diff "$f1o" "$f2o" +done +) +} + +#echo paypal_bilan_tests_dev +paypal_bilan_tests_dev() { + +/g/public_html/imapsync/paypal_reply/paypal_bilan \ + /g/paypal/paypal_201?_??_complet.csv --invoices '1 50 200' + +# Strange characters +/g/public_html/imapsync/paypal_reply/paypal_bilan \ + /g/paypal/paypal_201?_??_complet.csv --invoices '389 234 96' + +# France +/g/public_html/imapsync/paypal_reply/paypal_bilan \ + /g/paypal/paypal_201?_??_complet.csv --invoices '9 392' + +# individual +/g/public_html/imapsync/paypal_reply/paypal_bilan \ + /g/paypal/paypal_201?_??_complet.csv --invoices '313 415' + +# /g/public_html/imapsync/paypal_reply/paypal_bilan /g/paypal/paypal_2011_03_complet.csv +# pb with latex +# Ok 10 # character +# 65 clientAdrB Keyboard character used is undefined YOSHITO YONEI +# Ok 84 Missing $ inserted. clientEmail victor_su@yahoo.com +# 92 Dr. Westernacher & Partner GmbH + +# /g/public_html/imapsync/paypal_reply/paypal_bilan --first_in 147 --invoices '242' /g/paypal/paypal_2010_1?_complet.csv +} diff --git a/paypal_reply/paypal_bilan b/paypal_reply/paypal_bilan index 059a628..e679737 100755 --- a/paypal_reply/paypal_bilan +++ b/paypal_reply/paypal_bilan @@ -1,70 +1,98 @@ #!/usr/bin/perl +# $Id: paypal_bilan,v 1.23 2011/04/19 14:59:43 gilles Exp gilles $ + use strict; use warnings; +use Getopt::Long; +use Text::CSV_XS ; +use IO::Handle ; +use Data::Dumper ; +use Unicode::MapUTF8 qw(to_utf8 from_utf8 utf8_supported_charset); -my $total_usd_received ; -my $total_usd_invoice ; +die unless (utf8_supported_charset('ISO-8859-1')); -my $total_eur_received ; -my $total_eur_invoice ; -my $nb_invoice ; -my $line ; +my $total_usd_received = 0 ; +my $total_usd_invoice = 0 ; +my $total_HT_EUR_exo = 0 ; +my $total_HT_EUR_ass = 0 ; +my $total_TVA_EUR = 0 ; +my $total_eur_received = 0 ; +my $total_eur_invoice = 0 ; +my $nb_invoice = 0 ; +my $nb_invoice_refund = 0 ; -while( $line = <> ) { - next if ( $line =~ /^Date, Heure, Fuseau horaire, Nom, Type, Etat, Devise, Montant, Numéro d'avis de réception, Solde,/ ) ; - #print( "A1 $line" ) ; - chomp( $line ) ; - #print ("A2 $line\n" ); +my $debug ; +my $debug_csv ; +my $debug_dev ; +my $first_invoice = 1 ; +my $print_details = '' ; +my $bnc = ''; +my $usdeur = 1.2981 ; +my $invoices ; +my %invoice_refund ; +my $write_invoices = 0; + +my $dir_invoices = '/g/var/paypal_invoices' ; + +my $option_ret = GetOptions ( + 'debug' => \$debug, + 'debug_csv' => \$debug_csv, + 'debug_dev' => \$debug_dev, + 'first_invoice=i' => \$first_invoice, + 'print_details|details' => \$print_details, + 'bnc' => \$bnc, + 'usdeur=f' => \$usdeur, + 'invoices=s' => \$invoices, + 'write_invoices!' => \$write_invoices, +); + +my @files = @ARGV ; +my %action_of_invoice ; + +my @invoices = split( /\s+/, $invoices ) if $invoices ; + +#print "@invoices\n" ; + +foreach my $file ( @files ) { + + my @actions = parse_file( $file ) ; - my $line2 = '",' . $line . '"' ; - my( $Nothing, $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, $Devise, $Montant, $Numero_davis_de_reception, $Solde ) - = split( '","', $line2 ) ; - #print ( "[$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; - - - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'USD' eq $Devise - and 'Terminé' eq $Etat - ) { - $Montant =~tr/,/./; - #print "$Montant\n" ; - my $Montant2_usd; - $Montant2_usd = 15 if ( 14.11 == $Montant or 14.19 == $Montant ) ; - $Montant2_usd = 25 if ( 23.72 == $Montant or 23.85 == $Montant ) ; - $Montant2_usd = 35 if ( 33.33 == $Montant or 33.51 == $Montant ) ; - $Montant2_usd = 50 if ( 47.75 == $Montant or 14.19 == $Montant ) ; - $Montant2_usd = 125 if ( 119.82 == $Montant or 119.82 == $Montant ) ; - $Montant2_usd = 135 if ( 129.43 == $Montant or 129.43 == $Montant ) ; - #print "$Montant $Montant2_usd\n" ; - $total_usd_received += $Montant ; - $total_usd_invoice += $Montant2_usd ; - $nb_invoice++ ; - } - if ( - 'Paiement sur site marchand reçu' eq $Type - and 'EUR' eq $Devise - and 'Terminé' eq $Etat - ) { - $Montant =~tr/,/./; - #print "$Montant\n" ; - my $Montant2_eur; - $Montant2_eur = 22 if ( 20.88 == $Montant or 20.99 == $Montant ) ; - $Montant2_eur = 30 if ( 28.58 == $Montant or 28.73 == $Montant ) ; - $Montant2_eur = 110 if ( 105.46 == $Montant ) ; - #print "$Montant $Montant2_eur\n" ; - $total_eur_received += $Montant ; - $total_eur_invoice += $Montant2_eur ; - $nb_invoice++ ; + foreach my $action (@actions) { + my %action = %$action ; + #print $action->{ Nom }, "\n" ; + my( $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, + $Devise, $Montant, $Numero_davis_de_reception, $Solde, + $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe ) + = @action{ ( 'Date', 'Heure', 'Fuseau horaire', 'Nom', 'Type', 'Etat', + 'Devise', 'Montant', "Numéro d'avis de réception", 'Solde', + 'Pays', 'Nom Option 1', 'Valeur Option 1', 'Hors taxe') } ; + #print "$Nom\n" ; + my $invoice = 'NONE' ; + $Montant = $action->{ Net } if not defined $Montant; + compute_line($action, $invoice, $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, + $Devise, $Montant, $Numero_davis_de_reception, $Solde, + $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe ) ; + + # index by invoice number + $action_of_invoice{ $action->{ 'invoice' } } = $action ; } + delete $action_of_invoice{ 'NONE' } ; } +@invoices = ( $first_invoice .. $first_invoice + $nb_invoice -1 ) if ( ! @invoices ) ; + +foreach my $invoice ( @invoices ) { + build_invoice( $invoice ) ; +} + + + print "USD banque $total_usd_received\n" ; print "USD invoice $total_usd_invoice\n" ; my $total_eur_from_usd ; -$total_eur_from_usd = int( ( $total_usd_invoice / 1.2981 ) + 0.5 ) ; # au 30 nov 2010 http://fr.finance.yahoo.com/devises/convertisseur/#from=EUR;to=USD;amt=1 +$total_eur_from_usd = int( ( $total_usd_invoice / $usdeur ) + 0.5 ) ; # au 30 nov 2010 http://fr.finance.yahoo.com/devises/convertisseur/#from=EUR;to=USD;amt=1 print "EUR from USD $total_eur_from_usd\n" ; #$total_eur = int( ( $total_eur_invoice / 1.3 ) + 0.5 ) ; #print "EUR $total_eur_from_usd\n" ; @@ -72,10 +100,674 @@ print "EUR banque $total_eur_received\n" ; print "EUR invoice $total_eur_invoice\n" ; my $total_eur = $total_eur_from_usd + $total_eur_invoice ; -print "EUR total $total_eur\n" ; -print "Nb invoice $nb_invoice\n" ; + +$total_HT_EUR_exo = sprintf('%2.f', $total_HT_EUR_exo) ; +$total_HT_EUR_ass = sprintf('%2.f', $total_HT_EUR_ass) ; +$total_TVA_EUR = sprintf('%2.f', $total_TVA_EUR) ; + +$total_eur = sprintf('%2.f', $total_eur) ; + +print "EUR total $total_eur\n" ; +print "EUR total HT exo $total_HT_EUR_exo\n" ; +print "EUR total HT assuj $total_HT_EUR_ass\n" ; +print "EUR total TVA $total_TVA_EUR\n" ; +print "Nb invoice $nb_invoice\n" ; +print "Nb invoice refund $nb_invoice_refund\n" ; + +print "$total_eur != $total_HT_EUR_exo + $total_HT_EUR_ass + $total_TVA_EUR\n" +if ( $total_eur != $total_HT_EUR_exo + $total_HT_EUR_ass + $total_TVA_EUR ) ; + +sub parse_one_line_io { + my $csv = shift ; + my $io = shift ; + + my $line = $csv->getline($io) ; + + return if ( $csv->eof( ) ) ; + if ( not defined( $line ) ) { + my($cde, $str, $pos) = $csv->error_diag () ; + print "[$cde] [$str] [$pos]\n" ; + + } + return( $line ) ; +} + +sub hash_and_count_dupplicate { + my @columns = @_ ; + my %columns ; + + #@columns_def{ @columns_def } = ( ) ; + foreach my $col ( @columns ) { + $columns{ $col } += 1 ; + } + $debug_csv and print "Nb columns: ", scalar( keys %columns ), " ", scalar( @columns ), "\n" ; + # debug how many time a title is defined + foreach my $col (1 .. scalar( @columns )) { + $debug_csv and print "$col | ", + deci_to_AA( $col ) , " | ", + $columns{ $columns[ $col - 1 ] }, " | ", + $columns[ $col - 1 ], "\n" ; + } + + # exit in case two columns have the same name + die "Erreur : doublons dans les titres\n" if ( scalar( keys %columns ) != scalar( @columns ) ) ; + + return( %columns ) ; +} + +sub deci_to_AA { + my $deci = shift ; + my $AA = ''; + + while ( $deci > 0 ) { + my $quot = int( ( $deci - 1 ) / 26 ) ; + my $rest = $deci - 1 - ( 26 * $quot ) ; + my $char = chr ( ord('A') + $rest ) ; + $AA = $char . $AA ; + $deci = $quot ; + } + #print "col=$AA\n" ; + return( $AA ) ; +} + +sub remove_first_blank { + my $string = shift ; + + $string =~ s/^ +// ; + return( $string ) ; + +} + +sub parse_file { + my $file = shift ; + + open my $io, "<", $file or die "$file: $!" ; + + my $csv = Text::CSV_XS->new( { + sep_char => ',', + binary => 1, + keep_meta_info => 1, + eol => $/, + } ) ; + + my $line_1 = parse_one_line_io( $csv, $io ) ; + die if ( not defined $line_1 ) ; # first line must have no problem + + my @columns_def_orig = @$line_1 ; + my @columns_def = map { remove_first_blank( $_ ) } @columns_def_orig ; + $debug_csv and print "columns_def = ", map( { "[$_]" } @columns_def ), "\n"; + + my %columns_def = hash_and_count_dupplicate( @columns_def ) ; + my $nb_columns_def = scalar @columns_def ; + + my $line_counter = 2 ; + my @actions ; + while ( 1 ) { + $debug_csv and print "ligne $line_counter ", $csv->eof( ), "\n" ; + my $line = parse_one_line_io( $csv, $io ) ; + last if ( $csv->eof( ) ) ; + if ( not defined $line ) { + print "Erreur ligne $line_counter : ", $csv->error_diag, "\n\n"; + ++$line_counter ; + next ; + } + my @columns = @$line ; + + if ( $nb_columns_def != scalar @columns ) { + print "Erreur ligne $line_counter : nombre de colonnes = ", scalar @columns, " != $nb_columns_def\n" ; + ++$line_counter ; + next ; + } + my %columns ; + @columns{ @columns_def } = @columns ; + $columns{ 'file_csv' } = $file ; + $columns{ 'line_number' } = $line_counter ; + $csv->combine( @columns ) ; + my $line_csv = $csv->string(); + $columns{ 'line_csv' } = $line_csv ; + $debug_csv and print map( { "[$_] = [" . $columns{$_} . "]\n" } + @columns_def, 'line_number', 'line_csv', 'file_csv' ), + "\n"; + ++$line_counter ; + push( @actions, \%columns ) ; + } + close( $io ); + return( reverse @actions ) ; +} + +sub compute_line { + my( $action, $invoice, $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, + $Devise, $Montant, $Numero_davis_de_reception, $Solde, + $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe_paypal ) = @_ ; + + $debug and print( "[$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n", + "[$Pays] [$Nom_Option_1] [$Valeur_Option_1]\n" ) ; + #$debug_dev and print "$Hors_taxe_paypal\n" ; + + $Montant =~ s/[^0-9-,.]//g ; + $Montant =~ s/,/./g ; + #$debug and print "MM[$Montant]\n" ; + $Hors_taxe_paypal =~ s/,/./g ; + + my $MontantEUR; + my( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) ; + if ( $bnc ) { + $MontantEUR = $Montant ; + $MontantEUR = sprintf( "%.4f", $Montant/$usdeur ) if ($Devise eq 'USD') ; + print( "\n", "=" x 60, "\n" ) ; + print( "[$Date] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [EUR $MontantEUR]\n", + "[$Pays] [$Nom_Option_1] [$Valeur_Option_1]\n" ) ; + } + + if ( + 'Paiement sur site marchand reçu' eq $Type + and 'USD' eq $Devise + and ( 'Terminé' eq $Etat or 'Compensé' eq $Etat ) + ) { + $Montant =~tr/,/./; + #print "$Montant\n" ; + my $Montant2_usd; + $Montant2_usd = $Hors_taxe_paypal ; + $total_usd_received += $Montant ; + $total_usd_invoice += $Montant2_usd ; + ( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) = tva_line( $Devise, $Montant2_usd, $Pays, $Nom_Option_1, $Valeur_Option_1 ) ; + $total_HT_EUR_exo += $montant_HT_EUR_exo ; + $total_HT_EUR_ass += $montant_HT_EUR_ass ; + $total_TVA_EUR += $montant_TVA_EUR ; + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; + + } + if ( + 'Paiement sur site marchand reçu' eq $Type + and 'EUR' eq $Devise + and ( 'Terminé' eq $Etat or 'Compensé' eq $Etat ) + ) { + $Montant =~tr/,/./; + #print "$Montant\n" ; + my $Montant2_eur; + $Montant2_eur = $Hors_taxe_paypal ; + $total_eur_received += $Montant ; + $total_eur_invoice += $Montant2_eur ; + ( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) = tva_line( $Devise, $Montant2_eur, $Pays, $Nom_Option_1, $Valeur_Option_1 ) ; + $total_HT_EUR_exo += $montant_HT_EUR_exo ; + $total_HT_EUR_ass += $montant_HT_EUR_ass ; + $total_TVA_EUR += $montant_TVA_EUR ; + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; + } + if ( + 'Paiement sur site marchand reçu' eq $Type + and 'EUR' eq $Devise + and 'Remboursé' eq $Etat + ) { + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $nb_invoice_refund++; + $invoice_refund{ $invoice }++ ; + + $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; + } + if ( + 'Paiement sur site marchand reçu' eq $Type + and 'EUR' eq $Devise + and 'Non compensé' eq $Etat + ) { + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; + } + + $action->{ 'invoice' } = $invoice ; + if ( $bnc ) { + my $FR_flag = '' ; + $FR_flag = ' FR' if $Pays eq 'France' ; + my $IND_flag = '' ; + $IND_flag = ' IND' if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) ; + print "FE $invoice$FR_flag$IND_flag\n" ; + print "Facture $invoice imapsync$FR_flag $Nom\n" ; + printf( "%.2f [EUR %.2f]\n", $Montant, $MontantEUR ) ; + } +} + +sub build_invoice { + my $invoice = shift ; + + return if ! $invoice ; + + my $action = $action_of_invoice{ $invoice } ; + my $refund = '' ; + $refund = 'REFUND ' if $invoice_refund{ $invoice } ; + my %action = %$action if $action ; + #print Data::Dumper->Dump( [$action] ) ; + + my( $Date, $Heure, $Nom, $Type, $Etat, $Devise, $Hors_taxe, $Commission, $Net, + $De_l_adresse_email, $A_l_adresse_email, $N_de_transaction, $Titre_de_l_objet, + $TVA, $Nom_Option_1, $Valeur_Option_1, $N_de_transaction_de_reference, + $Adresse_1, $Adresse_2_district_quartier, $Ville, + $Etat_Province, $Code_postal, $Pays, $line_number, $line_csv, $file_csv ) + = @action{ ( 'Date', 'Heure', 'Nom', 'Type', 'Etat', 'Devise', 'Hors taxe', 'Commission', 'Net', + "De l'adresse email", "A l'adresse email", 'N° de transaction', "Titre de l'objet", + 'TVA', 'Nom Option 1', 'Valeur Option 1', 'Nº de transaction de référence', + 'Adresse 1', 'Adresse 2/district/quartier', 'Ville', + 'Etat/Province/Région/Comté/Territoire/Préfecture/République', 'Code postal', 'Pays', 'line_number', 'line_csv', 'file_csv' ) } ; + + #print "$Hors_taxe $Devise\n" ; + my $Hors_taxe_num = $Hors_taxe ; + $Hors_taxe_num =~ s{,}{.} ; + if ($Hors_taxe_num > 100) { + print "invoice $invoice $Hors_taxe_num > 100\n" ; + #return() ; + } + + my ( $email_message_header, $email_message_body ) + = build_email_message( $Date, $Nom, $De_l_adresse_email, $invoice ) ; + if ( $write_invoices ) { + write_email_message( $dir_invoices, $invoice, + $email_message_header, $email_message_body, + $De_l_adresse_email) ; + write_csv_info( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) ; + } + + + + #print "==== $invoice $refund=================================================" ; + #print $email_message ; + + my( + $clientAdrA, + $clientAdrB, + $clientAdrC, + $clientAdrD, + $clientAdrE, + $clientAdrF, + ) + = build_adress( + $Nom, + $Adresse_1, + $Adresse_2_district_quartier, + $Ville, + $Code_postal, + $Etat_Province, + $Pays, + ) ; + + foreach my $str ( + $De_l_adresse_email, + $Nom, + $clientAdrA, + $clientAdrB, + $clientAdrC, + $clientAdrD, + $clientAdrE, + $clientAdrF, + ) { + $str =~ s{#}{\\#}g ; + $str =~ s{_}{\\_}g ; + $str =~ s{&}{\\&}g ; + } + + my ( $clientTypeEN, $clientTypeFR ) = client_type( $Nom_Option_1, $Valeur_Option_1 ) ; + + my ( + $priceHT, + $tvaFR, + $tvaEN, + $priceTVA, + $priceTTC, + $messageTVAFR, + $messageTVAEN, + $priceTTCusd + ) + = tva_stuff( $clientTypeEN, $Pays, $Hors_taxe, $Devise ) ; + + my ( $urlSrc, $urlExe ) = download_urls( $Date ) ; + my $tex_variables = qq{ +%% Begin input from $0 +\\providecommand{\\invoiceNumber}{$invoice} +\\providecommand{\\clientName}{$Nom} +\\providecommand{\\clientEmail}{$De_l_adresse_email} +\\providecommand{\\clientTypeEN}{$clientTypeEN} +\\providecommand{\\clientTypeFR}{$clientTypeFR} +\\providecommand{\\clientAdrA}{$clientAdrA} +\\providecommand{\\clientAdrB}{$clientAdrB} +\\providecommand{\\clientAdrC}{$clientAdrC} +\\providecommand{\\clientAdrD}{$clientAdrD} +\\providecommand{\\clientAdrE}{$clientAdrE} +\\providecommand{\\clientAdrF}{$clientAdrF} +\\providecommand{\\invoiceDate}{$Date} +\\providecommand{\\invoiceHour}{$Heure} +\\providecommand{\\priceHT}{$priceHT} +\\providecommand{\\tvaFR}{$tvaFR} +\\providecommand{\\tvaEN}{$tvaEN} +\\providecommand{\\priceTVA}{$priceTVA} +\\providecommand{\\priceTTC}{$priceTTC} +\\providecommand{\\priceTTCusd}{$priceTTCusd} +\\providecommand{\\messageTVAFR}{$messageTVAFR} +\\providecommand{\\messageTVAEN}{$messageTVAEN} +\\providecommand{\\urlSrc}{\\url{$urlSrc}} +\\providecommand{\\urlExe}{\\url{$urlExe}} +%% End input from $0 +} ; + + + #print $tex_variables ; + + write_tex_variables_file( $dir_invoices, + $invoice, $Date, $tex_variables ) if $write_invoices ; + +} + +sub build_email_message { + + my ( $date, $name, $email, $invoice ) = @_ ; + + my $message_header = qq{X-imapsync: invoice $invoice +From: Gilles LAMIRAL +Bcc: gilles\@lamiral.info +Subject: [imapsync invoice] $invoice ($date) +Disposition-Notification-To: Gilles LAMIRAL +} ; + + +my $message_body = qq{ +Hello $name, + +First I'm sorry for the delay to prepare and send you this message. + +Attached is the invoice of imapsync software you bought ($date). +The invoice file is named facture_imapsync-${invoice}.pdf +This invoice is in PDF format, ready to be print. + +If you need this invoice on paper, just ask me then +I will send it to you by postal mail. + +In order to respect the law, this numeric invoice PDF +file is signed with my private gpg key. + +The resulting gpg signature is in the file named +facture_imapsync-${invoice}.pdf.asc +also attached in this email message. + +You can verify I (Gilles LAMIRAL) really generated +this invoice with the following command line + + gpg --verify facture_imapsync-${invoice}.pdf.asc facture_imapsync-${invoice}.pdf + +or any other gpg graphical tool. + +I thank you again for buying and using imapsync. + +Any feedback is welcome. + +-- +Au revoir, 09 51 84 42 42 +Gilles Lamiral. France, Baulon (35580) 06 20 79 76 06 +} ; + +my $message_body_blabla = qq{ +Here is the fingerprint of my public key +pub 1024D/FDA2B3DC 2002-05-08 + Key fingerprint = 7906 F53D 0D62 0C67 304A 4CF0 6928 869B FDA2 B3DC +uid Gilles LAMIRAL +sub 1024g/A2C4CB42 2002-05-08 + +Of course the verification doesn't prove anything until +all the following conditions are met: +- you met me, +- I agree that the fingerprint above is really mine +- I prove I'm Gilles LAMIRAL with an official paper. + +Normally we won't have to verify anything unless +I disagree with this invoice and the payment +you made for imapsync. +} ; + +return( $message_header, $message_body ) ; + +} + +sub write_csv_info { + + my( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) = @_ ; + + open( CSVINFO, "> $dir_invoices/$invoice/csv_info.txt") or die ; + print CSVINFO join( "\n", $file_csv, $line_number, $line_csv ) ; + close( CSVINFO ) ; + +} + +sub write_email_message { + my ( $dir_invoices, $invoice, $message_header, $message_body, $email_address ) = @_ ; + + my $message_body_utf8 = to_utf8({ -string => $message_body, -charset => 'ISO-8859-1' }); + + mkdir( "$dir_invoices/$invoice" ) or die if ! -d "$dir_invoices/$invoice" ; + + open( HEADER, "> $dir_invoices/$invoice/facture_message_header.txt") or die ; + print HEADER $message_header ; + close( HEADER ) ; + + open( BODY, "> $dir_invoices/$invoice/facture_message_body.txt") or die ; + print BODY $message_body_utf8 ; + close( BODY ) ; + + open( ADDRESS, "> $dir_invoices/$invoice/email_address.txt") or die ; + print ADDRESS "$email_address\n" ; + close( ADDRESS ) ; +} + + +sub write_tex_variables_file { + my ( $dir_invoices, $invoice, $date_jjSmmSaaaa, $tex_variables ) = @_ ; + + my $tex_variables_utf8 = to_utf8({ -string => $tex_variables, -charset => 'ISO-8859-1' }); + mkdir( "$dir_invoices/$invoice" ) or die if ! -d "$dir_invoices/$invoice" ; + open( FILE, "> $dir_invoices/$invoice/imapsync_var.tex") or die ; + print FILE $tex_variables_utf8 ; + close( FILE ) ; + +} + +sub download_urls { + my $date_jjSmmSaaaa = shift ; + + my $date_aaaa_mm_jj = date_aaaa_mm_jj( $date_jjSmmSaaaa ) ; + # print "$date_aaaa_mm_jj $date_jjSmmSaaaa\n" ; + my ( $urlSrc, $urlExe ) ; + + if ('2011_03_24' le $date_aaaa_mm_jj) { + $urlSrc = 'http://www.linux-france.org/prj/imapsync/paypal_return.shtml' ; + $urlExe = '' ; + return( $urlSrc, $urlExe ) ; + } + if ('2011_02_21' le $date_aaaa_mm_jj) { + $urlSrc = 'http://www.linux-france.org/depot/2011_02_21/OUMbo7/' ; + $urlExe = 'http://www.linux-france.org/depot/2011_02_21/rHSVNs/' ; + return( $urlSrc, $urlExe ) ; + } + if ('2011_01_18' le $date_aaaa_mm_jj) { + $urlSrc = 'http://www.linux-france.org/depot/2011_01_18/zPRRNt/' ; + $urlExe = 'http://www.linux-france.org/depot/2011_01_18/FO1QzG/' ; + return( $urlSrc, $urlExe ) ; + } + if ('2011_01_18' le $date_aaaa_mm_jj) { + $urlSrc = 'http://www.linux-france.org/depot/2010_11_28/SiNdlZ/' ; + $urlExe = 'http://www.linux-france.org/depot/2010_11_28/R3ZAyr/' ; + return( $urlSrc, $urlExe ) ; + } + $urlSrc = 'http://www.linux-france.org/depot/2010_11_08/X2PWMe/' ; + $urlExe = 'http://www.linux-france.org/depot/2010_11_08/ZZ7zSc/' ; + return( $urlSrc, $urlExe ) ; +} + +sub date_aaaa_mm_jj { + my $date_jjSmmSaaaa = shift ; + + if ( $date_jjSmmSaaaa =~ m{(\d\d)/(\d\d)/(\d\d\d\d)} ) { + my( $jj, $mm, $aaaa ) = ( $1, $2, $3 ) ; + return( join( '_', $aaaa, $mm, $jj ) ) ; + }else{ + return( '9999_12_31' ) ; + } +} + + +sub tva_line { + my( $Devise, $Montant2, $Pays, $Nom_Option_1, $Valeur_Option_1 ) = @_ ; + my( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) ; + + $Montant2 = $Montant2/$usdeur if 'USD' eq $Devise ; + + if ( + ( 'imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) + or + ( 'France' eq $Pays ) + ) { + $montant_HT_EUR_exo = 0 ; + $montant_HT_EUR_ass = $Montant2 / 1.196 ; + $montant_TVA_EUR = $Montant2 / 1.196 * 0.196 ; + $debug_dev and print "$Montant2 $Pays $Valeur_Option_1\n" ; + }else{ + $montant_HT_EUR_exo = $Montant2 ; + $montant_HT_EUR_ass = 0 ; + $montant_TVA_EUR = 0 ; + } + return( $montant_HT_EUR_exo, $montant_HT_EUR_ass, $montant_TVA_EUR ) ; +} +sub tva_stuff { + my( $clientTypeEN, $Pays, $Hors_taxe, $Devise ) = @_ ; + + my $priceTTCusd = '' ; + $Hors_taxe =~ s{,}{.} ; + + if ( $Devise eq 'USD' ) { + $priceTTCusd = "(USD $Hors_taxe)" ; + $Hors_taxe = ( $Hors_taxe/$usdeur ) ; + } + + my ( + $priceHT, + $tvaFR, + $tvaEN, + $priceTVA, + $priceTTC, + $messageTVAFR, + $messageTVAEN, + ) ; + + if ( ( 'individual' eq $clientTypeEN) + or + ( 'France' eq $Pays ) + ) { + $priceHT = sprintf('%2.2f', $Hors_taxe/1.196) ; + $tvaFR = '19,60\%'; + $tvaEN = ''; + $priceTVA = sprintf('%2.2f', $Hors_taxe/1.196*0.196) ; + $priceTTC = sprintf('%2.2f', $Hors_taxe) ; + $messageTVAFR = ''; + $messageTVAEN = ''; + }else{ + $priceHT = sprintf('%2.2f', $Hors_taxe) ; + $tvaFR = 'néant'; + $tvaEN = '(none)'; + $priceTVA = 0 ; + $priceTTC = $priceHT; + $messageTVAFR = 'Exonération de TVA, article 259 B-1 du Code Général des Impôts'; + $messageTVAEN = '(VAT tax-exempt, article 259 B-1 French General Tax Code)'; + } + foreach my $price ( $priceHT, $priceTVA, $priceTTC, $priceTTCusd ) { + #print "[$price]\n" ; + $price =~ s{\.}{, } ; + } + return( + $priceHT, + $tvaFR, + $tvaEN, + $priceTVA, + $priceTTC, + $messageTVAFR, + $messageTVAEN, + $priceTTCusd + ) ; +} + +sub client_type { + my ( $Nom_Option_1, $Valeur_Option_1 ) = @_ ; + + my ( $clientTypeEN, $clientTypeFR ) = ( 'professional', 'professionnel' ) ; + + if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) { + $clientTypeEN = 'individual' ; + $clientTypeFR = 'individuel' ; + }elsif ('imapsync usage' eq $Nom_Option_1 and 'professional' eq $Valeur_Option_1 ) { + $clientTypeEN = 'professional' ; + $clientTypeFR = 'professionnel' ; + } + + return( $clientTypeEN, $clientTypeFR ) ; +} + +sub build_adress { + my( + $Nom, + $Adresse_1, + $Adresse_2_district_quartier, + $Ville, + $Code_postal, + $Etat_Province, + $Pays, + ) = @_ ; + + my $addr = " +=========================================================== +Nom $Nom +Adresse_1 $Adresse_1 +Adresse_2_district_quartier $Adresse_2_district_quartier +Ville Code_postal $Ville $Code_postal +Etat_Province $Etat_Province +Pays $Pays +" ; + #print $addr ; + + my @address ; + $Nom = '' if ( $Nom =~ m/^\s+$/ ) ; + push( @address, $Nom ) if $Nom ; + push( @address, $Adresse_1 ) if $Adresse_1 ; + push( @address, $Adresse_2_district_quartier ) if $Adresse_2_district_quartier ; + push( @address, "$Ville $Code_postal" ) if ( $Ville or $Code_postal ); + push( @address, $Etat_Province ) if $Etat_Province ; + push( @address, $Pays, ) if $Pays ; + my $clientAdrA = shift( @address ) || '' ; + my $clientAdrB = shift( @address ) || '' ; + my $clientAdrC = shift( @address ) || '' ; + my $clientAdrD = shift( @address ) || '' ; + my $clientAdrE = shift( @address ) || '' ; + my $clientAdrF = shift( @address ) || '' ; + +$addr = " +[$clientAdrA] +[$clientAdrB] +[$clientAdrC] +[$clientAdrD] +[$clientAdrE] +[$clientAdrF] +"; + #print $addr ; + + return( + $clientAdrA, + $clientAdrB, + $clientAdrC, + $clientAdrD, + $clientAdrE, + $clientAdrF, + ) ; +} diff --git a/paypal_reply/paypal_bilan_1.22 b/paypal_reply/paypal_bilan_1.22 new file mode 100755 index 0000000..b0a9070 --- /dev/null +++ b/paypal_reply/paypal_bilan_1.22 @@ -0,0 +1,756 @@ +#!/usr/bin/perl + +# $Id: paypal_bilan,v 1.22 2011/04/19 12:52:27 gilles Exp gilles $ + +use strict; +use warnings; +use Getopt::Long; +use Text::CSV_XS ; +use IO::Handle ; +use Data::Dumper ; +use Unicode::MapUTF8 qw(to_utf8 from_utf8 utf8_supported_charset); + +die unless (utf8_supported_charset('ISO-8859-1')); + +my $total_usd_received = 0 ; +my $total_usd_invoice = 0 ; + +my $total_eur_received = 0 ; +my $total_eur_invoice = 0 ; +my $nb_invoice = 0 ; +my $nb_invoice_refund = 0 ; + +my $debug ; +my $debug_csv ; +my $debug_dev ; +my $first_invoice = 1 ; +my $print_details = '' ; +my $bnc = ''; +my $usdeur = 1.2981 ; +my $invoices ; +my %invoice_refund ; +my $write_invoices = 0; + +my $dir_invoices = '/g/var/paypal_invoices' ; + +my $option_ret = GetOptions ( + 'debug' => \$debug, + 'debug_csv' => \$debug_csv, + 'debug_dev' => \$debug_dev, + 'first_invoice=i' => \$first_invoice, + 'print_details|details' => \$print_details, + 'bnc' => \$bnc, + 'usdeur=f' => \$usdeur, + 'invoices=s' => \$invoices, + 'write_invoices!' => \$write_invoices, +); + +my @files = @ARGV ; +my %action_of_invoice ; + +my @invoices = split( /\s+/, $invoices ) if $invoices ; + +#print "@invoices\n" ; + +foreach my $file ( @files ) { + + my @actions = parse_file( $file ) ; + + foreach my $action (@actions) { + my %action = %$action ; + #print $action->{ Nom }, "\n" ; + my( $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, + $Devise, $Montant, $Numero_davis_de_reception, $Solde, + $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe ) + = @action{ ( 'Date', 'Heure', 'Fuseau horaire', 'Nom', 'Type', 'Etat', + 'Devise', 'Montant', "Numéro d'avis de réception", 'Solde', + 'Pays', 'Nom Option 1', 'Valeur Option 1', 'Hors taxe') } ; + #print "$Nom\n" ; + my $invoice = 'NONE' ; + $Montant = $action->{ Net } if not defined $Montant; + compute_line($action, $invoice, $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, + $Devise, $Montant, $Numero_davis_de_reception, $Solde, + $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe ) ; + + # index by invoice number + $action_of_invoice{ $action->{ 'invoice' } } = $action ; + } + delete $action_of_invoice{ 'NONE' } ; +} + +@invoices = ( $first_invoice .. $first_invoice + $nb_invoice -1 ) if ( ! @invoices ) ; + +foreach my $invoice ( @invoices ) { + build_invoice( $invoice ) ; +} + + + +print "USD banque $total_usd_received\n" ; +print "USD invoice $total_usd_invoice\n" ; +my $total_eur_from_usd ; +$total_eur_from_usd = int( ( $total_usd_invoice / $usdeur ) + 0.5 ) ; # au 30 nov 2010 http://fr.finance.yahoo.com/devises/convertisseur/#from=EUR;to=USD;amt=1 +print "EUR from USD $total_eur_from_usd\n" ; +#$total_eur = int( ( $total_eur_invoice / 1.3 ) + 0.5 ) ; +#print "EUR $total_eur_from_usd\n" ; +print "EUR banque $total_eur_received\n" ; +print "EUR invoice $total_eur_invoice\n" ; + +my $total_eur = $total_eur_from_usd + $total_eur_invoice ; +print "EUR total $total_eur\n" ; +print "Nb invoice $nb_invoice\n" ; +print "Nb invoice refund $nb_invoice_refund\n" ; + + +sub parse_one_line_io { + my $csv = shift ; + my $io = shift ; + + my $line = $csv->getline($io) ; + + return if ( $csv->eof( ) ) ; + if ( not defined( $line ) ) { + my($cde, $str, $pos) = $csv->error_diag () ; + print "[$cde] [$str] [$pos]\n" ; + + } + return( $line ) ; +} + +sub hash_and_count_dupplicate { + my @columns = @_ ; + my %columns ; + + #@columns_def{ @columns_def } = ( ) ; + foreach my $col ( @columns ) { + $columns{ $col } += 1 ; + } + $debug_csv and print "Nb columns: ", scalar( keys %columns ), " ", scalar( @columns ), "\n" ; + # debug how many time a title is defined + foreach my $col (1 .. scalar( @columns )) { + $debug_csv and print "$col | ", + deci_to_AA( $col ) , " | ", + $columns{ $columns[ $col - 1 ] }, " | ", + $columns[ $col - 1 ], "\n" ; + } + + # exit in case two columns have the same name + die "Erreur : doublons dans les titres\n" if ( scalar( keys %columns ) != scalar( @columns ) ) ; + + return( %columns ) ; +} + +sub deci_to_AA { + my $deci = shift ; + my $AA = ''; + + while ( $deci > 0 ) { + my $quot = int( ( $deci - 1 ) / 26 ) ; + my $rest = $deci - 1 - ( 26 * $quot ) ; + my $char = chr ( ord('A') + $rest ) ; + $AA = $char . $AA ; + $deci = $quot ; + } + #print "col=$AA\n" ; + return( $AA ) ; +} + +sub remove_first_blank { + my $string = shift ; + + $string =~ s/^ +// ; + return( $string ) ; + +} + +sub parse_file { + my $file = shift ; + + open my $io, "<", $file or die "$file: $!" ; + + my $csv = Text::CSV_XS->new( { + sep_char => ',', + binary => 1, + keep_meta_info => 1, + eol => $/, + } ) ; + + my $line_1 = parse_one_line_io( $csv, $io ) ; + die if ( not defined $line_1 ) ; # first line must have no problem + + my @columns_def_orig = @$line_1 ; + my @columns_def = map { remove_first_blank( $_ ) } @columns_def_orig ; + $debug_csv and print "columns_def = ", map( { "[$_]" } @columns_def ), "\n"; + + my %columns_def = hash_and_count_dupplicate( @columns_def ) ; + my $nb_columns_def = scalar @columns_def ; + + my $line_counter = 2 ; + my @actions ; + while ( 1 ) { + $debug_csv and print "ligne $line_counter ", $csv->eof( ), "\n" ; + my $line = parse_one_line_io( $csv, $io ) ; + last if ( $csv->eof( ) ) ; + if ( not defined $line ) { + print "Erreur ligne $line_counter : ", $csv->error_diag, "\n\n"; + ++$line_counter ; + next ; + } + my @columns = @$line ; + + if ( $nb_columns_def != scalar @columns ) { + print "Erreur ligne $line_counter : nombre de colonnes = ", scalar @columns, " != $nb_columns_def\n" ; + ++$line_counter ; + next ; + } + my %columns ; + @columns{ @columns_def } = @columns ; + $columns{ 'file_csv' } = $file ; + $columns{ 'line_number' } = $line_counter ; + $csv->combine( @columns ) ; + my $line_csv = $csv->string(); + $columns{ 'line_csv' } = $line_csv ; + $debug_csv and print map( { "[$_] = [" . $columns{$_} . "]\n" } + @columns_def, 'line_number', 'line_csv', 'file_csv' ), + "\n"; + ++$line_counter ; + push( @actions, \%columns ) ; + } + close( $io ); + return( reverse @actions ) ; +} + +sub compute_line { + my( $action, $invoice, $Date, $Heure, $Fuseau_horaire, $Nom, $Type, $Etat, + $Devise, $Montant, $Numero_davis_de_reception, $Solde, + $Pays, $Nom_Option_1, $Valeur_Option_1, $Hors_taxe_paypal ) = @_ ; + + $debug and print( "[$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n", + "[$Pays] [$Nom_Option_1] [$Valeur_Option_1]\n" ) ; + #$debug_dev and print "$Hors_taxe_paypal\n" ; + + $Montant =~ s/[^0-9-,.]//g ; + $Montant =~ s/,/./g ; + #$debug and print "MM[$Montant]\n" ; + $Hors_taxe_paypal =~ s/,/./g ; + + my $MontantEUR; + if ( $bnc ) { + $MontantEUR = $Montant ; + $MontantEUR = sprintf( "%.4f", $Montant/$usdeur ) if ($Devise eq 'USD') ; + print( "\n", "=" x 60, "\n" ) ; + print( "[$Date] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [EUR $MontantEUR]\n", + "[$Pays] [$Nom_Option_1] [$Valeur_Option_1]\n" ) ; + } + + if ( + 'Paiement sur site marchand reçu' eq $Type + and 'USD' eq $Devise + and 'Terminé' eq $Etat + ) { + $Montant =~tr/,/./; + #print "$Montant\n" ; + my $Montant2_usd; + $Montant2_usd = $Hors_taxe_paypal ; + $total_usd_received += $Montant ; + $total_usd_invoice += $Montant2_usd ; + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; + + } + if ( + 'Paiement sur site marchand reçu' eq $Type + and 'USD' eq $Devise + and 'Compensé' eq $Etat + ) { + $Montant =~tr/,/./; + #print "$Montant\n" ; + my $Montant2_usd; + $Montant2_usd = $Hors_taxe_paypal ; + $total_usd_received += $Montant ; + $total_usd_invoice += $Montant2_usd ; + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; + } + if ( + 'Paiement sur site marchand reçu' eq $Type + and 'EUR' eq $Devise + and 'Terminé' eq $Etat + ) { + $Montant =~tr/,/./; + #print "$Montant\n" ; + my $Montant2_eur; + $Montant2_eur = $Hors_taxe_paypal ; + $total_eur_received += $Montant ; + $total_eur_invoice += $Montant2_eur ; + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; + } + if ( + 'Paiement sur site marchand reçu' eq $Type + and 'EUR' eq $Devise + and 'Remboursé' eq $Etat + ) { + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $nb_invoice_refund++; + $invoice_refund{ $invoice }++ ; + + $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; + } + if ( + 'Paiement sur site marchand reçu' eq $Type + and 'EUR' eq $Devise + and 'Compensé' eq $Etat + ) { + $Montant =~tr/,/./; + #print "$Montant\n" ; + my $Montant2_eur; + $Montant2_eur = 21.99 if ( 20.88 == $Montant or 20.99 == $Montant ) ; + $Montant2_eur = 30 if ( 28.58 == $Montant or 28.73 == $Montant ) ; + $Montant2_eur = 110 if ( 105.46 == $Montant ) ; + #print "$Montant $Montant2_eur\n" ; + $total_eur_received += $Montant ; + $total_eur_invoice += $Montant2_eur ; + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; + } + if ( + 'Paiement sur site marchand reçu' eq $Type + and 'EUR' eq $Devise + and 'Non compensé' eq $Etat + ) { + $invoice = $first_invoice + $nb_invoice ; + $nb_invoice++ ; + $print_details and print ( "[$invoice] [$Date] [$Heure] [$Fuseau_horaire] [$Nom] [$Type] [$Etat] [$Devise] [$Montant] [$Numero_davis_de_reception] [$Solde]\n" ) ; + } + + $action->{ 'invoice' } = $invoice ; + if ( $bnc ) { + my $FR_flag = '' ; + $FR_flag = ' FR' if $Pays eq 'France' ; + my $IND_flag = '' ; + $IND_flag = ' IND' if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) ; + print "FE $invoice$FR_flag$IND_flag\n" ; + print "Facture $invoice imapsync$FR_flag $Nom\n" ; + printf( "%.2f [EUR %.2f]\n", $Montant, $MontantEUR ) ; + } +} + +sub build_invoice { + my $invoice = shift ; + + return if ! $invoice ; + + my $action = $action_of_invoice{ $invoice } ; + my $refund = '' ; + $refund = 'REFUND ' if $invoice_refund{ $invoice } ; + my %action = %$action if $action ; + #print Data::Dumper->Dump( [$action] ) ; + + my( $Date, $Heure, $Nom, $Type, $Etat, $Devise, $Hors_taxe, $Commission, $Net, + $De_l_adresse_email, $A_l_adresse_email, $N_de_transaction, $Titre_de_l_objet, + $TVA, $Nom_Option_1, $Valeur_Option_1, $N_de_transaction_de_reference, + $Adresse_1, $Adresse_2_district_quartier, $Ville, + $Etat_Province, $Code_postal, $Pays, $line_number, $line_csv, $file_csv ) + = @action{ ( 'Date', 'Heure', 'Nom', 'Type', 'Etat', 'Devise', 'Hors taxe', 'Commission', 'Net', + "De l'adresse email", "A l'adresse email", 'N° de transaction', "Titre de l'objet", + 'TVA', 'Nom Option 1', 'Valeur Option 1', 'Nº de transaction de référence', + 'Adresse 1', 'Adresse 2/district/quartier', 'Ville', + 'Etat/Province/Région/Comté/Territoire/Préfecture/République', 'Code postal', 'Pays', 'line_number', 'line_csv', 'file_csv' ) } ; + + #print "$Hors_taxe $Devise\n" ; + my $Hors_taxe_num = $Hors_taxe ; + $Hors_taxe_num =~ s{,}{.} ; + if ($Hors_taxe_num > 100) { + print "invoice $invoice $Hors_taxe_num > 100\n" ; + #return() ; + } + + my ( $email_message_header, $email_message_body ) + = build_email_message( $Date, $Nom, $De_l_adresse_email, $invoice ) ; + if ( $write_invoices ) { + write_email_message( $dir_invoices, $invoice, + $email_message_header, $email_message_body, + $De_l_adresse_email) ; + write_csv_info( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) ; + } + + + + #print "==== $invoice $refund=================================================" ; + #print $email_message ; + + my( + $clientAdrA, + $clientAdrB, + $clientAdrC, + $clientAdrD, + $clientAdrE, + $clientAdrF, + ) + = build_adress( + $Nom, + $Adresse_1, + $Adresse_2_district_quartier, + $Ville, + $Code_postal, + $Etat_Province, + $Pays, + ) ; + + foreach my $str ( + $De_l_adresse_email, + $Nom, + $clientAdrA, + $clientAdrB, + $clientAdrC, + $clientAdrD, + $clientAdrE, + $clientAdrF, + ) { + $str =~ s{#}{\\#}g ; + $str =~ s{_}{\\_}g ; + $str =~ s{&}{\\&}g ; + } + + my ( $clientTypeEN, $clientTypeFR ) = client_type( $Nom_Option_1, $Valeur_Option_1 ) ; + + my ( + $priceHT, + $tvaFR, + $tvaEN, + $priceTVA, + $priceTTC, + $messageTVAFR, + $messageTVAEN, + $priceTTCusd + ) + = tva_stuff( $clientTypeEN, $Pays, $Hors_taxe, $Devise ) ; + + my ( $urlSrc, $urlExe ) = download_urls( $Date ) ; + my $tex_variables = qq{ +%% Begin input from $0 +\\providecommand{\\invoiceNumber}{$invoice} +\\providecommand{\\clientName}{$Nom} +\\providecommand{\\clientEmail}{$De_l_adresse_email} +\\providecommand{\\clientTypeEN}{$clientTypeEN} +\\providecommand{\\clientTypeFR}{$clientTypeFR} +\\providecommand{\\clientAdrA}{$clientAdrA} +\\providecommand{\\clientAdrB}{$clientAdrB} +\\providecommand{\\clientAdrC}{$clientAdrC} +\\providecommand{\\clientAdrD}{$clientAdrD} +\\providecommand{\\clientAdrE}{$clientAdrE} +\\providecommand{\\clientAdrF}{$clientAdrF} +\\providecommand{\\invoiceDate}{$Date} +\\providecommand{\\invoiceHour}{$Heure} +\\providecommand{\\priceHT}{$priceHT} +\\providecommand{\\tvaFR}{$tvaFR} +\\providecommand{\\tvaEN}{$tvaEN} +\\providecommand{\\priceTVA}{$priceTVA} +\\providecommand{\\priceTTC}{$priceTTC} +\\providecommand{\\priceTTCusd}{$priceTTCusd} +\\providecommand{\\messageTVAFR}{$messageTVAFR} +\\providecommand{\\messageTVAEN}{$messageTVAEN} +\\providecommand{\\urlSrc}{\\url{$urlSrc}} +\\providecommand{\\urlExe}{\\url{$urlExe}} +%% End input from $0 +} ; + + + #print $tex_variables ; + + write_tex_variables_file( $dir_invoices, + $invoice, $Date, $tex_variables ) if $write_invoices ; + +} + +sub build_email_message { + + my ( $date, $name, $email, $invoice ) = @_ ; + + my $message_header = qq{X-imapsync: invoice $invoice +From: Gilles LAMIRAL +Bcc: gilles\@lamiral.info +Subject: [imapsync invoice] $invoice ($date) +Disposition-Notification-To: Gilles LAMIRAL +} ; + + +my $message_body = qq{ +Hello $name, + +First I'm sorry for the delay to prepare and send you this message. + +Attached is the invoice of imapsync software you bought ($date). +The invoice file is named facture_imapsync-${invoice}.pdf +This invoice is in PDF format, ready to be print. + +If you need this invoice on paper, just ask me then +I will send it to you by postal mail. + +In order to respect the law, this numeric invoice PDF +file is signed with my private gpg key. + +The resulting gpg signature is in the file named +facture_imapsync-${invoice}.pdf.asc +also attached in this email message. + +You can verify I (Gilles LAMIRAL) really generated +this invoice with the following command line + + gpg --verify facture_imapsync-${invoice}.pdf.asc facture_imapsync-${invoice}.pdf + +or any other gpg graphical tool. + +I thank you again for buying and using imapsync. + +Any feedback is welcome. + +-- +Au revoir, 09 51 84 42 42 +Gilles Lamiral. France, Baulon (35580) 06 20 79 76 06 +} ; + +my $message_body_blabla = qq{ +Here is the fingerprint of my public key +pub 1024D/FDA2B3DC 2002-05-08 + Key fingerprint = 7906 F53D 0D62 0C67 304A 4CF0 6928 869B FDA2 B3DC +uid Gilles LAMIRAL +sub 1024g/A2C4CB42 2002-05-08 + +Of course the verification doesn't prove anything until +all the following conditions are met: +- you met me, +- I agree that the fingerprint above is really mine +- I prove I'm Gilles LAMIRAL with an official paper. + +Normally we won't have to verify anything unless +I disagree with this invoice and the payment +you made for imapsync. +} ; + +return( $message_header, $message_body ) ; + +} + +sub write_csv_info { + + my( $dir_invoices, $invoice, $file_csv, $line_number, $line_csv ) = @_ ; + + open( CSVINFO, "> $dir_invoices/$invoice/csv_info.txt") or die ; + print CSVINFO join( "\n", $file_csv, $line_number, $line_csv ) ; + close( CSVINFO ) ; + +} + +sub write_email_message { + my ( $dir_invoices, $invoice, $message_header, $message_body, $email_address ) = @_ ; + + my $message_body_utf8 = to_utf8({ -string => $message_body, -charset => 'ISO-8859-1' }); + + mkdir( "$dir_invoices/$invoice" ) or die if ! -d "$dir_invoices/$invoice" ; + + open( HEADER, "> $dir_invoices/$invoice/facture_message_header.txt") or die ; + print HEADER $message_header ; + close( HEADER ) ; + + open( BODY, "> $dir_invoices/$invoice/facture_message_body.txt") or die ; + print BODY $message_body_utf8 ; + close( BODY ) ; + + open( ADDRESS, "> $dir_invoices/$invoice/email_address.txt") or die ; + print ADDRESS "$email_address\n" ; + close( ADDRESS ) ; +} + + +sub write_tex_variables_file { + my ( $dir_invoices, $invoice, $date_jjSmmSaaaa, $tex_variables ) = @_ ; + + my $tex_variables_utf8 = to_utf8({ -string => $tex_variables, -charset => 'ISO-8859-1' }); + mkdir( "$dir_invoices/$invoice" ) or die if ! -d "$dir_invoices/$invoice" ; + open( FILE, "> $dir_invoices/$invoice/imapsync_var.tex") or die ; + print FILE $tex_variables_utf8 ; + close( FILE ) ; + +} + +sub download_urls { + my $date_jjSmmSaaaa = shift ; + + my $date_aaaa_mm_jj = date_aaaa_mm_jj( $date_jjSmmSaaaa ) ; + # print "$date_aaaa_mm_jj $date_jjSmmSaaaa\n" ; + my ( $urlSrc, $urlExe ) ; + + if ('2011_03_24' le $date_aaaa_mm_jj) { + $urlSrc = 'http://www.linux-france.org/prj/imapsync/paypal_return.shtml' ; + $urlExe = '' ; + return( $urlSrc, $urlExe ) ; + } + if ('2011_02_21' le $date_aaaa_mm_jj) { + $urlSrc = 'http://www.linux-france.org/depot/2011_02_21/OUMbo7/' ; + $urlExe = 'http://www.linux-france.org/depot/2011_02_21/rHSVNs/' ; + return( $urlSrc, $urlExe ) ; + } + if ('2011_01_18' le $date_aaaa_mm_jj) { + $urlSrc = 'http://www.linux-france.org/depot/2011_01_18/zPRRNt/' ; + $urlExe = 'http://www.linux-france.org/depot/2011_01_18/FO1QzG/' ; + return( $urlSrc, $urlExe ) ; + } + if ('2011_01_18' le $date_aaaa_mm_jj) { + $urlSrc = 'http://www.linux-france.org/depot/2010_11_28/SiNdlZ/' ; + $urlExe = 'http://www.linux-france.org/depot/2010_11_28/R3ZAyr/' ; + return( $urlSrc, $urlExe ) ; + } + $urlSrc = 'http://www.linux-france.org/depot/2010_11_08/X2PWMe/' ; + $urlExe = 'http://www.linux-france.org/depot/2010_11_08/ZZ7zSc/' ; + return( $urlSrc, $urlExe ) ; +} + +sub date_aaaa_mm_jj { + my $date_jjSmmSaaaa = shift ; + + if ( $date_jjSmmSaaaa =~ m{(\d\d)/(\d\d)/(\d\d\d\d)} ) { + my( $jj, $mm, $aaaa ) = ( $1, $2, $3 ) ; + return( join( '_', $aaaa, $mm, $jj ) ) ; + }else{ + return( '9999_12_31' ) ; + } +} + +sub tva_stuff { + my( $clientTypeEN, $Pays, $Hors_taxe, $Devise ) = @_ ; + + my $priceTTCusd = '' ; + $Hors_taxe =~ s{,}{.} ; + + if ( $Devise eq 'USD' ) { + $priceTTCusd = "(USD $Hors_taxe)" ; + $Hors_taxe = ( $Hors_taxe/$usdeur ) ; + } + + my ( + $priceHT, + $tvaFR, + $tvaEN, + $priceTVA, + $priceTTC, + $messageTVAFR, + $messageTVAEN, + ) ; + + if ( ( 'individual' eq $clientTypeEN) + or + ( 'France' eq $Pays ) + ) { + $priceHT = sprintf('%2.2f', $Hors_taxe/1.196) ; + $tvaFR = '19,60\%'; + $tvaEN = ''; + $priceTVA = sprintf('%2.2f', $Hors_taxe/1.196*0.196) ; + $priceTTC = sprintf('%2.2f', $Hors_taxe) ; + $messageTVAFR = ''; + $messageTVAEN = ''; + }else{ + $priceHT = sprintf('%2.2f', $Hors_taxe) ; + $tvaFR = 'néant'; + $tvaEN = '(none)'; + $priceTVA = 0 ; + $priceTTC = $priceHT; + $messageTVAFR = 'Exonération de TVA, article 259 B-1 du Code Général des Impôts'; + $messageTVAEN = '(VAT tax-exempt, article 259 B-1 French General Tax Code)'; + } + foreach my $price ( $priceHT, $priceTVA, $priceTTC, $priceTTCusd ) { + #print "[$price]\n" ; + $price =~ s{\.}{, } ; + } + return( + $priceHT, + $tvaFR, + $tvaEN, + $priceTVA, + $priceTTC, + $messageTVAFR, + $messageTVAEN, + $priceTTCusd + ) ; +} + +sub client_type { + my ( $Nom_Option_1, $Valeur_Option_1 ) = @_ ; + + my ( $clientTypeEN, $clientTypeFR ) = ( 'professional', 'professionnel' ) ; + + if ('imapsync usage' eq $Nom_Option_1 and 'individual' eq $Valeur_Option_1 ) { + $clientTypeEN = 'individual' ; + $clientTypeFR = 'individuel' ; + }elsif ('imapsync usage' eq $Nom_Option_1 and 'professional' eq $Valeur_Option_1 ) { + $clientTypeEN = 'professional' ; + $clientTypeFR = 'professionnel' ; + } + + return( $clientTypeEN, $clientTypeFR ) ; +} + +sub build_adress { + my( + $Nom, + $Adresse_1, + $Adresse_2_district_quartier, + $Ville, + $Code_postal, + $Etat_Province, + $Pays, + ) = @_ ; + + my $addr = " +=========================================================== +Nom $Nom +Adresse_1 $Adresse_1 +Adresse_2_district_quartier $Adresse_2_district_quartier +Ville Code_postal $Ville $Code_postal +Etat_Province $Etat_Province +Pays $Pays +" ; + #print $addr ; + + my @address ; + $Nom = '' if ( $Nom =~ m/^\s+$/ ) ; + push( @address, $Nom ) if $Nom ; + push( @address, $Adresse_1 ) if $Adresse_1 ; + push( @address, $Adresse_2_district_quartier ) if $Adresse_2_district_quartier ; + push( @address, "$Ville $Code_postal" ) if ( $Ville or $Code_postal ); + push( @address, $Etat_Province ) if $Etat_Province ; + push( @address, $Pays, ) if $Pays ; + + + my $clientAdrA = shift( @address ) || '' ; + my $clientAdrB = shift( @address ) || '' ; + my $clientAdrC = shift( @address ) || '' ; + my $clientAdrD = shift( @address ) || '' ; + my $clientAdrE = shift( @address ) || '' ; + my $clientAdrF = shift( @address ) || '' ; + +$addr = " +[$clientAdrA] +[$clientAdrB] +[$clientAdrC] +[$clientAdrD] +[$clientAdrE] +[$clientAdrF] +"; + #print $addr ; + + return( + $clientAdrA, + $clientAdrB, + $clientAdrC, + $clientAdrD, + $clientAdrE, + $clientAdrF, + ) ; +} diff --git a/paypal_reply/paypal_build_invoices b/paypal_reply/paypal_build_invoices new file mode 100644 index 0000000..98faf5c --- /dev/null +++ b/paypal_reply/paypal_build_invoices @@ -0,0 +1,83 @@ +#!/bin/sh + +# usage: sh paypal_build_invoices/g/var/paypal_invoices/??? + +cp /home/gilles/public_html/AGIL/factures/000/facture_imapsync-000.tex /g/var/paypal_invoices/ + +set -x +/g/public_html/imapsync/paypal_reply/paypal_bilan --write_invoices --first_in 147 /g/paypal/paypal_2010_11_complet.csv +/g/public_html/imapsync/paypal_reply/paypal_bilan --write_invoices --first_in 214 /g/paypal/paypal_2010_12_complet.csv +/g/public_html/imapsync/paypal_reply/paypal_bilan --write_invoices --first_in 294 /g/paypal/paypal_2011_01_complet.csv +/g/public_html/imapsync/paypal_reply/paypal_bilan --write_invoices --first_in 382 /g/paypal/paypal_2011_02_complet.csv +/g/public_html/imapsync/paypal_reply/paypal_bilan --write_invoices --first_in 473 /g/paypal/paypal_2011_03_complet.csv +set +x + +# USD de 147 à 340 +# EUR de 341 à ... + +# 20110413 Found problems with 189 199 249 258 263 359 537 +# 20110412 Found problems with 189 199 242 249 258 263 359 382 537 +# cen cen JAP cen cen cen cen TCH JAP +# cen +# 155 TVA 1,89 +# 171 TVA 4,42 +# 220 TVA 3,16 +# 225 TVA 3,16 +# 236 TVA 4,42 +# 298 TVA 3,16 +# 307 TVA 4,42 +# 312 TVA 4,42 +# 324 TVA 4,42 +# 351 TVA 4,92 +# 395 TVA 4,92 +# 408 TVA 4,92 +# 419 TVA 4,92 +# 432 TVA 4,92 +# 435 TVA 4,92 +# 452 TVA 4,92 +# 460 TVA 4,92 +# 461 TVA 4,92 +# 463 TVA 4,92 +# 464 TVA 4,92 +# 475 TVA 4,92 +# 487 TVA 4,92 +# 489 TVA 4,92 +# 502 TVA 4,92 +# 504 TVA 4,92 +# 511 TVA 4,92 +# 522 TVA 4,92 +# 523 TVA 4,92 +# 533 TVA 4,92 +# 537 TVA 4,92 +# 540 TVA 4,92 +# 543 TVA 4,92 +# 549 TVA 4,92 +# 551 TVA 4,92 +# 552 TVA 4,92 +# 556 TVA 4,92 +# 563 TVA 4,92 + +for d in "$@"; do + echo "==== $d ====" + cd $d + bd=`basename $d` + ln -f ../facture_imapsync-000.tex facture_imapsync-$bd.tex; + if ! pdflatex facture_imapsync-$bd.tex < /dev/null > /dev/null; then + echo "PB $bd" + if test -f facture_imapsync-${bd}_good.tex \ + && pdflatex facture_imapsync-${bd}_good.tex < /dev/null > /dev/null + then + ln -f facture_imapsync-${bd}_good.pdf facture_imapsync-$bd.pdf + echo "PB $bd solved with manual facture_imapsync-${bd}_good.tex" + PB_LIST_MANUAL="$PB_LIST_MANUAL $bd" + else + PB_LIST="$PB_LIST $bd" + rm -f facture_imapsync-$bd.pdf + continue + fi + fi + gpg --use-agent --armor --detach-sign --yes facture_imapsync-$bd.pdf +done + +echo "Found problems with $PB_LIST" +echo "Manual invoices for $PB_LIST_MANUAL" diff --git a/paypal_reply/paypal_build_reply b/paypal_reply/paypal_build_reply index ca1c72d..f112439 100755 --- a/paypal_reply/paypal_build_reply +++ b/paypal_reply/paypal_build_reply @@ -1,9 +1,10 @@ #!/usr/bin/perl -# $Id: paypal_build_reply,v 1.10 2011/02/02 22:31:41 gilles Exp gilles $ +# $Id: paypal_build_reply,v 1.12 2011/03/23 18:31:52 gilles Exp gilles $ use warnings; use strict; +use Getopt::Long; my ($msg_id_file, $msg_id); my ($amount, $name, $email); @@ -13,23 +14,39 @@ my ( $url_source, $url_exe, $url, $release, ); +my $help ; +my $debug ; + +my $numopt = scalar(@ARGV); +my $opt_ret = GetOptions( + "help" => \$help, + "debug!" => \$debug, +); + +usage() and exit if ($help or ! $numopt) ; + $msg_id_file = $ARGV[1]; $msg_id = firstline($msg_id_file); +$debug and print "Hi!\n" ; while(<>) { - next if ( ! /^(.*Num.+ro de transaction :.*)$/ ); + next if ( ! /^(.*Num.+ro de transaction.*)$/ ); $paypal_line = $1; $paypal_info = "===== Paypal id =====\n$paypal_line\n"; + $debug and print "$paypal_info" ; last; } - while(<>) { - next if ( ! /^Vous avez re.*paiement d'un montant de (.*) de la part de (.*) \((.*)\)/); - ($amount, $name, $email) = ($1, $2, $3); - last; + if ( /^Vous avez re.*paiement d'un montant de (.*) de la part de (.*) \((.*)\)/) { + ($amount, $name, $email) = ($1, $2, $3); + last; + } + if ( /^Vous avez re.*paiement d'un montant de (.*) de la part de (.*)/) { + ($amount, $name, $email) = ($1, "", $2); + last; + } } - $url_source = firstline('/g/var/paypal_reply/url_source'); $url_exe = firstline('/g/var/paypal_reply/url_exe'); $release = firstline('/g/var/paypal_reply/url_release'); @@ -37,18 +54,25 @@ $release = firstline('/g/var/paypal_reply/url_release'); #print "[$amount] [$name] [$email] [$paypal_line]\n"; - while(<>) { - next if ( ! /^Acheteur/ ); - $buyer .= "===== Acheteur =====\n"; - last; + if ( /^Acheteur/ ) { + $buyer .= "===== Acheteur =====\n"; + last; + } + if ( /^Informations sur l'acheteur/ ) { + $buyer .= "===== Acheteur =====\n"; + chomp( $name = <> ); + $buyer .= "$name\n" ; + last; + } } while(<>) { - $buyer .= $_ if ( ! /^Instructions/ ); - last if ( /^Instructions/ ); + $buyer .= $_ if ( ! /^-----------------------------------/ ); + last if ( /^-----------------------------------/ ); } + while(<>) { next if ( ! /^Description :(.*)/ ); $description = "===== Details =====\n"; @@ -57,13 +81,16 @@ while(<>) { } while(<>) { + $debug and print "LINE:$_" ; $description .= $_; last if ( /^Paiement envoy/ ); + last if ( /^N.*d'avis de r.*ception/ ); } + my $address = 'gilles.lamiral@laposte.net'; my $address2 = 'gilles@lamiral.info'; -my $rcstag = '$Id: paypal_build_reply,v 1.10 2011/02/02 22:31:41 gilles Exp gilles $'; +my $rcstag = '$Id: paypal_build_reply,v 1.12 2011/03/23 18:31:52 gilles Exp gilles $'; my $message = < \$password, "passfile=s" => \$passfile, "folder=s" => \$folder, + "search=s" => \@search, "help" => \$help, "delete!" => \$delete, "expunge!" => \$expunge, @@ -51,7 +53,10 @@ $imap->select($folder) or die "Error select folder [$folder] host [$host] user [ #my @uids = $imap->search('HEADER', 'SUBJECT',"=?windows-1252?Q?Avis_de_r=E9ception_d=27un_paiement?="); #my @uids = $imap->search('HEADER', 'Sender','sendmail@paypal.com'); -my @uids = $imap->search('TEXT', 'PP341'); +#my @uids = $imap->search('TEXT', 'PP341'); +print "@search\n" ; +@search = ('TEXT', 'PP341') if not @search ; +my @uids = $imap->search('HEADER', 'Sender','sendmail@paypal.com', @search ); print "Search: [@uids]\n"; foreach $msg (@uids) { diff --git a/paypal_reply/paypal_run_test b/paypal_reply/paypal_run_dev similarity index 71% rename from paypal_reply/paypal_run_test rename to paypal_reply/paypal_run_dev index b3f262c..1303460 100755 --- a/paypal_reply/paypal_run_test +++ b/paypal_reply/paypal_run_dev @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: paypal_run_test,v 1.1 2010/11/28 01:00:45 gilles Exp gilles $ +# $Id: paypal_run_dev,v 1.4 2011/03/23 19:08:30 gilles Exp gilles $ set -e #set -x @@ -8,7 +8,7 @@ set -e # Add path to commands at home PATH=$PATH:/g/public_html/imapsync/paypal_reply -PERL5LIB=/g/public_html/imapsync/Mail-IMAPClient-3.25/lib +PERL5LIB=/g/public_html/imapsync/Mail-IMAPClient-3.28/lib export PERL5LIB test -f /g/public_html/imapsync/paypal_reply/paypal_functions \ @@ -18,7 +18,7 @@ test -f /g/public_html/imapsync/paypal_reply/paypal_functions \ DATE_1=`date` echo "==== paypal_reply_test ====" -paypal_reply_test +paypal_reply_petite_dev "$@" echo diff --git a/paypal_reply/paypal_run_laposte b/paypal_reply/paypal_run_laposte index dad363d..1831206 100755 --- a/paypal_reply/paypal_run_laposte +++ b/paypal_reply/paypal_run_laposte @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: paypal_run_laposte,v 1.2 2010/11/28 05:27:12 gilles Exp gilles $ +# $Id: paypal_run_laposte,v 1.3 2011/03/23 17:02:39 gilles Exp $ set -e #set -x @@ -8,7 +8,7 @@ set -e # Add path to commands at home PATH=$PATH:/g/public_html/imapsync/paypal_reply -PERL5LIB=/g/public_html/imapsync/Mail-IMAPClient-3.25/lib +PERL5LIB=/g/public_html/imapsync/Mail-IMAPClient-3.28/lib export PERL5LIB test -f /g/public_html/imapsync/paypal_reply/paypal_functions \ diff --git a/paypal_reply/paypal_run_petite b/paypal_reply/paypal_run_petite index 742c0b3..5ed89d0 100755 --- a/paypal_reply/paypal_run_petite +++ b/paypal_reply/paypal_run_petite @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: paypal_run_petite,v 1.4 2010/12/14 15:40:13 gilles Exp gilles $ +# $Id: paypal_run_petite,v 1.5 2011/03/23 17:02:39 gilles Exp $ set -e #set -x @@ -8,7 +8,7 @@ set -e # Add path to commands at home PATH=$PATH:/g/public_html/imapsync/paypal_reply -PERL5LIB=/g/public_html/imapsync/Mail-IMAPClient-3.25/lib +PERL5LIB=/g/public_html/imapsync/Mail-IMAPClient-3.28/lib export PERL5LIB test -f /g/public_html/imapsync/paypal_reply/paypal_functions \ diff --git a/paypal_reply/paypal_send_invoices b/paypal_reply/paypal_send_invoices new file mode 100644 index 0000000..bad84bc --- /dev/null +++ b/paypal_reply/paypal_send_invoices @@ -0,0 +1,43 @@ +#!/bin/sh + +# usages: +# sh paypal_send_invoices /g/var/paypal_invoices/147 +# sh paypal_send_invoices /g/var/paypal_invoices/15? + + +send_invoice() { + test X"" = X"$1" && { echo "usage: send_invoice /g/var/paypal_invoices/147 vince@norestech.net"; return; } + d="$1" + echo "====== $d ======" + #echo + cd $d || return + bd=`basename $d` + #echo "$bd" + invoice="$bd" + test -f facture_imapsync-${invoice}.pdf || { echo NO facture_imapsync-${invoice}.pdf ; return; } + test -f facture_imapsync-${invoice}.pdf.asc || { echo NO facture_imapsync-${invoice}.pdf.asc ; return; } + test -f facture_message_header.txt || { echo NO facture_message_header.txt ; return; } + test -f facture_message_body.txt || { echo NO facture_message_body.txt ; return; } + test -f email_address.txt || { echo NO email_address.txt ; return; } + + email=${2:-`cat email_address.txt`} + > facture_message_to.txt + egrep '^To: ' facture_message_header.txt > /dev/null || echo "To: $email" > facture_message_to.txt + cat facture_message_header.txt facture_message_to.txt facture_message_body.txt > facture_message.txt + more facture_message.txt + + echo '====== END of message ======' + test -f "SENT_TO_$email" && { echo "Already SENT_TO_$email"; } + test -f "SENT_TO_$email" || acroread facture_imapsync-${invoice}.pdf& + echo "Send this invoice ${invoice} to $email?" + read r < /dev/tty + echo SAID "[$r]" + test X"$r" = Xy && { + echo | mutt -H facture_message.txt -a facture_imapsync-${invoice}.pdf facture_imapsync-${invoice}.pdf.asc -- + touch SENT_TO_$email + } +} + +for d in "$@"; do + send_invoice "$d" +done diff --git a/paypal_return.shtml b/paypal_return.shtml new file mode 100644 index 0000000..b3b049b --- /dev/null +++ b/paypal_return.shtml @@ -0,0 +1,113 @@ + + + + +imapsync download + + + + + + + + + + + + + + + + + + + + +

    imapsync download

    + +

    I thank you for buying Imapsync!

    + +

    The payment has been made and the transaction has been completed.
    +A receipt for your purchase has been emailed to you.
    +You may log into your account at www.paypal.com +to view details of this transaction. +

    + +

    You will find the latest imapsync source code release 1.404 at the following link:
    +http://www.linux-france.org/depot/2011_02_21/OUMbo7/ +

    + +

    You will find the latest imapsync.exe binary release 1.404 at the following link:
    +http://www.linux-france.org/depot/2011_02_21/rHSVNs/ +

    + +

    You will receive an invoice soon.

    + +

    Next imapsync releases will be available for one year without extra payment.
    +I will send you a message explaining how to get them

    + +

    I thank you again for buying and using imapsync, +I wish you successful imap transfers!

    + +

    imapsync homepage

    + +

    Gilles LAMIRAL
    +gilles.lamiral@laposte.net

    + +
    +

    + Valid XHTML 1.0 Strict + + + CSS Valide ! + +
    + + +This document last modified on
    +($Id: paypal_return.shtml,v 1.2 2011/03/24 01:21:27 gilles Exp gilles $) +

    + + + + + + + + + + diff --git a/paypal_return_support.shtml b/paypal_return_support.shtml new file mode 100644 index 0000000..4d0ea17 --- /dev/null +++ b/paypal_return_support.shtml @@ -0,0 +1,109 @@ + + + + +imapsync support + + + + + + + + + + + + + + + + + + + + +

    imapsync support

    + +

    I thank you for buying Imapsync support!

    + +

    The payment has been made and the transaction has been completed.
    +A receipt for your purchase has been emailed to you.
    +You may log into your account at www.paypal.com +to view details of this transaction. +

    + +

    You will receive an invoice soon.

    + +

    Now you can contact me (Gilles LAMIRAL) by email or phone

    +
      +
    • Email address: gilles.lamiral@laposte.net.
      • +
    • Professionnal phone number: +33 9 51 84 42 42 (in France) I can call you back for free in many countries.
      • +
    • Mobile phone number: +33 620 79 76 06 (in France).
      • +
    + +

    I thank you again for buying imapsync support, +I wish you successful imap transfers and I will help you until you reach this goal!

    + +

    imapsync homepage

    + +

    Gilles LAMIRAL
    +gilles.lamiral@laposte.net

    + +
    +

    + Valid XHTML 1.0 Strict + + + CSS Valide ! + +
    + + +This document last modified on
    +($Id: paypal_return_support.shtml,v 1.2 2011/04/19 13:09:12 gilles Exp gilles $) +

    + + + + + + + + + + diff --git a/test2.bat b/test2.bat index 63037d3..e23f935 100755 --- a/test2.bat +++ b/test2.bat @@ -3,5 +3,12 @@ REM $Id: test.bat,v 1.8 2011/01/15 06:30:33 gilles Exp gilles $ cd C:\msys\1.0\home\Admin\imapsync REM perl ./imapsync --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi --delete2 --expunge2 --folder INBOX -perl ./imapsync --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi --delete2 --expunge1 --expunge2 --folder INBOX --usecache +REM perl ./imapsync --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi --delete2 --expunge1 --expunge2 --folder INBOX --usecache + + + + +REM imapsync --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi --justfolders --nofoldersize --folder INBOX.yop.yap --sep1 / --regextrans2 "s,/,_," +imapsync --host1 p --user1 tata --passfile1 secret.tata --host2 p --user2 titi --passfile2 secret.titi --nofoldersize --folder INBOX.yop.yap --regexflag 's/\\Answered//g' --debug > out.txt + diff --git a/tests.sh b/tests.sh index 02891f0..0a17242 100644 --- a/tests.sh +++ b/tests.sh @@ -1,6 +1,6 @@ #!/bin/sh -# $Id: tests.sh,v 1.149 2011/02/21 02:13:52 gilles Exp gilles $ +# $Id: tests.sh,v 1.159 2011/04/20 01:18:40 gilles Exp gilles $ # Example 1: # CMD_PERL='perl -I./Mail-IMAPClient-3.25/lib' sh -x tests.sh @@ -24,7 +24,7 @@ CMD_PERL=${CMD_PERL:-'perl -I./Mail-IMAPClient-2.2.9'} # few debugging tests use: CMD_PERL_2xx='perl -I./Mail-IMAPClient-2.2.9' -CMD_PERL_3xx='perl -I./Mail-IMAPClient-3.27/lib' +CMD_PERL_3xx='perl -I./Mail-IMAPClient-3.28/lib' #### Shell pragmas @@ -922,7 +922,7 @@ ll_regex_flag() --host2 $HOST2 --user2 titi \ --passfile2 ../../var/pass/secret.titi \ --folder INBOX.yop.yap \ - --debug --regexflag 's/\\Answered/\\Seen/g' + --regexflag 's/\\Answered/\$Forwarded/g' echo 'rm -f /home/vmail/titi/.yop.yap/cur/*' } @@ -994,9 +994,9 @@ ll_tls_justlogin() { ll_tls_devel() { CMD_PERL='perl -I./Mail-IMAPClient-2.2.9' ll_justlogin ll_ssl_justlogin \ -&& CMD_PERL='perl -I./Mail-IMAPClient-3.27/lib' ll_justlogin ll_ssl_justlogin \ +&& CMD_PERL='perl -I./Mail-IMAPClient-3.28/lib' ll_justlogin ll_ssl_justlogin \ && CMD_PERL='perl -I./Mail-IMAPClient-2.2.9' ll_tls_justconnect ll_tls_justlogin \ -&& CMD_PERL='perl -I./Mail-IMAPClient-3.27/lib' ll_tls_justconnect ll_tls_justlogin +&& CMD_PERL='perl -I./Mail-IMAPClient-3.28/lib' ll_tls_justconnect ll_tls_justlogin } ll_tls() { @@ -1099,6 +1099,17 @@ ll_authuser() { --authuser2 titi } +ll_authuser_2() { + + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 $HOST2 --user2 anything \ + --passfile2 ../../var/pass/secret.titi \ + --justfoldersizes \ + --authuser2 titi --folder INBOX.lalala +} + ll_authmech_LOGIN() { @@ -1214,6 +1225,65 @@ xxxxx_gmail() { --justfolders --dry --prefix2 '[Gmail]/' } +xxxxx_gmail_2() { + + ! ping -c1 imap.gmail.com || $CMD_PERL ./imapsync \ + --host1 $HOST2 \ + --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 imap.gmail.com \ + --ssl2 \ + --user2 gilles.lamiral@gmail.com \ + --passfile2 ../../var/pass/secret.gilles_gmail \ + --nofoldersizes \ + --regextrans2 's,(.*),SMS,' +#--dry --prefix2 '[Gmail]/' +} + +xxxxx_gmail_3() { + + ! ping -c1 imap.gmail.com || $CMD_PERL ./imapsync \ + --host1 $HOST2 \ + --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 imap.gmail.com \ + --ssl2 \ + --user2 gilles.lamiral@gmail.com \ + --passfile2 ../../var/pass/secret.gilles_gmail \ + --nofoldersizes \ + --folder INBOX.few_emails --justfolders --debug \ + --regextrans2 's,few_emails,Gmail/Messages envoyes,' +} + +xxxxx_gmail_4() { + + ! ping -c1 imap.gmail.com || $CMD_PERL ./imapsync \ + --host1 $HOST2 \ + --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 imap.gmail.com \ + --ssl2 \ + --user2 gilles.lamiral@gmail.com \ + --passfile2 ../../var/pass/secret.gilles_gmail \ + --nofoldersizes \ + --folder INBOX.Sent \ + --regextrans2 's{Sent}{Gmail/Messages envoyes}' +} + +xxxxx_gmail_5_justlogin() { + + ! ping -c1 imap.gmail.com || $CMD_PERL ./imapsync \ + --host1 $HOST2 \ + --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 imap.gmail.com \ + --ssl2 \ + --user2 gilles.lamiral@gmail.com \ + --passfile2 ../../var/pass/secret.gilles_gmail \ + --justlogin +} + + gmail_xxxxx() { ! ping -c1 imap.gmail.com || $CMD_PERL ./imapsync \ @@ -1292,7 +1362,7 @@ allow3xx() { } noallow3xx() { - ! perl -I./Mail-IMAPClient-3.27/lib ./imapsync \ + ! perl -I./Mail-IMAPClient-3.28/lib ./imapsync \ --host1 $HOST1 --user1 tata \ --passfile1 ../../var/pass/secret.tata \ --host2 $HOST2 --user2 titi \ @@ -1480,6 +1550,59 @@ ll_useuid_nousecache() # specific tests ########################## +godaddy_1_justlogin() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 imap.secureserver.net --user2 migrationtest@overnightmac.com \ + --passfile2 ../../var/pass/secret.overnightmac --tls2 \ + --folder INBOX.oneemail --folder INBOX.few_emails +} + +mailenable_1() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 email.avonvalley.wilts.sch.uk --user2 "GLamiral" \ + --passfile2 ../../var/pass/secret.avonvalley \ + --sep2 / --prefix2 '' --useuid \ + --folder INBOX.Junk --folder INBOX.few_emails \ + --delete2 --expunge2 +} + +mailenable_2_justfolders() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 email.avonvalley.wilts.sch.uk --user2 "GLamiral" \ + --passfile2 ../../var/pass/secret.avonvalley \ + --sep2 / --prefix2 '' --useuid \ + --justfolders --exclude "Gmail" --exclude ' ' +} + + +mailenable_3_reverse() { + $CMD_PERL ./imapsync \ + --host2 $HOST1 --user2 tata \ + --passfile2 ../../var/pass/secret.tata \ + --host1 email.avonvalley.wilts.sch.uk --user1 "GLamiral" \ + --passfile1 ../../var/pass/secret.avonvalley \ + --sep1 / --prefix1 '' \ + --folder few_emails \ + --delete2 --expunge2 --debug --useuid +} + + + +bug_zero_byte() { + $CMD_PERL ./imapsync \ + --host1 buzon.us.es --user1 rafaeltovar \ + --passfile1 ../../var/pass/secret.rafaeltovar \ + --host2 $HOST2 --user2 titi \ + --passfile2 ../../var/pass/secret.titi \ + --folder INBOX --regextrans2 s/INBOX/INBOX.rafaeltovar/ +} + exchange_1() { $CMD_PERL ./imapsync \ --host1 $HOST1 --user1 tata \ @@ -1489,11 +1612,32 @@ exchange_1() { --folder INBOX.oneemail --folder INBOX.few_emails --folder INBOX -maxage 1 } +exchange_2() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 mail.ethz.ch --ssl2 --user2 glamiral \ + --passfile2 ../../var/pass/secret.ethz.ch \ + --folder INBOX.Junk --useuid +} + +exchange_3_delete2() { + $CMD_PERL ./imapsync \ + --host1 $HOST1 --user1 tata \ + --passfile1 ../../var/pass/secret.tata \ + --host2 mail.ethz.ch --ssl2 --user2 glamiral \ + --passfile2 ../../var/pass/secret.ethz.ch \ + --folder INBOX.Junk --useuid --delete2 +} + + + jong_1() { $CMD_PERL ./imapsync \ --host1 mail.y-publicaties.nl --user1 gillesl --passfile1 ../../var/pass/secret.jong \ --host2 $HOST2 --user2 titi --passfile2 ../../var/pass/secret.titi --sep1 / --prefix1 '' \ - --delete2 --expunge2 --folder INBOX --nofoldersizes + --delete2 --expunge2 --expunge1 --expunge \ + --foldersizes --folder Junk/2009 --useuid # --debugimap1 --dry } @@ -1502,7 +1646,7 @@ $CMD_PERL ./imapsync \ --host2 mail.y-publicaties.nl --user2 gillesl --passfile2 ../../var/pass/secret.jong \ --host1 $HOST2 --user1 gilles@est.belle --passfile1 ../../var/pass/secret.gilles_mbox \ --sep2 / --prefix2 '' \ - --folder INBOX.Junk.2009 --delete2 --expunge2 --debug > zzz 2>&1 + --folder INBOX.Junk.2009 --delete2 --expunge2 --expunge1 --expunge --useuid #--nofoldersizes # --debugimap1 --dry }