1#!/usr/bin/perl5.8.8 2 3# structure 4# pod documentation 5# pragmas 6# main program 7# global variables initialisation 8# default values 9# folder loop 10# subroutines 11# IMAPClient 2.2.9 overrides 12# IMAPClient 2.2.9 3.xx ads 13 14# pod documentation 15 16=pod 17 18=head1 NAME 19 20imapsync - IMAP synchronisation, sync, copy or migration tool. 21Synchronises mailboxes between two imap servers. 22Good at IMAP migration. More than 52 different IMAP server softwares 23supported with success, few failures. 24 25$Revision: 1.564 $ 26 27=head1 SYNOPSIS 28 29To synchronize imap account "foo" on "imap.truc.org" 30 to imap account "bar" on "imap.trac.org" 31 with foo password "secret1" 32 and bar password "secret2": 33 34 imapsync \ 35 --host1 imap.truc.org --user1 foo --password1 secret1 \ 36 --host2 imap.trac.org --user2 bar --password2 secret2 37 38=head1 INSTALL 39 40 imapsync works fine under any Unix OS with perl. 41 imapsync works fine under Windows (2000, XP, Vista, Seven) 42 with Strawberry Perl (5.10, 5.12 or higher) 43 or as a standalone binary software imapsync.exe 44 45imapsync can be available directly on the following distributions: 46FreeBSD, Debian, Ubuntu, Gentoo, Fedora, 47NetBSD, Darwin, Mandriva and OpenBSD. 48 49 Purchase latest imapsync at 50 http://imapsync.lamiral.info/ 51 52 You'll receive a link to a compressed tarball called imapsync-x.xx.tgz 53 where x.xx is the version number. Untar the tarball where 54 you want (on Unix): 55 56 tar xzvf imapsync-x.xx.tgz 57 58 Go into the directory imapsync-x.xx and read the INSTALL file. 59 The INSTALL file is also at 60 http://imapsync.lamiral.info/INSTALL 61 62 The freecode (was freshmeat) record is at 63 http://freecode.com/projects/imapsync 64 65=head1 USAGE 66 67 imapsync [options] 68 69To get a description of each option just run imapsync like this: 70 71 imapsync --help 72 imapsync 73 74The option list: 75 76 imapsync [--host1 server1] [--port1 <num>] 77 [--user1 <string>] [--passfile1 <string>] 78 [--host2 server2] [--port2 <num>] 79 [--user2 <string>] [--passfile2 <string>] 80 [--ssl1] [--ssl2] 81 [--tls1] [--tls2] 82 [--authmech1 <string>] [--authmech2 <string>] 83 [--proxyauth1] [--proxyauth2] 84 [--domain1] [--domain2] 85 [--authmd51] [--authmd52] 86 [--folder <string> --folder <string> ...] 87 [--folderrec <string> --folderrec <string> ...] 88 [--include <regex>] [--exclude <regex>] 89 [--prefix2 <string>] [--prefix1 <string>] 90 [--regextrans2 <regex> --regextrans2 <regex> ...] 91 [--sep1 <char>] 92 [--sep2 <char>] 93 [--justfolders] [--justfoldersizes] [--justconnect] [--justbanner] 94 [--syncinternaldates] 95 [--idatefromheader] 96 [--syncacls] 97 [--regexmess <regex>] [--regexmess <regex>] 98 [--maxsize <int>] 99 [--minsize <int>] 100 [--maxage <int>] 101 [--minage <int>] 102 [--search <string>] 103 [--search1 <string>] 104 [--search2 <string>] 105 [--skipheader <regex>] 106 [--useheader <string>] [--useheader <string>] 107 [--nouid1] [--nouid2] 108 [--usecache] 109 [--skipsize] [--allowsizemismatch] 110 [--delete] [--delete2] 111 [--expunge] [--expunge1] [--expunge2] [--uidexpunge2] 112 [--delete2folders] [--delete2foldersonly] [--delete2foldersbutnot] 113 [--subscribed] [--subscribe] [--subscribe_all] 114 [--nofoldersizes] [--nofoldersizesatend] 115 [--dry] 116 [--debug] [--debugimap][--debugimap1][--debugimap2] 117 [--timeout <int>] 118 [--split1] [--split2] 119 [--reconnectretry1 <int>] [--reconnectretry2 <int>] 120 [--noreleasecheck] 121 [--pidfile <filepath>] 122 [--tmpdir <dirpath>] 123 [--version] [--help] 124 [--tests] [--tests_debug] 125 126=cut 127# comment 128 129=pod 130 131=head1 DESCRIPTION 132 133The command imapsync is a tool allowing incremental and 134recursive imap transfer from one mailbox to another. 135 136By default all folders are transferred, recursively, all 137possible flags (\Seen \Answered \Flagged etc.) are synced too. 138 139We sometimes need to transfer mailboxes from one imap server to 140another. This is called migration. 141 142imapsync is a good tool because it reduces the amount 143of data transferred by not transferring a given message 144if it is already on both sides. Same headers 145and the transfer is done only once. All flags are 146preserved, unread will stay unread, read will stay read, 147deleted will stay deleted. You can stop the transfer at any 148time and restart it later, imapsync works well with bad 149connections. 150 151You can decide to delete the messages from the source mailbox 152after a successful transfer, it can be a good feature when migrating 153live mailboxes since messages will be only on one side. 154In that case, use the --delete option. Option --delete implies 155also option --expunge so all messages marked deleted on host1 156will be really deleted. 157(you can use --noexpunge to avoid this but I don't see any 158good real world scenario for the combinaison --delete --noexpunge). 159 160You can also just synchronize a mailbox B from another mailbox A 161in case you just want to keep a "live" copy of A in B. 162In that case --delete2 can be used, it deletes messages in host2 163folder B that are not in host1 folder A. 164 165imapsync is not adequate for maintaining two active imap accounts 166in synchronization where the user plays independently on both sides. 167Use offlineimap (written by John Goerzen) or mbsync (written by 168Michael R. Elkins) for 2 ways synchronizations. 169 170 171=head1 OPTIONS 172 173To get a description of each option just invoke: 174 175imapsync --help 176 177=head1 HISTORY 178 179I wrote imapsync because an enterprise (basystemes) paid me to install 180a new imap server without losing huge old mailboxes located on a far 181away remote imap server accessible by a low bandwidth link. The tool 182imapcp (written in python) could not help me because I had to verify 183every mailbox was well transferred and delete it after a good 184transfer. imapsync started life as a copy_folder.pl patch. 185The tool copy_folder.pl comes from the Mail-IMAPClient-2.1.3 perl 186module tarball source (in the examples/ directory of the tarball). 187 188=head1 EXAMPLE 189 190While working on imapsync parameters please run imapsync in 191dry mode (no modification induced) with the --dry 192option. Nothing bad can be done this way. 193 194To synchronize the imap account "buddy" (with password "secret1") 195on host "imap.src.fr" to the imap account "max" (with password "secret2") 196on host "imap.dest.fr": 197 198 imapsync --host1 imap.src.fr --user1 buddy --password1 secret1 \ 199 --host2 imap.dest.fr --user2 max --password2 secret2 200 201Then you will have max's mailbox updated from buddy's 202mailbox. 203 204=head1 SECURITY 205 206You can use --passfile1 instead of --password1 to give the 207password since it is safer. With --password1 option any user 208on your host can see the password by using the 'ps auxwwww' 209command. Using a variable (like $PASSWORD1) is also 210dangerous because of the 'ps auxwwwwe' command. So, saving 211the password in a well protected file (600 or rw-------) is 212the best solution. 213 214imasync is not totally protected against sniffers on the 215network since passwords may be transferred in plain text 216if CRAM-MD5 is not supported by your imap servers. Use 217--ssl1 (or --tls1) and --ssl2 (or --tls2) to enable 218encryption on host1 and host2. 219 220You may authenticate as one user (typically an admin user), 221but be authorized as someone else, which means you don't 222need to know every user's personal password. Specify 223--authuser1 "adminuser" to enable this on host1. In this 224case, --authmech1 PLAIN will be used by default since it 225is the only way to go for now. So don't use --authmech1 SOMETHING 226with --authuser1 "adminuser", it will not work. 227Same behavior with the --authuser2 option. 228Authenticate with an admin account must be supported by your 229imap server to work with imapsync. 230 231When working on Sun/iPlanet/Netscape IMAP servers you must use 232--proxyauth1 to enable administrative user to masquerade as another user. 233Can also be used on destination server with --proxyauth2 234 235You can authenticate with OAUTH when transfering from Google Apps. 236The consumer key will be the domain part of the --user, and the 237--password will be used as the consumer secret. It does not work 238with Google Apps free edition. 239 240=head1 EXIT STATUS 241 242imapsync will exit with a 0 status (return code) if everything went good. 243Otherwise, it exits with a non-zero status. 244 245So if you have an unreliable internet connection, you can use this loop 246in a Bourne shell: 247 248 while ! imapsync ...; do 249 echo imapsync not complete 250 done 251 252=head1 LICENSE 253 254imapsync is free, open, public but not always gratis software 255cover by the NOLIMIT Public License. 256See the LICENSE file included in the distribution or just read this 257simple sentence as it is the licence text: 258No limit to do anything with this work and this license. 259 260=head1 MAILING-LIST 261 262The public mailing-list may be the best way to get free support. 263 264To write on the mailing-list, the address is: 265<imapsync@linux-france.org> 266 267To subscribe, send any message (even empty) to: 268<imapsync-subscribe@listes.linux-france.org> 269then just reply to the confirmation message. 270 271To unsubscribe, send a message to: 272<imapsync-unsubscribe@listes.linux-france.org> 273 274To contact the person in charge for the list: 275<imapsync-request@listes.linux-france.org> 276 277The list archives are available at: 278http://www.linux-france.org/prj/imapsync_list/ 279So consider that the list is public, anyone 280can see your post. Use a pseudonym or do not 281post to this list if you want to stay private. 282 283Thank you for your participation. 284 285=head1 AUTHOR 286 287Gilles LAMIRAL <gilles.lamiral@laposte.net> 288 289Feedback good or bad is very often welcome. 290 291Gilles LAMIRAL earns his living by writing, installing, 292configuring and teaching free, open and often gratis 293softwares. It used to be "always gratis" but now it is 294"often" because imapsync is sold by its author, a good 295way to stay maintening and supporting free open public 296softwares (see the license) over decades. 297 298=head1 BUG REPORT GUIDELINES 299 300Help us to help you: follow the following guidelines. 301 302Report any bugs or feature requests to the public mailing-list 303or to the author. 304 305Before reporting bugs, read the FAQ, the README and the 306TODO files. http://imapsync.lamiral.info/ 307 308Upgrade to last imapsync release, maybe the bug 309is already fixed. 310 311Upgrade to last Mail-IMAPClient Perl module. 312http://search.cpan.org/dist/Mail-IMAPClient/ 313maybe the bug is already fixed. 314 315Make a good title with word "imapsync" in it (my spam filter won't filter it), 316Don't write an email title with just "imapsync" or "problem", 317a good title is made of keywords summary, not too long (one visible line). 318 319Don't write imapsync in uppercase in the email title, I'll 320then know you run Windows and you haven't read this README yet. 321 322Help us to help you: in your report, please include: 323 324 - imapsync version. 325 326 - output given with --debug --debugimap near the failure point. 327 Isolate a message or two in a folder 'BUG' and use 328 329 imapsync ... --folder 'BUG' --debug --debugimap 330 331 - imap server software on both side and their version number. 332 333 - imapsync with all the options you use, the full command line 334 you use (except the passwords of course). 335 336 - IMAPClient.pm version. 337 338 - the run context. Do you run imapsync.exe, a unix binary 339 or the perl script imapsync. 340 341 - operating system running imapsync. 342 343 - virtual software context (vmware, xen etc.) 344 345 - operating systems on both sides and the third side in case 346 you run imapsync on a foreign host from the both. 347 348Most of those values can be found as a copy/paste at the begining of the output, 349so a copy of the output is a very easy and very good debug report for me. 350 351One time in your life, read the paper 352"How To Ask Questions The Smart Way" 353http://www.catb.org/~esr/faqs/smart-questions.html 354and then forget it. 355 356=head1 IMAP SERVERS 357 358Failure stories reported with the following 3 imap servers: 359 360 - MailEnable 1.54 (Proprietary) but MailEnable 4.23 is supported. 361 - DBMail 0.9, 2.0.7 (GPL). But DBMail 1.2.1 is supported. 362 Patient and confident testers are welcome. 363 - Imail 7.04 (maybe). 364 - (2011) MDaemon 12.0.3 as host2 but MDaemon is supported as host1. 365 MDaemon is simply buggy with the APPEND IMAP command with 366 any IMAP email client. 367 - Hotmail since hotmail.com does not provide IMAP access 368 - Outlook.com since outlook.com does not provide IMAP access 369 370Success stories reported with the following 55 imap servers 371(software names are in alphabetic order): 372 373 - 1und1 H mimap1 84498 [host1] H mibap4 95231 [host1] 374 - a1.net imap.a1.net IMAP4 Ready [host1] 375 - Apple Server 10.6 Snow Leopard [host1] 376 - Archiveopteryx 2.03, 2.04, 2.09, 2.10 [host2], 3.0.0 [host2] 377 (OSL 3.0) http://www.archiveopteryx.org/ 378 - Atmail 6.x [host1] 379 - Axigen Mail Server Version 8.0.0 380 - BincImap 1.2.3 (GPL) (http://www.bincimap.org/) 381 - CommuniGatePro server (Redhat 8.0) (Solaris), CommuniGate Pro 5.2.17[host2] (CentOS 5.4) 382 - Courier IMAP 1.5.1, 2.2.0, 2.1.1, 2.2.1, 3.0.8, 3.0.3, 4.1.1 (GPL) 383 (http://www.courier-mta.org/) 384 - Critical Path (7.0.020) 385 - Cyrus IMAP 1.5, 1.6, 386 2.1, 2.1.15, 2.1.16, 2.1.18 387 2.2.1, 2.2.2-BETA, 2.2.3, 2.2.6, 2.2.10, 2.2.12, 2.2.13, 388 2.3-alpha (OSI Approved), 2.3.1, 2.3.7, 2.3.16 389 (http://asg.web.cmu.edu/cyrus/) 390 - David Tobit V8 (proprietary Message system). 391 - Deerfield VisNetic MailServer 5.8.6 [host1] (http://www.deerfield.net/products/visnetic-mailserver/) 392 - DBMail 1.2.1, 2.0.4, 2.0.9, 2.2rc1 (GPL) (http://www.dbmail.org/). 393 2.0.7 seems buggy. 394 - DBOX 2.41 System [host1] (http://www.dbox.handshake.de/). 395 - Deerfield VisNetic MailServer 5.8.6 [host1] 396 - dkimap4 [host1] 397 - Domino (Notes) 4.61 [host1], 6.5 [host1], 5.0.6, 5.0.7, 7.0.2, 6.0.2CF1, 398 7.0.1 [host1], 8.0.1 [host1], 8.5.2 [host2], 8.5.3 [host1] 399 - Dovecot 0.99.10.4, 0.99.14, 0.99.14-8.fc4, 1.0-0.beta2.7, 400 1.0.0 [dest/source] (LGPL) (http://www.dovecot.org/) 401 - Eudora WorldMail v2 402 - Gimap (Gmail imap) 403 - GMX IMAP4 StreamProxy. 404 - Groupwise IMAP (Novell) 6.x and 7.0. Buggy so see the FAQ. 405 - hMailServer 5.3.3 [host2], 4.4.1 [host1] (see FAQ) 406 - iPlanet Messaging server 4.15, 5.1, 5.2 407 - IMail 7.15 (Ipswitch/Win2003), 8.12, 11.03 [host1] 408 - Kerio 7.2.0 Patch 1 [host12], Kerio 8 [host1] 409 - Mail2World IMAP4 Server 2.5 [host1] (http://www.mail2world.com/) 410 - MailEnable 4.23 [host1] [host2], 4.26 [host1][host2], 5 [host1] 411 - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform), 412 9.6.5 [host1], 12 [host2], 12.0.3 [host1], 12.5.5 [host1], 413 - Mercury 4.1 (Windows server 2000 platform) 414 - Microsoft Exchange Server 5.5, 6.0.6249.0[host1], 6.0.6487.0[host1], 415 6.5.7638.1 [host2], 6.5 [host1], Exchange 2007 SP1 (with Update Rollup 2), 416 Exchange2007-EP-SP2, 417 Exchange 2010 RTM (Release to Manufacturing) [host2], 418 Exchange 2010 SP1 RU2[host2], 419 - Mirapoint, 4.1.9-GA [host1] 420 - Netscape Mail Server 3.6 (Wintel !) 421 - Netscape Messaging Server 4.15 Patch 7 422 - Office 365 [host1] [host2] 423 - OpenMail IMAP server B.07.00.k0 (Samsung Contact ?) 424 - OpenWave 425 - Oracle Beehive [host1] 426 - Qualcomm Worldmail (NT) 427 - QQMail IMAP4Server [host1] [host2] https://en.mail.qq.com/ 428 - Rockliffe Mailsite 5.3.11, 4.5.6 429 - Samsung Contact IMAP server 8.5.0 430 - Scalix v10.1, 10.0.1.3, 11.0.0.431, 11.4.6 431 - SmarterMail, Smarter Mail 5.0 Enterprise, Smarter Mail 5.5 [host1], SmarterMail Professional 10.2 [host1]. 432 - Softalk Workgroup Mail 7.6.4 [host1]. 433 - SunONE Messaging server 5.2, 6.0 (SUN JES - Java Enterprise System) 434 - Sun Java(tm) System Messaging Server 6.2-2.05, 6.2-7.05, 6.3 435 - Surgemail 3.6f5-5, 6.3d-72 [host2] 436 - UW-imap servers (imap-2000b) rijkkramer IMAP4rev1 2000.287 437 (RedHat uses UW like 2003.338rh), v12.264 Solaris 5.7 (OSI Approved) 438 (http://www.washington.edu/imap/) 439 - UW - QMail v2.1 440 - VMS, Imap part of TCP/IP suite of VMS 7.3.2 441 - Yahoo [host1] 442 - Zarafa 6,40,0,20653 [host1] (http://www.zarafa.com/) 443 - Zarafa ZCP 7.1.4 IMAP Gateway [host2] 444 - Zimbra-IMAP 3.0.1 GA 160, 3.1.0 Build 279, 4.0.5, 4.5.2, 4.5.6, 445 Zimbra 5.0.24_GA_3356.RHEL4 [host1], 5.5, 6.x 446 447Please report to the author any success or bad story with 448imapsync and do not forget to mention the IMAP server 449software names and version on both sides. This will help 450future users. To help the author maintaining this section 451report the two lines at the begining of the output if they 452are useful to know the softwares. Example: 453 454 Host1 software:* OK louloutte Cyrus IMAP4 v1.5.19 server ready 455 Host2 software:* OK Courier-IMAP ready 456 457You can use option --justconnect to get those lines. 458Example: 459 460 imapsync --host1 imap.troc.org --host2 imap.trac.org --justconnect 461 462 463=head1 HUGE MIGRATION 464 465Pay special attention to options 466--subscribed 467--subscribe 468--delete 469--delete2 470--delete2folders 471--maxage 472--minage 473--maxsize 474--useuid 475--usecache 476 477If you have many mailboxes to migrate think about a little 478shell program. Write a file called file.txt (for example) 479containing users and passwords. 480The separator used in this example is ';' 481 482The file.txt file contains: 483 484user001_1;password001_1;user001_2;password001_2 485user002_1;password002_1;user002_2;password002_2 486user003_1;password003_1;user003_2;password003_2 487user004_1;password004_1;user004_2;password004_2 488user005_1;password005_1;user005_2;password005_2 489... 490 491On Unix the shell program can be: 492 493 { while IFS=';' read u1 p1 u2 p2; do 494 imapsync --host1 imap.side1.org --user1 "$u1" --password1 "$p1" \ 495 --host2 imap.side2.org --user2 "$u2" --password2 "$p2" ... 496 done ; } < file.txt 497 498On Windows the batch program can be: 499 500 FOR /F "tokens=1,2,3,4 delims=; eol=#" %%G IN (file.txt) DO imapsync ^ 501 --host1 imap.side1.org --user1 %%G --password1 %%H ^ 502 --host2 imap.side2.org --user2 %%I --password2 %%J ... 503 504The ... have to be replaced by nothing or any imapsync option. 505 506Welcome in shell programming ! 507 508=head1 Hacking 509 510Feel free to hack imapsync as the NOLIMIT license permits it. 511 512=head1 Links 513 514Entries for imapsync: 515 http://www.imap.org/products/showall.php 516 517 518=head1 SIMILAR SOFTWARES 519 520 imap_tools : http://www.athensfbc.com/imap_tools 521 offlineimap : https://github.com/nicolas33/offlineimap 522 mbsync : http://isync.sourceforge.net/ 523 mailsync : http://mailsync.sourceforge.net/ 524 mailutil : http://www.washington.edu/imap/ 525 part of the UW IMAP tookit. 526 imaprepl : http://www.bl0rg.net/software/ 527 http://freecode.com/projects/imap-repl/ 528 imapcopy : http://home.arcor.de/armin.diehl/imapcopy/imapcopy.html 529 migrationtool : http://sourceforge.net/projects/migrationtool/ 530 imapmigrate : http://sourceforge.net/projects/cyrus-utils/ 531 wonko_imapsync: http://wonko.com/article/554 532 see also file W/tools/wonko_ruby_imapsync 533 exchange-away : http://exchange-away.sourceforge.net/ 534 pop2imap : http://www.linux-france.org/prj/pop2imap/ 535 536 537Feedback (good or bad) will often be welcome. 538 539$Id: imapsync,v 1.564 2013/08/18 19:28:47 gilles Exp gilles $ 540 541=cut 542 543 544# pragmas 545 546use strict; 547use warnings; 548++$|; 549use Carp; 550use Getopt::Long; 551use Mail::IMAPClient 3.29 ; 552use Digest::MD5 qw( md5 md5_hex md5_base64 ); 553use Digest::HMAC_SHA1 qw( hmac_sha1 ) ; 554#use Term::ReadKey; 555#use IO::Socket::SSL; 556use MIME::Base64; 557use English '-no_match_vars' ; 558use File::Basename; 559use POSIX qw(uname SIGALRM); 560use Fcntl; 561use File::Spec; 562use File::Path qw(mkpath rmtree); 563use IO::Socket qw(:crlf SOL_SOCKET SO_KEEPALIVE); 564use Errno qw(EAGAIN EPIPE ECONNRESET); 565use File::Glob qw( :glob ) ; 566use IO::File; 567use Time::Local ; 568use Time::HiRes qw( time ) ; 569use Test::More 'no_plan' ; 570use IPC::Open3 'open3' ; 571#use Unix::Sysexits ; 572 573# global variables 574 575my( 576 $rcs, $pidfile, $pidfilelocking, 577 $debug, $debugimap, $debugimap1, $debugimap2, $debugcontent, $debugflags, 578 $debugLIST, $debugsleep, $debugdev, 579 $nb_errors, 580 $host1, $host2, $port1, $port2, 581 $user1, $user2, $domain1, $domain2, 582 $password1, $password2, $passfile1, $passfile2, 583 @folder, @include, @exclude, @folderrec, 584 $prefix1, $prefix2, 585 @regextrans2, @regexmess, @regexflag, 586 $flagsCase, $filterflags, $syncflagsaftercopy, 587 $sep1, $sep2, 588 $syncinternaldates, 589 $idatefromheader, 590 $syncacls, 591 $fastio1, $fastio2, 592 $maxsize, $minsize, $maxage, $minage, 593 $exitwhenover, 594 $search, $search1, $search2, 595 $skipheader, @useheader, 596 $skipsize, $allowsizemismatch, $foldersizes, $foldersizesatend, $buffersize, 597 $delete, $delete2, $delete2duplicates, 598 $expunge, $expunge1, $expunge2, $uidexpunge2, $dry, 599 $justfoldersizes, 600 $authmd5, $authmd51, $authmd52, 601 $subscribed, $subscribe, $subscribe_all, 602 $version, $help, 603 $justconnect, $justfolders, $justbanner, 604 $fast, 605 606 $total_bytes_transferred, 607 $total_bytes_skipped, 608 $total_bytes_error, 609 $nb_msg_transferred, 610 $nb_msg_skipped, 611 $nb_msg_skipped_dry_mode, 612 $h1_nb_msg_duplicate, 613 $h2_nb_msg_duplicate, 614 $h1_nb_msg_noheader, 615 $h2_nb_msg_noheader, 616 $h1_total_bytes_duplicate, 617 $h2_total_bytes_duplicate, 618 $h1_nb_msg_deleted, 619 $h2_nb_msg_deleted, 620 621 $h1_bytes_processed, 622 $h1_nb_msg_processed, 623 $h1_nb_msg_at_start, $h1_bytes_start, 624 $h2_nb_msg_start, $h2_bytes_start, 625 $h1_nb_msg_end, $h1_bytes_end, 626 $h2_nb_msg_end, $h2_bytes_end, 627 628 $timeout, 629 $timestart, $timestart_int, $timeend, 630 $timebefore, 631 $ssl1, $ssl2, 632 $ssl1_SSL_version, $ssl2_SSL_version, 633 $tls1, $tls2, 634 $uid1, $uid2, 635 $authuser1, $authuser2, 636 $proxyauth1, $proxyauth2, 637 $authmech1, $authmech2, 638 $split1, $split2, 639 $reconnectretry1, $reconnectretry2, 640 $relogin1, $relogin2, 641 $tests, $test_builder, $tests_debug, 642 $allow3xx, $justlogin, 643 $tmpdir, 644 $releasecheck, 645 $max_msg_size_in_bytes, 646 $modules_version, 647 $delete2folders, $delete2foldersonly, $delete2foldersbutnot, 648 $usecache, $debugcache, $cacheaftercopy, 649 $wholeheaderifneeded, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess, 650 $addheader, 651 %h1, %h2, 652 $checkselectable, $checkmessageexists, 653 $expungeaftereach, 654 $abletosearch, 655 $showpasswords, 656 $fixslash2, 657 $messageidnodomain, 658 $fixInboxINBOX, 659 $maxlinelength, 660 $uidnext_default, 661); 662 663# main program 664 665# global variables initialisation 666 667$rcs = '$Id: imapsync,v 1.564 2013/08/18 19:28:47 gilles Exp gilles $ '; 668 669$total_bytes_transferred = 0; 670$total_bytes_skipped = 0; 671$total_bytes_error = 0; 672$nb_msg_transferred = 0; 673$nb_msg_skipped = $nb_msg_skipped_dry_mode = 0; 674$h1_nb_msg_deleted = $h2_nb_msg_deleted = 0; 675$h1_nb_msg_duplicate = $h2_nb_msg_duplicate = 0; 676$h1_nb_msg_noheader = $h2_nb_msg_noheader = 0; 677$h1_total_bytes_duplicate = $h2_total_bytes_duplicate = 0; 678 679 680$h1_nb_msg_at_start = $h1_bytes_start = 0 ; 681$h2_nb_msg_start = $h2_bytes_start = 0 ; 682$h1_nb_msg_processed = $h1_bytes_processed = 0 ; 683 684$h1_nb_msg_end = $h1_bytes_end = 0 ; 685$h2_nb_msg_end = $h2_bytes_end = 0 ; 686 687$nb_errors = 0; 688$max_msg_size_in_bytes = 0; 689 690my %month_abrev = ( 691 Jan => 0, 692 Feb => 1, 693 Mar => 2, 694 Apr => 3, 695 May => 4, 696 Jun => 5, 697 Jul => 6, 698 Aug => 7, 699 Sep => 8, 700 Oct => 9, 701 Nov => 10, 702 Dec => 11, 703); 704 705sub EX_USAGE { 706 # 64 on my linux box. 707 # See http://search.cpan.org/~jmates/Unix-Sysexits-0.02/lib/Unix/Sysexits.pm 708 return( 64 ) ; 709} 710 711 712# @ARGV will be eat by get_options() 713my @argv_copy = @ARGV; 714 715get_options(); 716 717# $SIG{ INT } = \&catch_continue ; 718local $SIG{ INT } = local $SIG{ QUIT } = local $SIG{ TERM } = \&catch_exit ; 719 720$timestart = time( ); 721$timestart_int = int( $timestart ) ; 722$timebefore = $timestart; 723 724my $timestart_str = localtime( $timestart ) ; 725print "Transfer started at $timestart_str\n"; 726 727$modules_version = defined($modules_version) ? $modules_version : 1; 728 729 730$releasecheck = defined($releasecheck) ? $releasecheck : 1; 731my $warn_release = ($releasecheck) ? check_last_release() : ''; 732 733# default values 734 735$tmpdir ||= File::Spec->tmpdir(); 736$pidfile ||= $tmpdir . '/imapsync.pid'; 737 738$pidfilelocking = defined( $pidfilelocking ) ? $pidfilelocking : 0 ; 739 740# allow Mail::IMAPClient 3.0.xx by default 741$allow3xx = defined($allow3xx) ? $allow3xx : 1; 742 743$wholeheaderifneeded = defined( $wholeheaderifneeded ) ? $wholeheaderifneeded : 1; 744 745# turn on RFC standard flags correction like \SEEN -> \Seen 746$flagsCase = defined( $flagsCase ) ? $flagsCase : 1 ; 747 748# Use PERMANENTFLAGS if available 749$filterflags = defined( $filterflags ) ? $filterflags : 1 ; 750 751# sync flags just after an APPEND, some servers ignore the flags given in the APPEND 752# like MailEnable IMAP server. 753# Off by default since it takes time. 754$syncflagsaftercopy = defined( $syncflagsaftercopy ) ? $syncflagsaftercopy : 0 ; 755 756 757 758# turn on relogin 5 by default 759$relogin1 = defined( $relogin1 ) ? $relogin1 : 5 ; 760$relogin2 = defined( $relogin2 ) ? $relogin2 : 5 ; 761 762if ( $fast ) { 763 # $useuid = 1 ; 764 # $foldersizes = 0 ; 765 # $foldersizesatend = 0 ; 766} 767 768# Activate --usecache if --useuid is set and no --nousecache 769$usecache = 1 if ( $useuid and ( ! defined( $usecache ) ) ) ; 770$cacheaftercopy = 1 if ( $usecache and ( ! defined( $cacheaftercopy ) ) ) ; 771 772$checkselectable = defined( $checkselectable ) ? $checkselectable : 1 ; 773$checkmessageexists = defined( $checkmessageexists ) ? $checkmessageexists : 0 ; 774$expungeaftereach = defined( $expungeaftereach ) ? $expungeaftereach : 1 ; 775$abletosearch = defined( $abletosearch ) ? $abletosearch : 1 ; 776$checkmessageexists = 0 if ( not $abletosearch ) ; 777$showpasswords = defined( $showpasswords ) ? $showpasswords : 0 ; 778$fixslash2 = defined( $fixslash2 ) ? $fixslash2 : 1 ; 779$fixInboxINBOX = defined( $fixInboxINBOX ) ? $fixInboxINBOX : 1 ; 780 781$delete2duplicates = 1 if ( $delete2 and ( ! defined( $delete2duplicates ) ) ) ; 782 783print banner_imapsync(@argv_copy); 784 785print "Temp directory is $tmpdir\n"; 786 787is_valid_directory($tmpdir); 788write_pidfile($pidfile) if ($pidfile); 789 790$modules_version and print "Modules version list:\n", modules_VERSION(), "\n"; 791 792check_lib_version() or 793 croak "imapsync needs perl lib Mail::IMAPClient release 3.25 or superior \n"; 794 795exit_clean(0) if ($justbanner); 796 797# By default, 100 at a time, not more. 798$split1 ||= 100; 799$split2 ||= 100; 800 801$host1 || missing_option("--host1") ; 802$port1 ||= ( $ssl1 ) ? 993 : 143; 803 804$host2 || missing_option("--host2") ; 805$port2 ||= ( $ssl2 ) ? 993 : 143; 806 807$debugimap1 = $debugimap2 = 1 if ( $debugimap ) ; 808$debug = 1 if ( $debugimap1 or $debugimap2 ) ; 809 810# By default, don't take size to compare 811$skipsize = (defined $skipsize) ? $skipsize : 1; 812 813$uid1 = defined($uid1) ? $uid1 : 1; 814$uid2 = defined($uid2) ? $uid2 : 1; 815 816$subscribe = defined($subscribe) ? $subscribe : 1; 817 818# Allow size mismatch by default 819$allowsizemismatch = defined($allowsizemismatch) ? $allowsizemismatch : 1; 820 821$delete2folders = 1 822 if ( defined( $delete2foldersbutnot ) or defined( $delete2foldersonly ) ) ; 823 824if ($justconnect) { 825 justconnect(); 826 exit_clean(0); 827} 828 829$user1 || missing_option("--user1"); 830$user2 || missing_option("--user2"); 831 832$syncinternaldates = defined($syncinternaldates) ? $syncinternaldates : 1; 833 834# Turn on expunge if there is not explicit option --noexpunge and option 835# --delete is given. 836# Done because --delete --noexpunge is very dangerous on the second run: 837# the Deleted flag is then synced to all previously transfered messages. 838# So --delete implies --expunge is a better usability default behaviour. 839if ($delete) { 840 if ( ! defined($expunge)) { 841 $expunge = 1; 842 } 843} 844 845if ( $uidexpunge2 and not Mail::IMAPClient->can( 'uidexpunge' ) ) { 846 print "Failure: uidexpunge not supported (IMAPClient release < 3.17), use --expunge2 instead\n" ; 847 exit_clean( 3 ) ; 848} 849 850if ( ( $delete2 or $delete2duplicates ) and not defined( $uidexpunge2 ) ) { 851 if ( Mail::IMAPClient->can( 'uidexpunge' ) ) { 852 print "Info: will act as --uidexpunge2\n" ; 853 $uidexpunge2 = 1 ; 854 }elsif ( not defined( $expunge2 ) ) { 855 print "Info: will act as --expunge2 (no uidexpunge support)\n" ; 856 $expunge2 = 1 ; 857 } 858} 859 860if ( $delete and $delete2 ) { 861 print "Warning: using --delete and --delete2 together is almost always a bad idea, exiting imapsync\n" ; 862 exit_clean( 4 ) ; 863} 864 865if ($idatefromheader) { 866 print "Turned ON idatefromheader, ", 867 "will set the internal dates on host2 from the 'Date:' header line.\n"; 868 $syncinternaldates = 0; 869} 870 871if ($syncinternaldates) { 872 print "Info: turned ON syncinternaldates, ", 873 "will set the internal dates (arrival dates) on host2 same as host1.\n"; 874}else{ 875 print "Info: turned OFF syncinternaldates\n"; 876} 877 878 879 880if (defined($authmd5) and ($authmd5)) { 881 $authmd51 = 1 ; 882 $authmd52 = 1 ; 883} 884 885if (defined($authmd51) and ($authmd51)) { 886 $authmech1 ||= 'CRAM-MD5'; 887} 888else{ 889 $authmech1 ||= $authuser1 ? 'PLAIN' : 'LOGIN'; 890} 891 892if (defined($authmd52) and ($authmd52)) { 893 $authmech2 ||= 'CRAM-MD5'; 894} 895else{ 896 $authmech2 ||= $authuser2 ? 'PLAIN' : 'LOGIN'; 897} 898 899$authmech1 = uc($authmech1); 900$authmech2 = uc($authmech2); 901 902if (defined $proxyauth1 && !$authuser1) { 903 missing_option("With --proxyauth1, --authuser1"); 904} 905 906if (defined $proxyauth2 && !$authuser2) { 907 missing_option("With --proxyauth2, --authuser2"); 908} 909 910$authuser1 ||= $user1; 911$authuser2 ||= $user2; 912 913print "Info: will try to use $authmech1 authentication on host1\n"; 914print "Info: will try to use $authmech2 authentication on host2\n"; 915 916$timeout = defined( $timeout ) ? $timeout : 120 ; 917print "Info: imap connexions timeout is $timeout seconds\n"; 918 919 920$syncacls = (defined($syncacls)) ? $syncacls : 0 ; 921$foldersizes = (defined($foldersizes)) ? $foldersizes : 1 ; 922$foldersizesatend = (defined($foldersizesatend)) ? $foldersizesatend : $foldersizes ; 923 924 925 926$fastio1 = (defined($fastio1)) ? $fastio1 : 0; 927$fastio2 = (defined($fastio2)) ? $fastio2 : 0; 928 929$reconnectretry1 = (defined($reconnectretry1)) ? $reconnectretry1 : 3; 930$reconnectretry2 = (defined($reconnectretry2)) ? $reconnectretry2 : 3; 931 932# Since select_msgs() returns no messages when uidnext does not return something 933# then $uidnext_default is never used. So I have to remove it. 934$uidnext_default = 999999 ; 935 936@useheader = ( "Message-Id", "Message-ID", "Received" ) unless ( @useheader ) ; 937 938my %useheader ; 939 940# Make a hash %useheader of each --useheader 'key' in uppercase 941for ( @useheader ) { $useheader{ uc( $_ ) } = undef } ; 942 943#require Data::Dumper ; 944#print Data::Dumper->Dump( [ \%useheader ] ) ; 945#exit ; 946 947print "Host1: IMAP server [$host1] port [$port1] user [$user1]\n"; 948print "Host2: IMAP server [$host2] port [$port2] user [$user2]\n"; 949 950$password1 || $passfile1 || do { 951 $password1 = ask_for_password($authuser1 || $user1, $host1) unless ($authmech1 eq "EXTERNAL"); 952}; 953 954$password1 = (defined($passfile1)) ? firstline ($passfile1) : $password1; 955 956#$password1 || $passfile1 || 'PREAUTH' eq $authmech1 || do { 957# $password1 = ask_for_password( $authuser1 || $user1, $host1 ) ; 958#} ; 959 960#$password1 = ( defined( $passfile1 ) ) ? firstline ( $passfile1 ) : $password1 ; 961 962$password2 || $passfile2 || 'PREAUTH' eq $authmech2 || do { 963 $password2 = ask_for_password( $authuser2 || $user2, $host2 ) ; 964} ; 965 966$password2 = ( defined( $passfile2 ) ) ? firstline ( $passfile2 ) : $password2 ; 967 968 969my $dry_message = '' ; 970$dry_message = "\t(not really since --dry mode)" if $dry ; 971 972$search1 ||= $search if ( $search ) ; 973$search2 ||= $search if ( $search ) ; 974 975 976if ( @regexmess ) { 977 my $string = regexmess( '' ) ; 978 # string undef means one of the eval regex was bad. 979 if ( not ( defined( $string ) ) ) { 980 die_clean( "Error: one of --regexmess option is bad, check it" ) ; 981 } 982} 983 984if ( @regexflag and not ( defined( flags_regex( '' ) ) ) ) { 985 die_clean( "Error: one of --regexmess option is bad, check it" ) ; 986} 987 988my $imap1 = (); 989my $imap2 = (); 990 991$debugimap1 and print "Host1 connection\n"; 992$imap1 = login_imap($host1, $port1, $user1, $domain1, $password1, 993 $debugimap1, $timeout, $fastio1, $ssl1, $tls1, 994 $authmech1, $authuser1, $reconnectretry1, 995 $proxyauth1, $uid1, $split1, 'Host1', $ssl1_SSL_version ); 996 997$debugimap2 and print "Host2 connection\n"; 998$imap2 = login_imap($host2, $port2, $user2, $domain2, $password2, 999 $debugimap2, $timeout, $fastio2, $ssl2, $tls2, 1000 $authmech2, $authuser2, $reconnectretry2, 1001 $proxyauth2, $uid2, $split2, 'Host2', $ssl2_SSL_version ); 1002 1003 1004$debug and print "Host1 Buffer I/O: ", $imap1->Buffer(), "\n"; 1005$debug and print "Host2 Buffer I/O: ", $imap2->Buffer(), "\n"; 1006 1007 1008 1009die_clean( 'Not authenticated on host1' ) unless $imap1->IsAuthenticated( ) ; 1010print "Host1: state Authenticated\n"; 1011die_clean( 'Not authenticated on host2' ) unless $imap2->IsAuthenticated( ) ; 1012print "Host2: state Authenticated\n"; 1013 1014print "Host1 capability: ", join(" ", @{ $imap1->capability_update() || [] }), "\n"; 1015print "Host2 capability: ", join(" ", @{ $imap2->capability_update() || [] }), "\n"; 1016 1017 1018exit_clean(0) if ($justlogin); 1019 1020# 1021# Folder stuff 1022# 1023 1024my ( 1025@h1_folders_all, %h1_folders_all, @h1_folders_wanted, %requested_folder, 1026%h1_subscribed_folder, %h2_subscribed_folder, 1027@h2_folders_all, %h2_folders_all, 1028@h2_folders_from_1_wanted, %h2_folders_from_1_wanted, 1029%h2_folders_from_1_several, 1030%h2_folders_from_1_all, 1031); 1032 1033 1034# Make a hash of subscribed folders in both servers. 1035 1036for ( $imap1->subscribed( ) ) { $h1_subscribed_folder{ $_ } = 1 } ; 1037for ( $imap2->subscribed( ) ) { $h2_subscribed_folder{ $_ } = 1 } ; 1038 1039# All folders on host1 and host2 1040@h1_folders_all = sort $imap1->folders(); 1041@h2_folders_all = sort $imap2->folders(); 1042 1043for ( @h1_folders_all ) { $h1_folders_all{ $_ } = 1 } ; 1044for ( @h2_folders_all ) { $h2_folders_all{ $_ } = 1 } ; 1045 1046if ( $fixInboxINBOX and ( my $reg = fix_Inbox_INBOX_mapping( \%h1_folders_all, \%h2_folders_all ) ) ) { 1047 #print "RRRRRR $reg\n" ; 1048 push( @regextrans2, $reg ) ; 1049} 1050 1051if (scalar(@folder) or $subscribed or scalar(@folderrec)) { 1052 # folders given by option --folder 1053 if (scalar(@folder)) { 1054 add_to_requested_folders(@folder); 1055 } 1056 1057 # option --subscribed 1058 if ( $subscribed ) { 1059 add_to_requested_folders( keys ( %h1_subscribed_folder ) ) ; 1060 } 1061 1062 # option --folderrec 1063 if (scalar(@folderrec)) { 1064 foreach my $folderrec (@folderrec) { 1065 add_to_requested_folders($imap1->folders($folderrec)); 1066 } 1067 } 1068} 1069else { 1070 # no include, no folder/subscribed/folderrec options => all folders 1071 if (not scalar(@include)) { 1072 add_to_requested_folders(@h1_folders_all); 1073 } 1074} 1075 1076 1077# consider (optional) includes and excludes 1078if ( scalar( @include ) ) { 1079 foreach my $include ( @include ) { 1080 my @included_folders = grep { /$include/x } @h1_folders_all ; 1081 add_to_requested_folders( @included_folders ) ; 1082 print "Including folders matching pattern '$include': @included_folders\n" ; 1083 } 1084} 1085 1086if ( scalar( @exclude ) ) { 1087 foreach my $exclude ( @exclude ) { 1088 my @requested_folder = sort( keys( %requested_folder ) ) ; 1089 my @excluded_folders = grep { /$exclude/x } @requested_folder ; 1090 remove_from_requested_folders( @excluded_folders ) ; 1091 print "Excluding folders matching pattern '$exclude': @excluded_folders\n" ; 1092 } 1093} 1094 1095# Remove no selectable folders 1096 1097$checkselectable and do { 1098 foreach my $folder (keys(%requested_folder)) { 1099 if ( not $imap1->selectable($folder)) { 1100 print "Warning: ignoring folder $folder because it is not selectable\n"; 1101 remove_from_requested_folders($folder); 1102 } 1103 } 1104} ; 1105 1106my @requested_folder = sort(keys(%requested_folder)); 1107 1108@h1_folders_wanted = @requested_folder; 1109 1110#my $h1_namespace = $imap1->namespace() ; 1111#my $h2_namespace = $imap2->namespace() ; 1112#require Data::Dumper ; 1113#$debug and print "Host1 namespace:\n", Data::Dumper->Dump([$h1_namespace]) ; 1114#$debug and print "Host2 namespace:\n", Data::Dumper->Dump([$h2_namespace]) ; 1115 1116my($h1_sep,$h2_sep); 1117# what are the private folders separators for each server ? 1118 1119$debug and print "Getting separators\n"; 1120$h1_sep = get_separator($imap1, $sep1, "--sep1"); 1121$h2_sep = get_separator($imap2, $sep2, "--sep2"); 1122 1123my($h1_prefix,$h2_prefix); 1124$h1_prefix = get_prefix($imap1, $prefix1, "--prefix1"); 1125$h2_prefix = get_prefix($imap2, $prefix2, "--prefix2"); 1126 1127 1128print "Host1 separator and prefix: [$h1_sep][$h1_prefix]\n"; 1129print "Host2 separator and prefix: [$h2_sep][$h2_prefix]\n"; 1130 1131#my $h1_xlist_folders = $imap1->xlist_folders( ) ; 1132#my $h2_xlist_folders = $imap2->xlist_folders( ) ; 1133#require Data::Dumper ; 1134#print "Host1 xlist:\n", Data::Dumper->Dump([$h1_xlist_folders]) ; 1135#print "Host2 xlist:\n", Data::Dumper->Dump([$h2_xlist_folders]) ; 1136 1137#exit ; 1138 1139foreach my $h1_fold ( @h1_folders_wanted ) { 1140 my $h2_fold ; 1141 $h2_fold = imap2_folder_name( $h1_fold ) ; 1142 $h2_folders_from_1_wanted{ $h2_fold }++ ; 1143 if ( 1 < $h2_folders_from_1_wanted{ $h2_fold } ) { 1144 $h2_folders_from_1_several{ $h2_fold }++ ; 1145 } 1146} 1147@h2_folders_from_1_wanted = sort keys(%h2_folders_from_1_wanted); 1148 1149foreach my $h1_fold (@h1_folders_all) { 1150 my $h2_fold; 1151 $h2_fold = imap2_folder_name($h1_fold); 1152 $h2_folders_from_1_all{$h2_fold}++; 1153} 1154 1155 1156if ( $foldersizes ) { 1157 ( $h1_nb_msg_at_start, $h1_bytes_start ) = foldersizes( "Host1", $imap1, $search1, @h1_folders_wanted ) ; 1158 ( $h2_nb_msg_start, $h2_bytes_start ) = foldersizes( "Host2", $imap2, $search2, @h2_folders_from_1_wanted ) ; 1159 $fast or sleep( 2 ) ; 1160} 1161 1162 1163exit_clean(0) if ($justfoldersizes); 1164 1165print 1166 "++++ Listing folders\n", 1167 "Host1 folders list:\n", map( { "[$_]\n" } @h1_folders_all ), "\n", 1168 "Host2 folders list:\n", map( { "[$_]\n" } @h2_folders_all ), "\n" ; 1169 1170print 1171 "Host1 subscribed folders list: ", 1172 map( { "[$_] " } sort keys( %h1_subscribed_folder ) ), "\n" 1173 if ( $subscribed ) ; 1174 1175my @h2_folders_not_in_1; 1176@h2_folders_not_in_1 = list_folders_in_2_not_in_1(); 1177 1178print "Folders in host2 not in host1:\n", 1179 map( { "[$_]\n" } @h2_folders_not_in_1 ), "\n" ; 1180 1181delete_folders_in_2_not_in_1() if $delete2folders; 1182 1183# folder loop 1184print "++++ Looping on each folder\n"; 1185 1186my $begin_transfer_time = time ; 1187 1188 1189my %uid_candidate_for_deletion ; 1190my %uid_candidate_no_deletion ; 1191 1192FOLDER: foreach my $h1_fold ( @h1_folders_wanted ) { 1193 1194 last FOLDER if $imap1->IsUnconnected(); 1195 last FOLDER if $imap2->IsUnconnected(); 1196 1197 my $h2_fold = imap2_folder_name( $h1_fold ) ; 1198 #relogin1( ) if ( $relogin1 ) ; 1199 printf( "%-35s -> %-35s\n", "[$h1_fold]", "[$h2_fold]" ) ; 1200 1201 # host1 can not be fetched read only, select is needed because of expunge. 1202 select_folder( $imap1, $h1_fold, 'Host1' ) or next FOLDER ; 1203 #examine_folder( $imap1, $h1_fold, 'Host1' ) or next FOLDER ; 1204 1205 1206 if ( ! exists( $h2_folders_all{ $h2_fold } ) ) { 1207 create_folder( $imap2, $h2_fold, $h1_fold ) or next FOLDER ; 1208 } 1209 1210 acls_sync( $h1_fold, $h2_fold ) ; 1211 1212 # Sometimes the folder on host2 is listed (it exists) but is 1213 # not selectable but becomes selectable by a create (Gmail) 1214 select_folder( $imap2, $h2_fold, 'Host2' ) 1215 or ( create_folder( $imap2, $h2_fold, $h1_fold ) 1216 and select_folder( $imap2, $h2_fold, 'Host2' ) ) 1217 or next FOLDER ; 1218 my @select_results = $imap2->Results( ) ; 1219 1220 #print "%%% @select_results\n" ; 1221 my $permanentflags2 = permanentflags( @select_results ) ; 1222 ( $debug or $debugflags ) and print "permanentflags: $permanentflags2\n" ; 1223 1224 if ( $expunge or $expunge1 ){ 1225 print "Expunging host1 $h1_fold $dry_message\n" ; 1226 unless($dry) { $imap1->expunge() } ; 1227 #print "Expunging host2 $h2_fold\n" ; 1228 #unless($dry) { $imap2->expunge() } ; 1229 } 1230 1231 if ( ( ( $subscribe and exists $h1_subscribed_folder{ $h1_fold } ) or $subscribe_all ) 1232 and not exists( $h2_subscribed_folder{ $h2_fold } ) ) { 1233 print "Subscribing to folder $h2_fold on destination server\n" ; 1234 unless( $dry ) { $imap2->subscribe( $h2_fold ) } ; 1235 } 1236 1237 next FOLDER if ($justfolders); 1238 1239 last FOLDER if $imap1->IsUnconnected(); 1240 last FOLDER if $imap2->IsUnconnected(); 1241 1242 my $h1_msgs_all_hash_ref = { } ; 1243 my @h1_msgs = select_msgs( $imap1, $h1_msgs_all_hash_ref, $search1, $h1_fold ); 1244 last FOLDER if $imap1->IsUnconnected(); 1245 1246 my $h1_msgs_nb = scalar( @h1_msgs ) ; 1247 $h1{ $h1_fold }{ 'messages_nb' } = $h1_msgs_nb ; 1248 1249 ( $debug or $debugLIST ) and print "Host1 LIST: $h1_msgs_nb messages [@h1_msgs]\n" ; 1250 $debug and print "Host1 selecting messages of folder [$h1_fold] took ", timenext(), " s\n"; 1251 1252 my $h2_msgs_all_hash_ref = { } ; 1253 my @h2_msgs = select_msgs( $imap2, $h2_msgs_all_hash_ref, $search2, $h2_fold ) ; 1254 last FOLDER if $imap2->IsUnconnected(); 1255 1256 my $h2_msgs_nb = scalar( @h2_msgs ) ; 1257 $h2{ $h2_fold }{ 'messages_nb' } = $h2_msgs_nb ; 1258 1259 ( $debug or $debugLIST ) and print "Host2 LIST: $h2_msgs_nb messages [@h2_msgs]\n"; 1260 $debug and print "Host2 selecting messages of folder [$h2_fold] took ", timenext(), " s\n"; 1261 1262 my $cache_base = "$tmpdir/imapsync_cache/$host1/$user1/$host2/$user2" ; 1263 my $cache_dir = cache_folder( $cache_base, $h1_fold, $h2_fold ) ; 1264 my ( $cache_1_2_ref, $cache_2_1_ref ) = ( {}, {} ) ; 1265 1266 my $h1_uidvalidity = $imap1->uidvalidity( ) || '' ; 1267 my $h2_uidvalidity = $imap2->uidvalidity( ) || '' ; 1268 1269 last FOLDER if $imap1->IsUnconnected() ; 1270 last FOLDER if $imap2->IsUnconnected() ; 1271 1272 if ( $usecache ) { 1273 print "cache directory: $cache_dir\n" ; 1274 mkpath( "$cache_dir" ) ; 1275 ( $cache_1_2_ref, $cache_2_1_ref ) 1276 = get_cache( $cache_dir, \@h1_msgs, \@h2_msgs, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; 1277 print "CACHE h1 h2: ", scalar( keys %$cache_1_2_ref ), " files\n" ; 1278 $debug and print '[', 1279 map ( { "$_->$cache_1_2_ref->{$_} " } keys %$cache_1_2_ref ), " ]\n"; 1280 } 1281 1282 my %h1_hash = (); 1283 my %h2_hash = (); 1284 1285 my ( %h1_msgs, %h2_msgs ) ; 1286 @h1_msgs{ @h1_msgs } = (); 1287 @h2_msgs{ @h2_msgs } = (); 1288 1289 my @h1_msgs_in_cache = sort { $a <=> $b } keys %$cache_1_2_ref ; 1290 my @h2_msgs_in_cache = keys %$cache_2_1_ref ; 1291 1292 my ( %h1_msgs_not_in_cache, %h2_msgs_not_in_cache ) ; 1293 %h1_msgs_not_in_cache = %h1_msgs ; 1294 %h2_msgs_not_in_cache = %h2_msgs ; 1295 delete @h1_msgs_not_in_cache{ @h1_msgs_in_cache } ; 1296 delete @h2_msgs_not_in_cache{ @h2_msgs_in_cache } ; 1297 1298 my @h1_msgs_not_in_cache = keys %h1_msgs_not_in_cache ; 1299 #print "h1_msgs_not_in_cache: [@h1_msgs_not_in_cache]\n" ; 1300 my @h2_msgs_not_in_cache = keys %h2_msgs_not_in_cache ; 1301 1302 my @h2_msgs_delete2_not_in_cache = () ; 1303 %h1_msgs_copy_by_uid = ( ) ; 1304 1305 if ( $useuid ) { 1306 # use uid so we have to avoid getting header 1307 @h1_msgs_copy_by_uid{ @h1_msgs_not_in_cache } = ( ) ; 1308 @h2_msgs_delete2_not_in_cache = @h2_msgs_not_in_cache if $usecache ; 1309 @h1_msgs_not_in_cache = ( ) ; 1310 @h2_msgs_not_in_cache = ( ) ; 1311 1312 #print "delete2: @h2_msgs_delete2_not_in_cache\n"; 1313 } 1314 1315 $debug and print "Host1 parsing headers of folder [$h1_fold]\n"; 1316 1317 my ($h1_heads_ref, $h1_fir_ref) = ({}, {}); 1318 $h1_heads_ref = $imap1->parse_headers([@h1_msgs_not_in_cache], @useheader) if (@h1_msgs_not_in_cache); 1319 $debug and print "Host1 parsing headers of folder [$h1_fold] took ", timenext(), " s\n"; 1320 1321 @$h1_fir_ref{@h1_msgs} = (undef); 1322 1323 $debug and print "Host1 getting flags idate and sizes of folder [$h1_fold]\n" ; 1324 if ( $abletosearch ) { 1325 $h1_fir_ref = $imap1->fetch_hash( \@h1_msgs, "FLAGS", "INTERNALDATE", "RFC822.SIZE", $h1_fir_ref ) 1326 if ( @h1_msgs ) ; 1327 }else{ 1328 my $uidnext = $imap1->uidnext( $h1_fold ) || $uidnext_default ; 1329 $h1_fir_ref = $imap1->fetch_hash( "1:$uidnext", "FLAGS", "INTERNALDATE", "RFC822.SIZE", $h1_fir_ref ) 1330 if ( @h1_msgs ) ; 1331 } 1332 $debug and print "Host1 getting flags idate and sizes of folder [$h1_fold] took ", timenext(), " s\n"; 1333 unless ($h1_fir_ref) { 1334 print 1335 "Host1 folder $h1_fold: Could not fetch_hash ", 1336 scalar(@h1_msgs), " msgs: ", $imap1->LastError || '', "\n"; 1337 $nb_errors++; 1338 next FOLDER; 1339 } 1340 1341 my @h1_msgs_duplicate; 1342 foreach my $m (@h1_msgs_not_in_cache) { 1343 my $rc = parse_header_msg($imap1, $m, $h1_heads_ref, $h1_fir_ref, 'Host1', \%h1_hash); 1344 if (! defined($rc)) { 1345 my $h1_size = $h1_fir_ref->{$m}->{"RFC822.SIZE"} || 0; 1346 print "Host1 $h1_fold/$m size $h1_size ignored (no wanted headers so we ignore this message. To solve this: use --addheader)\n" ; 1347 $total_bytes_skipped += $h1_size; 1348 $nb_msg_skipped += 1; 1349 $h1_nb_msg_noheader +=1; 1350 $h1_nb_msg_processed +=1 ; 1351 } elsif(0 == $rc) { 1352 # duplicate 1353 push(@h1_msgs_duplicate, $m); 1354 # duplicate, same id same size? 1355 my $h1_size = $h1_fir_ref->{$m}->{"RFC822.SIZE"} || 0; 1356 $nb_msg_skipped += 1; 1357 $h1_total_bytes_duplicate += $h1_size; 1358 $h1_nb_msg_duplicate += 1; 1359 $h1_nb_msg_processed +=1 ; 1360 } 1361 } 1362 my $h1_msgs_duplicate_nb = scalar( @h1_msgs_duplicate ) ; 1363 $h1{ $h1_fold }{ 'duplicates_nb' } = $h1_msgs_duplicate_nb ; 1364 1365 $debug and print "Host1 selected: $h1_msgs_nb duplicates: $h1_msgs_duplicate_nb\n" ; 1366 $debug and print "Host1 whole time parsing headers took ", timenext(), " s\n"; 1367 1368 $debug and print "Host2 parsing headers of folder [$h2_fold]\n"; 1369 1370 my ($h2_heads_ref, $h2_fir_ref) = ( {}, {} ); 1371 $h2_heads_ref = $imap2->parse_headers([@h2_msgs_not_in_cache], @useheader) if (@h2_msgs_not_in_cache); 1372 $debug and print "Host2 parsing headers of folder [$h2_fold] took ", timenext(), " s\n" ; 1373 1374 $debug and print "Host2 getting flags idate and sizes of folder [$h2_fold]\n" ; 1375 @$h2_fir_ref{@h2_msgs} = ( ); # fetch_hash can select by uid with last arg as ref 1376 1377 1378 if ( $abletosearch ) { 1379 $h2_fir_ref = $imap2->fetch_hash( \@h2_msgs, "FLAGS", "INTERNALDATE", "RFC822.SIZE", $h2_fir_ref) 1380 if (@h2_msgs) ; 1381 }else{ 1382 my $uidnext = $imap2->uidnext( $h2_fold ) || $uidnext_default ; 1383 $h2_fir_ref = $imap2->fetch_hash( "1:$uidnext", "FLAGS", "INTERNALDATE", "RFC822.SIZE", $h2_fir_ref ) 1384 if ( @h2_msgs ) ; 1385 } 1386 1387 $debug and print "Host2 getting flags idate and sizes of folder [$h2_fold] took ", timenext(), " s\n" ; 1388 1389 my @h2_msgs_duplicate; 1390 foreach my $m (@h2_msgs_not_in_cache) { 1391 my $rc = parse_header_msg($imap2, $m, $h2_heads_ref, $h2_fir_ref, 'Host2', \%h2_hash); 1392 my $h2_size = $h2_fir_ref->{$m}->{"RFC822.SIZE"} || 0; 1393 if (! defined($rc)) { 1394 print "Host2 $h2_fold/$m size $h2_size ignored (no wanted headers so we ignore this message)\n" ; 1395 $h2_nb_msg_noheader += 1 ; 1396 } elsif(0 == $rc) { 1397 # duplicate 1398 $h2_nb_msg_duplicate += 1; 1399 $h2_total_bytes_duplicate += $h2_size; 1400 push(@h2_msgs_duplicate, $m); 1401 } 1402 } 1403 my $h2_msgs_duplicate_nb = scalar( @h2_msgs_duplicate ) ; 1404 $h2{ $h2_fold }{ 'duplicates_nb' } = $h2_msgs_duplicate_nb ; 1405 1406 print "Host2 folder $h2_fold selected: $h2_msgs_nb messages, duplicates: $h2_msgs_duplicate_nb\n" 1407 if ( $debug or $delete2duplicates or $h2_msgs_duplicate_nb ) ; 1408 $debug and print "Host2 whole time parsing headers took ", timenext(), " s\n"; 1409 1410 $debug and print "++++ Verifying [$h1_fold] -> [$h2_fold]\n"; 1411 # messages in host1 that are not in host2 1412 1413 my @h1_hash_keys_sorted_by_uid 1414 = sort {$h1_hash{$a}{'m'} <=> $h1_hash{$b}{'m'}} keys(%h1_hash); 1415 1416 #print map { $h1_hash{$_}{'m'} . " "} @h1_hash_keys_sorted_by_uid; 1417 1418 my @h2_hash_keys_sorted_by_uid 1419 = sort {$h2_hash{$a}{'m'} <=> $h2_hash{$b}{'m'}} keys(%h2_hash); 1420 1421 1422 if( $delete2duplicates and not exists( $h2_folders_from_1_several{ $h2_fold } ) ) { 1423 my @h2_expunge ; 1424 1425 foreach my $h2_msg ( @h2_msgs_duplicate ) { 1426 print "msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2 $dry_message\n" ; 1427 push( @h2_expunge, $h2_msg ) if $uidexpunge2 ; 1428 unless ( $dry ) { 1429 $imap2->delete_message( $h2_msg ) ; 1430 $h2_nb_msg_deleted += 1 ; 1431 } 1432 } 1433 my $cnt = scalar @h2_expunge ; 1434 if( @h2_expunge ) { 1435 print "uidexpunge $cnt message(s) $dry_message\n" ; 1436 $imap2->uidexpunge( \@h2_expunge ) if ! $dry ; 1437 } 1438 if ( $expunge2 ){ 1439 print "Expunging host2 folder $h2_fold $dry_message\n" ; 1440 $imap2->expunge( ) if ! $dry ; 1441 } 1442 } 1443 1444 if( $delete2 and not exists( $h2_folders_from_1_several{ $h2_fold } ) ) { 1445 # No host1 folders f1a f1b ... going all to same f2 (via --regextrans2) 1446 my @h2_expunge; 1447 foreach my $m_id (@h2_hash_keys_sorted_by_uid) { 1448 #print "$m_id "; 1449 unless (exists($h1_hash{$m_id})) { 1450 my $h2_msg = $h2_hash{$m_id}{'m'}; 1451 my $h2_flags = $h2_hash{$m_id}{'F'} || ""; 1452 my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0; 1453 print "msg $h2_fold/$h2_msg marked \\Deleted on host2 [$m_id] $dry_message\n" 1454 if ! $isdel; 1455 push(@h2_expunge, $h2_msg) if $uidexpunge2; 1456 unless ($dry or $isdel) { 1457 $imap2->delete_message($h2_msg); 1458 $h2_nb_msg_deleted += 1; 1459 } 1460 } 1461 } 1462 foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) { 1463 print "msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2 $dry_message\n"; 1464 push(@h2_expunge, $h2_msg) if $uidexpunge2; 1465 unless ($dry) { 1466 $imap2->delete_message($h2_msg); 1467 $h2_nb_msg_deleted += 1; 1468 } 1469 } 1470 my $cnt = scalar @h2_expunge ; 1471 if( @h2_expunge ) { 1472 print "uidexpunge $cnt message(s) $dry_message\n" ; 1473 $imap2->uidexpunge( \@h2_expunge ) if ! $dry ; 1474 } 1475 if ($expunge2){ 1476 print "Expunging host2 folder $h2_fold $dry_message\n" ; 1477 $imap2->expunge( ) if ! $dry ; 1478 } 1479 } 1480 1481 if( $delete2 and exists( $h2_folders_from_1_several{ $h2_fold } ) ) { 1482 print "Host2 folder $h2_fold $h2_folders_from_1_several{ $h2_fold } folders left to sync there\n" ; 1483 my @h2_expunge; 1484 foreach my $m_id ( @h2_hash_keys_sorted_by_uid ) { 1485 my $h2_msg = $h2_hash{ $m_id }{ 'm' } ; 1486 unless ( exists( $h1_hash{ $m_id } ) ) { 1487 my $h2_flags = $h2_hash{ $m_id }{ 'F' } || "" ; 1488 my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0 ; 1489 unless ( $isdel ) { 1490 $debug and print "msg $h2_fold/$h2_msg candidate for deletion on host2 [$m_id]\n" ; 1491 $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ; 1492 } 1493 }else{ 1494 $debug and print "msg $h2_fold/$h2_msg will cancel deletion on host2 [$m_id]\n" ; 1495 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; 1496 } 1497 } 1498 foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) { 1499 print "msg $h2_fold/$h2_msg candidate for deletion [not in cache] on host2\n"; 1500 $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ; 1501 } 1502 1503 foreach my $h2_msg ( @h2_msgs_in_cache ) { 1504 print "msg $h2_fold/$h2_msg will cancel deletion [in cache] on host2\n"; 1505 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; 1506 } 1507 1508 1509 if ( 0 == $h2_folders_from_1_several{ $h2_fold } ) { 1510 # last host1 folder going to $h2_fold 1511 print "Last host1 folder going to $h2_fold\n" ; 1512 foreach my $h2_msg ( keys %{ $uid_candidate_for_deletion{ $h2_fold } } ) { 1513 $debug and print "msg $h2_fold/$h2_msg candidate for deletion on host2\n" ; 1514 if ( exists( $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg } ) ) { 1515 $debug and print "msg $h2_fold/$h2_msg canceled deletion on host2\n" ; 1516 }else{ 1517 print "msg $h2_fold/$h2_msg marked \\Deleted on host2 $dry_message\n"; 1518 push( @h2_expunge, $h2_msg ) if $uidexpunge2 ; 1519 unless ( $dry ) { 1520 $imap2->delete_message( $h2_msg ) ; 1521 $h2_nb_msg_deleted += 1 ; 1522 } 1523 } 1524 } 1525 } 1526 1527 my $cnt = scalar @h2_expunge ; 1528 if( @h2_expunge ) { 1529 print "uidexpunge $cnt message(s) $dry_message\n" ; 1530 $imap2->uidexpunge( \@h2_expunge ) if ! $dry ; 1531 } 1532 if ( $expunge2 ) { 1533 print "Expunging host2 folder $h2_fold $dry_message\n" ; 1534 $imap2->expunge( ) if ! $dry ; 1535 } 1536 1537 $h2_folders_from_1_several{ $h2_fold }-- ; 1538 } 1539 1540 1541 my $h2_uidnext = $imap2->uidnext( $h2_fold ) ; 1542 $debug and print "Host2 uidnext: $h2_uidnext\n" ; 1543 $h2_uidguess = $h2_uidnext ; 1544 MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) { 1545 last FOLDER if $imap1->IsUnconnected(); 1546 last FOLDER if $imap2->IsUnconnected(); 1547 #print "h1_nb_msg_processed: $h1_nb_msg_processed\n" ; 1548 my $h1_size = $h1_hash{$m_id}{'s'}; 1549 my $h1_msg = $h1_hash{$m_id}{'m'}; 1550 my $h1_idate = $h1_hash{$m_id}{'D'}; 1551 1552 unless (exists($h2_hash{$m_id})) { 1553 # copy 1554 my $h2_msg = copy_message( $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; 1555 if( $delete2 and exists( $h2_folders_from_1_several{ $h2_fold } ) and $h2_msg ) { 1556 print "msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ; 1557 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; 1558 } 1559 last FOLDER if total_bytes_max_reached( ) ; 1560 next MESS; 1561 } 1562 else{ 1563 # already on host2 1564 my $h2_msg = $h2_hash{$m_id}{'m'} ; 1565 $debug and print "Host1 found msg $h1_fold/$h1_msg equals Host2 $h2_fold/$h2_msg\n" ; 1566 $total_bytes_skipped += $h1_size ; 1567 $nb_msg_skipped += 1 ; 1568 $h1_nb_msg_processed +=1 ; 1569 1570 if ( $usecache ) { 1571 $debugcache and print "touch $cache_dir/${h1_msg}_$h2_msg\n" ; 1572 touch( "$cache_dir/${h1_msg}_$h2_msg" ) 1573 or croak( "Couldn't touch $cache_dir/${h1_msg}_$h2_msg" ) ; 1574 } 1575 } 1576 1577 #$debug and print "MESSAGE $m_id\n"; 1578 my $h2_msg = $h2_hash{$m_id}{'m'}; 1579 1580 sync_flags_fir( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; 1581 last FOLDER if $imap2->IsUnconnected() ; 1582 # Good 1583 my $h2_size = $h2_hash{$m_id}{'s'}; 1584 $debug and print 1585 "Host1 size msg $h1_fold/$h1_msg = $h1_size <> $h2_size = Host2 $h2_fold/$h2_msg\n"; 1586 if( $delete ) { 1587 my $expunge_message = '' ; 1588 $expunge_message = "and expunged" if ( $expungeaftereach and ( $expunge or $expunge1 ) ) ; 1589 print "Host1 msg $h1_fold/$h1_msg marked deleted $expunge_message $dry_message\n" ; 1590 unless( $dry ) { 1591 $imap1->delete_message( $h1_msg ) ; 1592 $h1_nb_msg_deleted += 1 ; 1593 $imap1->expunge() if ( $expungeaftereach and ( $expunge or $expunge1 ) ) ; 1594 } 1595 } 1596 1597 } 1598 # END MESS: loop 1599 last FOLDER if $imap1->IsUnconnected(); 1600 last FOLDER if $imap2->IsUnconnected(); 1601 MESS_IN_CACHE: foreach my $h1_msg ( @h1_msgs_in_cache ) { 1602 my $h2_msg = $cache_1_2_ref->{ $h1_msg } ; 1603 $debugcache and print "cache messages update flags $h1_msg->$h2_msg\n"; 1604 sync_flags_fir( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; 1605 my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } || 0 ; 1606 $total_bytes_skipped += $h1_size; 1607 $nb_msg_skipped += 1; 1608 $h1_nb_msg_processed +=1 ; 1609 last FOLDER if $imap2->IsUnconnected(); 1610 } 1611 1612 #print "Messages by uid: ", map { "$_ " } keys %h1_msgs_copy_by_uid, "\n" ; 1613 MESS_BY_UID: foreach my $h1_msg ( sort { $a <=> $b } keys %h1_msgs_copy_by_uid ) { 1614 # 1615 $debug and print "Copy by uid $h1_fold/$h1_msg\n" ; 1616 last FOLDER if $imap1->IsUnconnected(); 1617 last FOLDER if $imap2->IsUnconnected(); 1618 my $h2_msg = copy_message( $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; 1619 if( $delete2 and exists( $h2_folders_from_1_several{ $h2_fold } ) and $h2_msg ) { 1620 print "msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ; 1621 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; 1622 } 1623 last FOLDER if total_bytes_max_reached( ) ; 1624 } 1625 1626 if ($expunge or $expunge1){ 1627 print "Expunging host1 folder $h1_fold $dry_message\n"; 1628 unless($dry) { $imap1->expunge() }; 1629 } 1630 if ($expunge2){ 1631 print "Expunging host2 folder $h2_fold $dry_message\n"; 1632 unless($dry) { $imap2->expunge() }; 1633 } 1634 1635 $debug and print "Time: ", timenext(), " s\n"; 1636} 1637 1638 1639sub total_bytes_max_reached { 1640 1641 return( 0 ) if not $exitwhenover ; 1642 if ( $total_bytes_transferred >= $exitwhenover ) { 1643 print "Maximum bytes transfered reached, $total_bytes_transferred >= $exitwhenover, ending sync\n" ; 1644 return( 1 ) ; 1645 } 1646 1647} 1648 1649print "++++ End looping on each folder\n"; 1650$debug and print "Time: ", timenext(), " s\n"; 1651 1652#print memory_consumption(); 1653 1654 1655if ( $foldersizesatend ) { 1656 timenext() ; 1657 ( $h1_nb_msg_end, $h1_bytes_end ) = foldersizes( "Host1", $imap1, $search1, @h1_folders_wanted ) ; 1658 ( $h2_nb_msg_end, $h2_bytes_end ) = foldersizes( "Host2", $imap2, $search2, @h2_folders_from_1_wanted ) ; 1659} 1660 1661$imap1->logout( ) unless lost_connection($imap1, "for host1 [$host1]"); 1662$imap2->logout( ) unless lost_connection($imap2, "for host2 [$host2]"); 1663 1664 1665stats( ) ; 1666exit_clean( 1 ) if ( $nb_errors ) ; 1667exit_clean( 0 ) ; 1668 1669# END of main program 1670 1671# subroutines 1672 1673 1674sub size_filtered_flag { 1675 my $h1_size = shift ; 1676 1677 if (defined $maxsize and $h1_size >= $maxsize) { 1678 return( 1 ) ; 1679 } 1680 if (defined $minsize and $h1_size <= $minsize) { 1681 return( 1 ) ; 1682 } 1683 return( 0 ) ; 1684} 1685 1686sub sync_flags_fir { 1687 my ( $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ; 1688 1689 my $h1_size = $h1_fir_ref->{$h1_msg}->{"RFC822.SIZE"} ; 1690 return( ) if size_filtered_flag( $h1_size ) ; 1691 1692 # used cached flag values for efficiency 1693 my $h1_flags = $h1_fir_ref->{ $h1_msg }->{ "FLAGS" } || '' ; 1694 my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ "FLAGS" } || '' ; 1695 1696 sync_flags( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ; 1697 1698 return( ) ; 1699} 1700 1701sub sync_flags_after_copy { 1702 my( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $permanentflags2 ) = @_ ; 1703 1704 my @h2_flags = $imap2->flags( $h2_msg ) ; 1705 my $h2_flags = "@h2_flags" ; 1706 print "FLAGS $h2_msg: $h2_flags\n" ; 1707 sync_flags( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ; 1708 return( ) ; 1709} 1710 1711sub sync_flags { 1712 my( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) = @_ ; 1713 1714 ( $debug or $debugflags ) and 1715 print "Host1 flags init msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 $h2_fold/$h2_msg flags( $h2_flags )\n" ; 1716 1717 $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ; 1718 1719 $h2_flags = flagsCase( $h2_flags ) ; 1720 1721 ( $debug or $debugflags ) and 1722 print "Host1 flags filt msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 $h2_fold/$h2_msg flags( $h2_flags )\n" ; 1723 1724 1725 # compare flags - set flags if there a difference 1726 my @h1_flags = sort split(' ', $h1_flags ); 1727 my @h2_flags = sort split(' ', $h2_flags ); 1728 my $diff = compare_lists( \@h1_flags, \@h2_flags ); 1729 1730 $diff and ( $debug or $debugflags ) 1731 and print "Host2 flags msg $h2_fold/$h2_msg replacing h2 flags( $h2_flags ) with h1 flags( $h1_flags )\n"; 1732 # This sets flags so flags can be removed with this 1733 # When you remove a \Seen flag on host1 you want to it 1734 # to be removed on host2. Just add flags is not what 1735 # we need most of the time. 1736 1737 if ( not $dry and $diff and not $imap2->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) { 1738 print "Host2 flags msg $h2_fold/$h2_msg could not add flags [@h1_flags]: ", 1739 $imap2->LastError || '', "\n" ; 1740 #$nb_errors++ ; 1741 } 1742 1743 return( ) ; 1744} 1745 1746 1747 1748sub _filter { 1749 my $str = shift or return ""; 1750 my $sz = 64; 1751 my $len = length($str); 1752 if ( not $debug and $len > $sz*2 ) { 1753 my $beg = substr($str, 0, $sz); 1754 my $end = substr($str, -$sz, $sz); 1755 $str = $beg . "..." . $end; 1756 } 1757 $str =~ s/\012?\015$//x; 1758 return "(len=$len) " . $str; 1759} 1760 1761 1762 1763sub lost_connection { 1764 my($imap, $error_message) = @_; 1765 if ( $imap->IsUnconnected() ) { 1766 $nb_errors++; 1767 my $lcomm = $imap->LastIMAPCommand || ""; 1768 my $einfo = $imap->LastError || @{$imap->History}[-1] || ""; 1769 1770 # if string is long try reduce to a more reasonable size 1771 $lcomm = _filter($lcomm); 1772 $einfo = _filter($einfo); 1773 print("Failure: last command: $lcomm\n") if ($debug && $lcomm); 1774 print("Failure: lost connection $error_message: ", $einfo, "\n"); 1775 return(1); 1776 } 1777 else{ 1778 return(0); 1779 } 1780} 1781 1782sub max { 1783 my @list = @_ ; 1784 return( undef ) if ( 0 == scalar( @list ) ) ; 1785 my @sorted = sort { $a <=> $b } @list ; 1786 return( pop( @sorted ) ) ; 1787} 1788 1789sub tests_max { 1790 ok( 0 == max(0), "max 0"); 1791 ok( 1 == max(1), "max 1"); 1792 ok( -1 == max(-1), "max -1"); 1793 ok( not ( defined( max( ) ) ), "max no arg" ) ; 1794 ok( 100 == max( 1, 100 ), "max 1 100" ) ; 1795 ok( 100 == max( 100, 1 ), "max 100 1") ; 1796 ok( 100 == max( 100, 42, 1 ), "max 100 42 1") ; 1797 ok( 100 == max( 100, "42", 1 ), "max 100 42 1") ; 1798 ok( 100 == max( "100", "42", 1 ), "max 100 42 1") ; 1799 #ok( 100 == max( 100, "haha", 1 ), "max 100 42 1") ; 1800 return( ) ; 1801} 1802 1803sub keyval { 1804 my %hash = @_ ; 1805 return( join( " ", map( { "$_ => " . $hash{ $_ } } keys %hash ) ) . "\n" ) ; 1806} 1807 1808 1809 1810sub check_lib_version { 1811 $debug and print "IMAPClient $Mail::IMAPClient::VERSION\n"; 1812 if ($Mail::IMAPClient::VERSION eq '2.2.9') { 1813 print "imapsync no longer supports Mail::IMAPClient 2.2.9, upgrade it" ; 1814 return( 0 ) ; 1815 } 1816 else{ 1817 # 3.x.x is no longer buggy with imapsync. 1818 return( 1 ) ; 1819 } 1820} 1821 1822sub module_version_str { 1823 my( $module_name, $module_version ) = @_ ; 1824 my $str = sprintf( "%-20s %s\n", $module_name, $module_version ) ; 1825 return( $str ) ; 1826} 1827 1828sub modules_VERSION { 1829 1830 my @list_version; 1831 1832 my $v ; 1833 eval { require Mail::IMAPClient; $v = $Mail::IMAPClient::VERSION } or $v = "?" ; 1834 push ( @list_version, module_version_str( 'Mail::IMAPClient', $v ) ) ; 1835 1836 eval { require IO::Socket; $v = $IO::Socket::VERSION } or $v = "?" ; 1837 push ( @list_version, module_version_str( 'IO::Socket', $v ) ) ; 1838 1839 eval { require IO::Socket::IP; $v = $IO::Socket::IP::VERSION } or $v = "?" ; 1840 push ( @list_version, module_version_str( 'IO::Socket::IP', $v ) ) ; 1841 1842 eval { require IO::Socket::INET; $v = $IO::Socket::INET::VERSION } or $v = "?" ; 1843 push ( @list_version, module_version_str( 'IO::Socket::INET', $v ) ) ; 1844 1845 eval { require IO::Socket::SSL ; $v = $IO::Socket::SSL::VERSION } or $v = "?" ; 1846 push ( @list_version, module_version_str( 'IO::Socket::SSL ', $v ) ) ; 1847 1848 eval { require Net::SSLeay ; $v = $Net::SSLeay::VERSION } or $v = "?" ; 1849 push ( @list_version, module_version_str( 'Net::SSLeay ', $v ) ) ; 1850 1851 eval { require Digest::MD5; $v = $Digest::MD5::VERSION } or $v = "?" ; 1852 push ( @list_version, module_version_str( 'Digest::MD5', $v ) ) ; 1853 1854 eval { require Digest::HMAC_MD5; $v = $Digest::HMAC_MD5::VERSION } or $v = "?" ; 1855 push ( @list_version, module_version_str( 'Digest::HMAC_MD5', $v ) ) ; 1856 1857 eval { require Digest::HMAC_SHA1; $v = $Digest::HMAC_SHA1::VERSION } or $v = "?" ; 1858 push ( @list_version, module_version_str( 'Digest::HMAC_SHA1', $v ) ) ; 1859 1860 eval { require Term::ReadKey; $v = $Term::ReadKey::VERSION } or $v = "?" ; 1861 push ( @list_version, module_version_str( 'Term::ReadKey', $v ) ) ; 1862 1863 eval { require Authen::NTLM; $v = $Authen::NTLM::VERSION } or $v = "?" ; 1864 push ( @list_version, module_version_str( 'Authen::NTLM', $v ) ) ; 1865 1866 eval { require File::Spec; $v = $File::Spec::VERSION } or $v = "?" ; 1867 push ( @list_version, module_version_str( 'File::Spec', $v ) ) ; 1868 1869 eval { require Time::HiRes; $v = $Time::HiRes::VERSION } or $v = "?" ; 1870 push ( @list_version, module_version_str( 'Time::HiRes', $v ) ) ; 1871 1872 eval { require URI::Escape; $v = $URI::Escape::VERSION } or $v = "?" ; 1873 push ( @list_version, module_version_str( 'URI::Escape', $v ) ) ; 1874 1875 eval { require Data::Uniqid; $v = $Data::Uniqid::VERSION } or $v = "?" ; 1876 push ( @list_version, module_version_str( 'Data::Uniqid', $v ) ) ; 1877 1878 return( @list_version ) ; 1879} 1880 1881 1882# Construct a command line copy with passwords replaced by MASKED. 1883sub command_line_nopassword { 1884 my @argv = @_; 1885 my @argv_nopassword; 1886 1887 return("@argv") if $showpasswords ; 1888 while (@argv) { 1889 my $arg = shift(@argv); # option name or value 1890 if ($arg =~ m/-password[12]/x) { 1891 shift(@argv); # password value 1892 push(@argv_nopassword, $arg, "MASKED"); # option name and fake value 1893 }else{ 1894 push(@argv_nopassword, $arg); # same option or value 1895 } 1896 } 1897 return("@argv_nopassword"); 1898} 1899 1900sub tests_command_line_nopassword { 1901 1902 ok('' eq command_line_nopassword(), 'command_line_nopassword void'); 1903 ok('--blabla' eq command_line_nopassword('--blabla'), 'command_line_nopassword --blabla'); 1904 #print command_line_nopassword((qw{ --password1 secret1 })), "\n"; 1905 ok('--password1 MASKED' eq command_line_nopassword(qw{ --password1 secret1}), 'command_line_nopassword --password1'); 1906 ok('--blabla --password1 MASKED --blibli' 1907 eq command_line_nopassword(qw{ --blabla --password1 secret1 --blibli }), 'command_line_nopassword --password1 --blibli'); 1908 $showpasswords = 1 ; 1909 ok('' eq command_line_nopassword(), 'command_line_nopassword void'); 1910 ok('--blabla' eq command_line_nopassword('--blabla'), 'command_line_nopassword --blabla'); 1911 #print command_line_nopassword((qw{ --password1 secret1 })), "\n"; 1912 ok('--password1 secret1' eq command_line_nopassword(qw{ --password1 secret1}), 'command_line_nopassword --password1'); 1913 ok('--blabla --password1 secret1 --blibli' 1914 eq command_line_nopassword(qw{ --blabla --password1 secret1 --blibli }), 'command_line_nopassword --password1 --blibli'); 1915 return( ) ; 1916} 1917 1918sub ask_for_password { 1919 my ($user, $host) = @_; 1920 print "What's the password for $user\@$host? "; 1921 Term::ReadKey::ReadMode(2); 1922 my $password = <>; 1923 chomp $password; 1924 printf "\n"; 1925 Term::ReadKey::ReadMode(0); 1926 return $password; 1927} 1928 1929sub catch_exit { 1930 my $signame = shift ; 1931 print "\nGot a SIG$signame!\n" ; 1932 stats( ) ; 1933 exit_clean( 6 ) ; 1934 return( ) ; # fake, for perlcritic 1935} 1936 1937sub catch_continue { 1938 my $signame = shift ; 1939 print "\nGot a SIG$signame!\n" ; 1940 return( ) ; 1941} 1942 1943 1944 1945sub connect_imap { 1946 my( $host, $port, $mydebugimap, $ssl, $tls, $SSL_version ) = @_; 1947 my $imap = Mail::IMAPClient->new(); 1948 if ( $ssl ) { set_ssl( $imap, $ssl, $SSL_version ) } 1949 $imap->Tls($tls) if ($tls); 1950 $imap->Server($host); 1951 $imap->Port($port); 1952 $imap->Debug($mydebugimap); 1953 $imap->connect() 1954 or die_clean("Can not open imap connection on [$host]: $@\n"); 1955 #myconnect($imap) 1956 # or die_clean("Can not open imap connection on [$host]: $@\n"); 1957 my $banner = $imap->Results()->[0] ; 1958 $imap->Banner( $banner ) ; 1959 $imap->starttls( ) if ( $imap->Tls( ) ) ; 1960 return( $imap ) ; 1961} 1962 1963sub justconnect { 1964 1965 $imap1 = connect_imap( $host1, $port1, $debugimap1, $ssl1, $tls1, $ssl1_SSL_version ) ; 1966 print "Host1 software: ", server_banner( $imap1 ) ; 1967 print "Host1 capability: ", join(" ", $imap1->capability( ) ), "\n" ; 1968 $imap2 = connect_imap( $host2, $port2, $debugimap2, $ssl2, $tls2, $ssl2_SSL_version ) ; 1969 print "Host2 software: ", server_banner( $imap2 ) ; 1970 print "Host2 capability: ", join(" ", $imap2->capability( ) ), "\n" ; 1971 $imap1->logout() ; 1972 $imap2->logout() ; 1973 return( ) ; 1974} 1975 1976sub relogin1 { 1977 $imap1 = relogin_imap( 1978 $imap1, 1979 $host1, $port1, $user1, $domain1, $password1, 1980 $debugimap1, $timeout, $fastio1, $ssl1, $tls1, 1981 $authmech1, $authuser1, $reconnectretry1, 1982 $proxyauth1, $uid1, $split1) ; 1983 1984 $relogin1-- if ( $relogin1 ) ; 1985 return( ) ; 1986} 1987 1988sub relogin2 { 1989 $imap2 = relogin_imap( 1990 $imap2, 1991 $host2, $port2, $user2, $domain2, $password2, 1992 $debugimap2, $timeout, $fastio2, $ssl2, $tls2, 1993 $authmech2, $authuser2, $reconnectretry2, 1994 $proxyauth2, $uid2, $split2) ; 1995 1996 $relogin2-- if ( $relogin2 ) ; 1997 return( ) ; 1998} 1999 2000sub relogin_imap { 2001 my($imap, 2002 $host, $port, $user, $domain, $password, 2003 $mydebugimap, $mytimeout, $fastio, 2004 $ssl, $tls, $authmech, $authuser, $reconnectretry, 2005 $proxyauth, $uid, $split) = @_; 2006 2007 my $folder_current = $imap->Folder ; 2008 $imap->logout( ) ; 2009 $imap = login_imap( 2010 $host, $port, $user, $domain, $password, 2011 $mydebugimap, $mytimeout, $fastio, 2012 $ssl, $tls, $authmech, $authuser, $reconnectretry, 2013 $proxyauth, $uid, $split 2014 ) ; 2015 $imap->select( $folder_current ) if defined( $folder_current ) ; 2016 return( $imap ) ; 2017} 2018 2019 2020sub login_imap { 2021 2022 my @allargs = @_ ; 2023 my($host, $port, $user, $domain, $password, 2024 $mydebugimap, $mytimeout, $fastio, 2025 $ssl, $tls, $authmech, $authuser, $reconnectretry, 2026 $proxyauth, $uid, $split, $Side, $SSL_version ) = @allargs ; 2027 2028 my $side = lc( $Side ) ; 2029 my $imap = init_imap( @allargs ) ; 2030 2031 $imap->connect() 2032 or die_clean("Failure: can not open imap connection on $side [$host] with user [$user]: $@\n"); 2033 2034 my $banner = $imap->Results()->[0] ; 2035 $imap->Banner( $banner ) ; 2036 print "$Side: ", server_banner($imap); 2037 2038 if ( $authmech eq 'PREAUTH' ) { 2039 if ( $imap->IsAuthenticated( ) ) { 2040 $imap->Socket ; 2041 printf("%s: Assuming PREAUTH for %s\n", $Side, $imap->Server ) ; 2042 }else{ 2043 die_clean( "Failure: error login on $side [$host] with user [$user] auth [PREAUTH]" ) ; 2044 } 2045 } 2046 2047 $imap->starttls( ) if ( $imap->Tls( ) ) ; 2048 2049 authenticate_imap( $imap, @allargs ) ; 2050 2051 print "$Side: success login on [$host] with user [$user] auth [$authmech]\n" ; 2052 return( $imap ) ; 2053} 2054 2055 2056sub authenticate_imap { 2057 2058 my($imap, 2059 $host, $port, $user, $domain, $password, 2060 $mydebugimap, $mytimeout, $fastio, 2061 $ssl, $tls, $authmech, $authuser, $reconnectretry, 2062 $proxyauth, $uid, $split, $Side ) = @_ ; 2063 2064 check_capability( $imap, $authmech, $Side ) ; 2065 2066 if ( $proxyauth ) { 2067 $imap->Authmechanism("") ; 2068 $imap->User($authuser) ; 2069 } else { 2070 $imap->Authmechanism( $authmech ) unless ( $authmech eq 'LOGIN' or $authmech eq 'PREAUTH' ) ; 2071 $imap->User($user) ; 2072 } 2073 2074 $imap->Authcallback(\&xoauth) if $authmech eq "XOAUTH" ; 2075 $imap->Authcallback(\&plainauth) if $authmech eq "PLAIN" || ($authmech eq "EXTERNAL") ; 2076 2077if ($proxyauth) { 2078 $imap->User($authuser); 2079 $imap->Domain($domain) if (defined($domain)); 2080 $imap->Authuser($authuser); 2081 if ($authmech eq "EXTERNAL") {$password = "NULL"}; 2082 $imap->Password($password); 2083 } else { 2084 $imap->User($user); 2085 $imap->Domain($domain) if (defined($domain)); 2086 $imap->Authuser($authuser); 2087 if ($authmech eq "EXTERNAL") {$password = "NULL"}; 2088 $imap->Password($password); 2089 } 2090 2091 2092 2093# $imap->Domain($domain) if (defined($domain)) ; 2094# $imap->Authuser($authuser) ; 2095# $imap->Password($password) ; 2096 2097 unless ( $authmech eq 'PREAUTH' or $imap->login( ) ) { 2098 my $info = "Failure: error login on [$host] with user [$user] auth" ; 2099 my $einfo = $imap->LastError || @{$imap->History}[-1] ; 2100 chomp( $einfo ) ; 2101 my $error = "$info [$authmech]: $einfo\n" ; 2102 if ( $authmech eq 'LOGIN' or $imap->IsUnconnected( ) or $authuser ) { 2103 die_clean( $error ) ; 2104 }else{ 2105 print $error ; 2106 } 2107 print "Info: trying LOGIN Auth mechanism on [$host] with user [$user]\n" ; 2108 $imap->Authmechanism("") ; 2109 $imap->login() or 2110 die_clean("$info [LOGIN]: ", $imap->LastError, "\n") ; 2111 } 2112 2113# if ( $proxyauth ) { 2114# if ( ! $imap->proxyauth( $user ) ) { 2115# my $info = "Failure: error doing proxyauth as user [$user] on [$host] using proxy-login as [$authuser]" ; 2116# my $einfo = $imap->LastError || @{$imap->History}[-1] ; 2117# chomp( $einfo ) ; 2118# die_clean( "$info: $einfo\n" ) ; 2119# } 2120# } 2121 2122 return( ) ; 2123} 2124 2125sub check_capability { 2126 2127 my( $imap, $authmech, $Side ) = @_ ; 2128 2129 if ($imap->has_capability("AUTH=$authmech") 2130 or $imap->has_capability($authmech) 2131 ) { 2132 printf("%s: %s says it has CAPABILITY for AUTHENTICATE %s\n", 2133 $Side, $imap->Server, $authmech); 2134 } 2135 else { 2136 printf("%s: %s says it has NO CAPABILITY for AUTHENTICATE %s\n", 2137 $Side, $imap->Server, $authmech); 2138 if ($authmech eq 'PLAIN') { 2139 print "$Side: frequently PLAIN is only supported with SSL, ", 2140 "try --ssl or --tls options\n"; 2141 } 2142 } 2143 return( ) ; 2144} 2145 2146sub set_ssl { 2147 my ( $imap, $ssl, $SSL_version ) = @_ ; 2148 # SSL_version can be 2149 # SSLv3 SSLv2 SSLv23 SSLv23:!SSLv2 (last one is the default in IO-Socket-SSL-1.953) 2150 # 2151 $SSL_version = $SSL_version || '' ; 2152 #print "[$SSL_version]\n" ; 2153 IO::Socket::SSL::set_ctx_defaults( 2154 SSL_verify_mode => 'SSL_VERIFY_PEER', 2155 SSL_verifycn_scheme => 'imap', 2156 SSL_version => $SSL_version, 2157 ) ; 2158 $imap->Ssl( $ssl ) ; 2159 return( ) ; 2160} 2161 2162sub init_imap { 2163 my($host, $port, $user, $domain, $password, 2164 $mydebugimap, $mytimeout, $fastio, 2165 $ssl, $tls, $authmech, $authuser, $reconnectretry, 2166 $proxyauth, $uid, $split, $Side, $SSL_version ) = @_ ; 2167 2168 my ( $imap ) ; 2169 2170 $imap = Mail::IMAPClient->new() ; 2171 2172 if ( $ssl ) { set_ssl( $imap, $ssl, $SSL_version ) } 2173 $imap->Tls($tls) if ($tls); 2174 $imap->Clear(1); 2175 $imap->Server($host); 2176 $imap->Port($port); 2177 $imap->Fast_io($fastio); 2178 $imap->Buffer($buffersize || 4096); 2179 $imap->Uid($uid); 2180 #$imap->Uid(0); 2181 $imap->Peek(1); 2182 $imap->Debug($mydebugimap); 2183 defined( $mytimeout ) and $imap->Timeout($mytimeout); 2184 2185 $imap->Reconnectretry($reconnectretry) if ($reconnectretry); 2186 $imap->Ignoresizeerrors( $allowsizemismatch ) ; 2187 $split and $imap->Maxcommandlength( 10 * $split ) ; 2188 2189 2190 return( $imap ) ; 2191 2192} 2193 2194sub plainauth { 2195 my $code = shift; 2196 my $imap = shift; 2197 2198 my $string = sprintf("%s\x00%s\x00%s", $imap->User, 2199 $imap->Authuser, $imap->Password); 2200 return encode_base64("$string", ""); 2201} 2202 2203# xoauth() thanks to Eduardo Bortoluzzi Junior 2204sub xoauth { 2205 require URI::Escape ; 2206 require Data::Uniqid ; 2207 2208 my $code = shift; 2209 my $imap = shift; 2210 2211 # The base information needed to construct the OAUTH authentication 2212 my $method = "GET"; 2213 my $URL = sprintf("https://mail.google.com/mail/b/%s/imap/", $imap->User); 2214 my $URLparm = sprintf("xoauth_requestor_id=%s", URI::Escape::uri_escape($imap->User)); 2215 2216 # For Google Apps, the consumer key is the primary domain 2217 # TODO: create a command line argument to define the consumer key 2218 my @user_parts = split(/@/x, $imap->User); 2219 $debug and print "XOAUTH: consumer key: $user_parts[1]\n"; 2220 2221 # All the parameters needed to be signed on the XOAUTH 2222 my %hash = (); 2223 $hash { 'xoauth_requestor_id' } = URI::Escape::uri_escape($imap->User); 2224 $hash { 'oauth_consumer_key' } = $user_parts[1]; 2225 $hash { 'oauth_nonce' } = md5_hex(Data::Uniqid::uniqid(rand(), 1==1)); 2226 $hash { 'oauth_signature_method' } = 'HMAC-SHA1'; 2227 $hash { 'oauth_timestamp' } = time(); 2228 $hash { 'oauth_version' } = '1.0'; 2229 2230 # Base will hold the string to be signed 2231 my $base = "$method&" . URI::Escape::uri_escape($URL) . "&"; 2232 2233 # The parameters must be in dictionary order before signing 2234 my $baseparms = ""; 2235 foreach my $key (sort keys %hash) { 2236 if(length($baseparms)>0) { 2237 $baseparms .= "&"; 2238 } 2239 2240 $baseparms .= "$key=$hash{$key}"; 2241 } 2242 2243 $base .= URI::Escape::uri_escape($baseparms); 2244 $debug and print "XOAUTH: base request to sign: $base\n"; 2245 # Sign it with the consumer secret, informed on the command line (password) 2246 my $digest = hmac_sha1($base, URI::Escape::uri_escape($imap->Password) . "&"); 2247 2248 # The parameters signed become a parameter and... 2249 $hash { 'oauth_signature' } = URI::Escape::uri_escape(substr(encode_base64($digest),0,-1)); 2250 2251 # ... we don't need the requestor_id anymore. 2252 delete $hash{'xoauth_requestor_id'}; 2253 2254 # Create the final authentication string 2255 my $string = $method . " " . $URL . "?" . $URLparm ." "; 2256 2257 # All the parameters must be sorted 2258 $baseparms = ""; 2259 foreach my $key (sort keys %hash) { 2260 if(length($baseparms)>0) { 2261 $baseparms .= ","; 2262 } 2263 2264 $baseparms .= "$key=\"$hash{$key}\""; 2265 } 2266 2267 $string .= $baseparms; 2268 2269 $debug and print "XOAUTH: authentication string: $string\n"; 2270 2271 # It must be base64 encoded 2272 return encode_base64("$string", ""); 2273} 2274 2275sub server_banner { 2276 my $imap = shift; 2277 my $banner = $imap->Banner() || "No banner\n"; 2278 return $banner; 2279 } 2280 2281 2282sub banner_imapsync { 2283 2284 my @argv = @_ ; 2285 my $banner_imapsync = join("", 2286 '$RCSfile: imapsync,v $ ', 2287 '$Revision: 1.564 $ ', 2288 '$Date: 2013/08/18 19:28:47 $ ', 2289 "\n",localhost_info(), "\n", 2290 "Command line used:\n", 2291 "$0 ", command_line_nopassword( @argv ), "\n", 2292 ) ; 2293 return( $banner_imapsync ) ; 2294} 2295 2296sub is_valid_directory { 2297 my $dir = shift; 2298 return(1) if (-d $dir and -r _ and -w _) ; 2299 # Trying to create it 2300 mkpath( $dir ) or croak "Error creating tmpdir $tmpdir : $!" ; 2301 croak "Error with tmpdir $tmpdir : $!" if not (-d $dir and -r _ and -w _) ; 2302 return( 1 ) ; 2303} 2304 2305 2306sub write_pidfile { 2307 my $pid_filename = shift ; 2308 2309 print "PID file is $pid_filename\n" ; 2310 if ( -e $pid_filename and $pidfilelocking ) { 2311 print "$pid_filename already exists, another imapsync may be curently running. Aborting imapsync.\n" ; 2312 exit( 8 ) ; 2313 } 2314 if ( -e $pid_filename ) { 2315 print "$pid_filename already exists, overwriting it\n" ; 2316 } 2317 my $FILE_HANDLE ; 2318 open( $FILE_HANDLE, '>', $pid_filename ) or do { 2319 print "Could not open $pid_filename for writing" ; 2320 return ; 2321 } ; 2322 2323 print $FILE_HANDLE $PROCESS_ID ; 2324 close $FILE_HANDLE ; 2325 2326 return( $PROCESS_ID ) ; 2327} 2328 2329sub exit_clean { 2330 my $status = shift ; 2331 $status = defined( $status ) ? $status : 1 ; 2332 unlink( $pidfile ) ; 2333 exit( $status ) ; 2334} 2335 2336sub die_clean { 2337 my @messages = @_ ; 2338 unlink( $pidfile ) ; 2339 croak @messages ; 2340} 2341 2342sub missing_option { 2343 my ($option) = @_; 2344 die_clean("$option option must be used, run $0 --help for help\n"); 2345 return( ) ; 2346} 2347 2348 2349sub fix_Inbox_INBOX_mapping { 2350 my( $h1_all, $h2_all ) = @_ ; 2351 2352 my $regex = '' ; 2353 SWITCH: { 2354 if ( exists( $h1_all->{INBOX} ) and exists( $h2_all->{INBOX} ) ) { $regex = '' ; last SWITCH ; } ; 2355 if ( exists( $h1_all->{Inbox} ) and exists( $h2_all->{Inbox} ) ) { $regex = '' ; last SWITCH ; } ; 2356 if ( exists( $h1_all->{INBOX} ) and exists( $h2_all->{Inbox} ) ) { $regex = 's/^INBOX$/Inbox/x' ; last SWITCH ; } ; 2357 if ( exists( $h1_all->{Inbox} ) and exists( $h2_all->{INBOX} ) ) { $regex = 's/^Inbox$/INBOX/x' ; last SWITCH ; } ; 2358 } ; 2359 return( $regex ) ; 2360} 2361 2362sub tests_fix_Inbox_INBOX_mapping { 2363 2364 my( $h1_all, $h2_all ) ; 2365 2366 $h1_all = { 'INBOX' => '' } ; 2367 $h2_all = { 'INBOX' => '' } ; 2368 ok( '' eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX INBOX' ) ; 2369 2370 $h1_all = { 'Inbox' => '' } ; 2371 $h2_all = { 'Inbox' => '' } ; 2372 ok( '' eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox Inbox' ) ; 2373 2374 $h1_all = { 'INBOX' => '' } ; 2375 $h2_all = { 'Inbox' => '' } ; 2376 ok( 's/^INBOX$/Inbox/x' eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX Inbox' ) ; 2377 2378 $h1_all = { 'Inbox' => '' } ; 2379 $h2_all = { 'INBOX' => '' } ; 2380 ok( 's/^Inbox$/INBOX/x' eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox INBOX' ) ; 2381 2382 $h1_all = { 'INBOX' => '' } ; 2383 $h2_all = { 'rrrrr' => '' } ; 2384 ok( '' eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX rrrrrr' ) ; 2385 2386 $h1_all = { 'rrrrr' => '' } ; 2387 $h2_all = { 'Inbox' => '' } ; 2388 ok( '' eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: rrrrr Inbox' ) ; 2389 2390 return( ) ; 2391} 2392 2393sub select_folder { 2394 my ( $imap, $folder, $hostside ) = @_ ; 2395 if ( ! $imap->select( $folder ) ) { 2396 print 2397 "$hostside folder $folder: Could not select: ", 2398 $imap->LastError, "\n" ; 2399 $nb_errors++ ; 2400 return( 0 ) ; 2401 }else{ 2402 # ok select succeeded 2403 return( 1 ) ; 2404 } 2405} 2406 2407sub examine_folder { 2408 my ( $imap, $folder, $hostside ) = @_ ; 2409 if ( ! $imap->examine( $folder ) ) { 2410 print 2411 "$hostside folder $folder: Could not examine: ", 2412 $imap->LastError, "\n" ; 2413 $nb_errors++ ; 2414 return( 0 ) ; 2415 }else{ 2416 # ok examine succeeded 2417 return( 1 ) ; 2418 } 2419} 2420 2421 2422sub create_folder { 2423 my( $imap, $h2_fold, $h1_fold ) = @_ ; 2424 2425 print "Creating folder [$h2_fold] on host2\n"; 2426 if ( ( 'INBOX' eq uc( $h2_fold) ) 2427 and ( $imap->exists( $h2_fold ) ) ) { 2428 print "Folder [$h2_fold] already exists\n" ; 2429 return( 1 ) ; 2430 } 2431 if ( ! $dry ){ 2432 if ( ! $imap->create( $h2_fold ) ) { 2433 print( "Couldn't create folder [$h2_fold] from [$h1_fold]: ", 2434 $imap->LastError( ), "\n" ); 2435 $nb_errors++; 2436 # success if folder exists ("already exists" error) 2437 return( 1 ) if $imap->exists( $h2_fold ) ; 2438 # failure since create failed 2439 return( 0 ); 2440 }else{ 2441 #create succeeded 2442 return( 1 ); 2443 } 2444 }else{ 2445 # dry mode, no folder so many imap will fail, assuming failure 2446 return( 0 ); 2447 } 2448} 2449 2450 2451 2452sub tests_folder_routines { 2453 ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 1' ); 2454 ok( add_to_requested_folders('folder_foo'), 'add_to_requested_folders folder_foo' ); 2455 ok( is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 2' ); 2456 ok( !is_requested_folder('folder_NO_EXIST'), 'is_requested_folder folder_NO_EXIST' ); 2457 ok( !remove_from_requested_folders('folder_foo'), 'removed folder_foo' ); 2458 ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 3' ); 2459 my @f ; 2460 ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f" ); 2461 ok( is_requested_folder('folder_bar'), 'is_requested_folder 4' ); 2462 ok( is_requested_folder('folder_toto'), 'is_requested_folder 5' ); 2463 ok( remove_from_requested_folders('folder_toto'), 'remove_from_requested_folders' ); 2464 ok( !is_requested_folder('folder_toto'), 'is_requested_folder 6' ); 2465 return( ) ; 2466} 2467 2468 2469sub is_requested_folder { 2470 my ( $folder ) = @_; 2471 2472 return( defined( $requested_folder{ $folder } ) ) ; 2473} 2474 2475 2476sub add_to_requested_folders { 2477 my @wanted_folders = @_ ; 2478 2479 foreach my $folder ( @wanted_folders ) { 2480 ++$requested_folder{ $folder } ; 2481 } 2482 return( keys( %requested_folder ) ) ; 2483} 2484 2485sub remove_from_requested_folders { 2486 my @wanted_folders = @_ ; 2487 2488 foreach my $folder (@wanted_folders) { 2489 delete $requested_folder{$folder} ; 2490 } 2491 return( keys( %requested_folder ) ) ; 2492} 2493 2494sub compare_lists { 2495 my ($list_1_ref, $list_2_ref) = @_; 2496 2497 return(-1) if ((not defined($list_1_ref)) and defined($list_2_ref)); 2498 return(0) if ((not defined($list_1_ref)) and not defined($list_2_ref)); # end if no list 2499 return(1) if (not defined($list_2_ref)); # end if only one list 2500 2501 if (not ref($list_1_ref)) {$list_1_ref = [$list_1_ref]}; 2502 if (not ref($list_2_ref)) {$list_2_ref = [$list_2_ref]}; 2503 2504 2505 my $last_used_indice = -1; 2506 #print "\$#$list_1_ref:", $#$list_1_ref, "\n"; 2507 #print "\$#$list_2_ref:", $#$list_2_ref, "\n"; 2508 ELEMENT: 2509 foreach my $indice ( 0 .. $#$list_1_ref ) { 2510 $last_used_indice = $indice; 2511 2512 # End of list_2 2513 return 1 if ($indice > $#$list_2_ref); 2514 2515 my $element_list_1 = $list_1_ref->[$indice]; 2516 my $element_list_2 = $list_2_ref->[$indice]; 2517 my $balance = $element_list_1 cmp $element_list_2 ; 2518 next ELEMENT if ($balance == 0) ; 2519 return $balance; 2520 } 2521 # each element equal until last indice of list_1 2522 return -1 if ($last_used_indice < $#$list_2_ref) ; 2523 2524 # same size, each element equal 2525 return 0 ; 2526} 2527 2528sub tests_compare_lists { 2529 2530 2531 my $empty_list_ref = []; 2532 2533 ok( 0 == compare_lists() , 'compare_lists, no args'); 2534 ok( 0 == compare_lists(undef) , 'compare_lists, undef = nothing'); 2535 ok( 0 == compare_lists(undef, undef) , 'compare_lists, undef = undef'); 2536 ok(-1 == compare_lists(undef , []) , 'compare_lists, undef < []'); 2537 ok(-1 == compare_lists(undef , [1]) , 'compare_lists, undef < [1]'); 2538 ok(-1 == compare_lists(undef , [0]) , 'compare_lists, undef < [0]'); 2539 ok(+1 == compare_lists([]) , 'compare_lists, [] > nothing'); 2540 ok(+1 == compare_lists([], undef) , 'compare_lists, [] > undef'); 2541 ok( 0 == compare_lists([] , []) , 'compare_lists, [] = []'); 2542 2543 ok(-1 == compare_lists([] , [1]) , 'compare_lists, [] < [1]'); 2544 ok(+1 == compare_lists([1] , []) , 'compare_lists, [1] > []'); 2545 2546 2547 ok( 0 == compare_lists([1], 1 ) , "compare_lists, [1] = 1 ") ; 2548 ok( 0 == compare_lists( 1 , [1]) , "compare_lists, 1 = [1]") ; 2549 ok( 0 == compare_lists( 1 , 1 ) , "compare_lists, 1 = 1 ") ; 2550 ok(-1 == compare_lists( 0 , 1 ) , "compare_lists, 0 < 1 ") ; 2551 ok(-1 == compare_lists(-1 , 0 ) , "compare_lists, -1 < 0 ") ; 2552 ok(-1 == compare_lists( 1 , 2 ) , "compare_lists, 1 < 2 ") ; 2553 ok(+1 == compare_lists( 2 , 1 ) , "compare_lists, 2 > 1 ") ; 2554 2555 2556 ok( 0 == compare_lists([1,2], [1,2]) , "compare_lists, [1,2] = [1,2]") ; 2557 ok(-1 == compare_lists([1], [1,2]) , "compare_lists, [1] < [1,2]") ; 2558 ok(+1 == compare_lists([2], [1,2]) , "compare_lists, [2] > [1,2]") ; 2559 ok(-1 == compare_lists([1], [1,1]) , "compare_lists, [1] < [1,1]") ; 2560 ok(+1 == compare_lists([1, 1], [1]) , "compare_lists, [1, 1] > [1]") ; 2561 ok( 0 == compare_lists([1 .. 20_000] , [1 .. 20_000]) 2562 , "compare_lists, [1..20_000] = [1..20_000]") ; 2563 ok(-1 == compare_lists([1], [3]) , 'compare_lists, [1] < [3]') ; 2564 ok( 0 == compare_lists([2], [2]) , 'compare_lists, [0] = [2]') ; 2565 ok(+1 == compare_lists([3], [1]) , 'compare_lists, [3] > [1]') ; 2566 2567 ok(-1 == compare_lists(["a"], ["b"]) , 'compare_lists, ["a"] < ["b"]') ; 2568 ok( 0 == compare_lists(["a"], ["a"]) , 'compare_lists, ["a"] = ["a"]') ; 2569 ok( 0 == compare_lists(["ab"], ["ab"]) , 'compare_lists, ["ab"] = ["ab"]') ; 2570 ok(+1 == compare_lists(["b"], ["a"]) , 'compare_lists, ["b"] > ["a"]') ; 2571 ok(-1 == compare_lists(["a"], ["aa"]) , 'compare_lists, ["a"] < ["aa"]') ; 2572 ok(-1 == compare_lists(["a"], ["a", "a"]), 'compare_lists, ["a"] < ["a", "a"]') ; 2573 ok( 0 == compare_lists([split(" ", "a b")], ["a", "b"]), 'compare_lists, split') ; 2574 ok( 0 == compare_lists([sort split(" ", "b a")], ["a", "b"]), 'compare_lists, sort split') ; 2575 return( ) ; 2576} 2577 2578 2579 2580sub get_prefix { 2581 my( $imap, $prefix_in, $prefix_opt ) = @_ ; 2582 my( $prefix_out ) ; 2583 2584 $debug and print "Getting prefix namespace\n" ; 2585 if ( defined( $prefix_in ) ) { 2586 print "Using [$prefix_in] given by $prefix_opt\n" ; 2587 $prefix_out = $prefix_in ; 2588 return( $prefix_out ) ; 2589 } 2590 $debug and print "Calling namespace capability\n" ; 2591 if ( $imap->has_capability( "namespace" ) ) { 2592 my $r_namespace = $imap->namespace( ) ; 2593 $prefix_out = $r_namespace->[0][0][0] ; 2594 return($prefix_out) ; 2595 } 2596 else{ 2597 print 2598 "No NAMESPACE capability in imap server ", 2599 $imap->Server( ),"\n", 2600 help_to_guess_prefix( $imap, $prefix_opt ) ; 2601 exit_clean( 1 ) ; 2602 } 2603 return( ) ; 2604} 2605 2606 2607sub get_separator { 2608 my($imap, $sep_in, $sep_opt) = @_; 2609 my($sep_out); 2610 2611 2612 if ( defined( $sep_in ) ) { 2613 print "Using [$sep_in] given by $sep_opt\n" ; 2614 $sep_out = $sep_in ; 2615 return( $sep_out ) ; 2616 } 2617 $debug and print "Calling namespace capability\n" ; 2618 if ($imap->has_capability( "namespace" ) ) { 2619 $sep_out = $imap->separator( ) ; 2620 return($sep_out) if defined $sep_out ; 2621 print 2622 "NAMESPACE request failed for ", 2623 $imap->Server(), ": ", $imap->LastError, "\n", 2624 help_to_guess_sep( $imap, $sep_opt ) ; 2625 exit_clean( 1 ) ; 2626 } 2627 else{ 2628 print 2629 "No NAMESPACE capability in imap server ", 2630 $imap->Server(),"\n", 2631 help_to_guess_sep( $imap, $sep_opt ) ; 2632 exit_clean( 1 ) ; 2633 } 2634 return( ) ; 2635} 2636 2637sub help_to_guess_sep { 2638 my( $imap, $sep_opt ) = @_ ; 2639 2640 my $help_to_guess_sep = "Give the separator character with the $sep_opt option,\n" 2641 . "the folowing listing of folders may help you to find it:\n" 2642 . folders_list_to_help($imap) 2643 . "Most of the time it is character . or /\n" 2644 . "so try $sep_opt . or $sep_opt /\n" ; 2645 2646 return( $help_to_guess_sep ) ; 2647} 2648 2649sub help_to_guess_prefix { 2650 my( $imap, $prefix_opt ) = @_ ; 2651 2652 my $help_to_guess_prefix = "Give the prefix namespace with the $prefix_opt option,\n" 2653 . "the folowing listing of folders may help you to find it:\n" 2654 . folders_list_to_help( $imap ) 2655 . "Most of the time it is INBOX. or an empty string\n" 2656 . "so try $prefix_opt INBOX. or $prefix_opt" . '""' . "\n" ; 2657 2658 return( $help_to_guess_prefix ) ; 2659} 2660 2661 2662sub folders_list_to_help { 2663 my($imap) = @_ ; 2664 2665 my @folders = $imap->folders ; 2666 my $listing = join('', map { "[$_]\n" } @folders) ; 2667 return( $listing ) ; 2668} 2669 2670 2671sub tests_separator_invert { 2672 $fixslash2 = 0 ; 2673 ok( not( defined( separator_invert( ) ) ), 'separator_invert: no args' ) ; 2674 ok( not( defined( separator_invert( '' ) ) ), 'separator_invert: not enough args' ) ; 2675 ok( not( defined( separator_invert( '', '' ) ) ), 'separator_invert: not enough args' ) ; 2676 2677 ok( '' eq separator_invert( '', '', '' ), 'separator_invert: 3 empty strings' ) ; 2678 ok( 'lalala' eq separator_invert( 'lalala', '', '' ), 'separator_invert: empty separator' ) ; 2679 ok( 'lalala' eq separator_invert( 'lalala', '/', '/' ), 'separator_invert: same separator /' ) ; 2680 ok( 'lal/ala' eq separator_invert( 'lal/ala', '/', '/' ), 'separator_invert: same separator / 2' ) ; 2681 ok( 'lal.ala' eq separator_invert( 'lal/ala', '/', '.' ), 'separator_invert: separators /.' ) ; 2682 ok( 'lal/ala' eq separator_invert( 'lal.ala', '.', '/' ), 'separator_invert: separators ./' ) ; 2683 ok( 'la.l/ala' eq separator_invert( 'la/l.ala', '.', '/' ), 'separator_invert: separators ./' ) ; 2684 2685 ok( 'l/al.ala' eq separator_invert( 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ; 2686 $fixslash2 = 1 ; 2687 ok( 'l_al.ala' eq separator_invert( 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ; 2688 2689 return( ) ; 2690} 2691 2692sub separator_invert { 2693 my( $h1_fold, $h1_separator, $h2_separator ) = @_ ; 2694 2695 return( undef ) if ( not defined( $h1_fold ) or not defined( $h1_separator ) or not defined( $h2_separator ) ) ; 2696 # The separator we hope we'll never encounter: 00000000 == 0x00 2697 my $o_sep="\000" ; 2698 2699 my $h2_fold = $h1_fold ; 2700 $h2_fold =~ s@\Q$h2_separator@$o_sep@xg ; 2701 $h2_fold =~ s@\Q$h1_separator@$h2_separator@xg ; 2702 $h2_fold =~ s@\Q$o_sep@$h1_separator@xg ; 2703 $h2_fold =~ s,/,_,xg if( $fixslash2 and '/' ne $h2_separator and '/' eq $h1_separator ) ; 2704 return( $h2_fold ) ; 2705} 2706 2707 2708sub tests_imap2_folder_name { 2709 2710$h1_prefix = $h2_prefix = ''; 2711$h1_sep = '/'; 2712$h2_sep = '.'; 2713 2714$debug and print <<"EOS" 2715prefix1: [$h1_prefix] 2716prefix2: [$h2_prefix] 2717sep1:[$h1_sep] 2718sep2:[$h2_sep] 2719EOS 2720; 2721 2722$fixslash2 = 0 ; 2723ok('' eq imap2_folder_name(''), 'imap2_folder_name: empty string'); 2724ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla'); 2725ok('spam.spam' eq imap2_folder_name('spam/spam'), 'imap2_folder_name: spam/spam'); 2726ok('spam/spam' eq imap2_folder_name('spam.spam'), 'imap2_folder_name: spam.spam'); 2727ok('spam.spam/spam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam'); 2728ok('s pam.spam/sp am' eq imap2_folder_name('s pam/spam.sp am'), 'imap2_folder_name: s pam/spam.sp am'); 2729@regextrans2 = ('s,/,X,g'); 2730ok('' eq imap2_folder_name(''), 'imap2_folder_name: empty string [s,/,X,g]'); 2731ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla [s,/,X,g]'); 2732ok('spam.spam' eq imap2_folder_name('spam/spam'), 'imap2_folder_name: spam/spam [s,/,X,g]'); 2733ok('spamXspam' eq imap2_folder_name('spam.spam'), 'imap2_folder_name: spam.spam [s,/,X,g]'); 2734ok('spam.spamXspam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam [s,/,X,g]'); 2735 2736@regextrans2 = ('s, ,_,g'); 2737ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla [s, ,_,g]'); 2738ok('bla_bla' eq imap2_folder_name('bla bla'), 'imap2_folder_name: blabla [s, ,_,g]'); 2739 2740@regextrans2 = ('s,(.*),\U$1,'); 2741ok('BLABLA' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla [s,\U(.*)\E,$1,]'); 2742 2743$fixslash2 = 1 ; 2744@regextrans2 = ( ) ; 2745ok('' eq imap2_folder_name(''), 'imap2_folder_name: empty string'); 2746ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla'); 2747ok('spam.spam' eq imap2_folder_name('spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam'); 2748ok('spam_spam' eq imap2_folder_name('spam.spam'), 'imap2_folder_name: spam.spam -> spam_spam'); 2749ok('spam.spam_spam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam_spam'); 2750ok('s pam.spam_spa m' eq imap2_folder_name('s pam/spam.spa m'), 'imap2_folder_name: s pam/spam.spa m -> s pam.spam_spa m'); 2751 2752$h1_sep = '.'; 2753$h2_sep = '/'; 2754ok('' eq imap2_folder_name(''), 'imap2_folder_name: empty string'); 2755ok('blabla' eq imap2_folder_name('blabla'), 'imap2_folder_name: blabla'); 2756ok('spam.spam' eq imap2_folder_name('spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam'); 2757ok('spam/spam' eq imap2_folder_name('spam.spam'), 'imap2_folder_name: spam.spam -> spam/spam'); 2758ok('spam.spam/spam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam'); 2759 2760$fixslash2 = 0 ; 2761$h1_prefix = ' '; 2762 2763ok('spam.spam/spam' eq imap2_folder_name('spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam'); 2764ok('spam.spam/spam' eq imap2_folder_name(' spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam'); 2765 2766 2767return( ) ; 2768 2769} 2770 2771sub imap2_folder_name { 2772 my ( $x_fold ) = @_ ; 2773 my ( $h2_fold ) ; 2774 # first we remove the prefix 2775 $x_fold =~ s/^\Q$h1_prefix\E//x ; 2776 $debug and print "removed host1 prefix: [$x_fold]\n"; 2777 $h2_fold = separator_invert($x_fold,$h1_sep, $h2_sep); 2778 $debug and print "inverted separators: [$h2_fold]\n"; 2779 # Adding the prefix supplied by namespace or the --prefix2 option 2780 $h2_fold = $h2_prefix . $h2_fold 2781 unless(($h2_prefix eq "INBOX" . $h2_sep) and ($h2_fold =~ m/^INBOX$/xi)); 2782 $debug and print "added host2 prefix: [$h2_fold]\n"; 2783 2784 # Transforming the folder name by the --regextrans2 option(s) 2785 foreach my $regextrans2 (@regextrans2) { 2786 my $h2_fold_before = $h2_fold; 2787 my $ret = eval( "\$h2_fold =~ $regextrans2 ; 1 ") ; 2788 $debug and print "[$h2_fold_before] -> [$h2_fold] using re [$regextrans2]\n" ; 2789 if ( not ( defined( $ret ) ) or $@ ) { 2790 die_clean("error: eval regextrans2 '$regextrans2': $@\n") ; 2791 } 2792 } 2793 return($h2_fold); 2794} 2795 2796sub tests_decompose_regex { 2797 ok( 1, 'decompose_regex 1' ) ; 2798 ok( 0 == compare_lists( [ '', '' ], [ decompose_regex( '' ) ] ), 'decompose_regex empty string' ) ; 2799 ok( 0 == compare_lists( [ '.*', 'lala' ], [ decompose_regex( 's/.*/lala/' ) ] ), 'decompose_regex s/.*/lala/' ) ; 2800 return( ) ; 2801} 2802 2803sub decompose_regex { 2804 my $regex = shift ; 2805 my( $left_part, $right_part ) ; 2806 2807 ( $left_part, $right_part ) = $regex =~ m{^s/((?:[^/]|\\/)+)/((?:[^/]|\\/)+)/}x; 2808 return( '', '' ) if not $left_part ; 2809 return( $left_part, $right_part ) ; 2810} 2811 2812 2813sub foldersizes { 2814 2815 my ( $side, $imap, $search_cmd, @folders ) = @_ ; 2816 my $total_size = 0 ; 2817 my $total_nb = 0 ; 2818 my $biggest_in_all = 0 ; 2819 2820 print "++++ Calculating sizes on $side\n" ; 2821 foreach my $folder ( @folders ) { 2822 my $stot = 0 ; 2823 my $nb_msgs = 0 ; 2824 printf( "$side folder %-35s", "[$folder]" ) ; 2825 if ( 'Host2' eq $side and not exists( $h2_folders_all{ $folder } ) ) { 2826 print(" does not exist yet\n") ; 2827 next ; 2828 } 2829 if ( 'Host1' eq $side and not exists( $h1_folders_all{ $folder } ) ) { 2830 print( " does not exist\n" ) ; 2831 next ; 2832 } 2833 2834 unless ( $imap->examine( $folder ) ) { 2835 print 2836 "$side Folder $folder: Could not examine: ", 2837 $imap->LastError, "\n" ; 2838 $nb_errors++ ; 2839 next ; 2840 } 2841 2842 my $hash_ref = { } ; 2843 my @msgs = select_msgs( $imap, undef, $search_cmd, $folder ) ; 2844 $nb_msgs = scalar( @msgs ) ; 2845 my $biggest_in_folder = 0 ; 2846 @$hash_ref{ @msgs } = ( undef ) if @msgs ; 2847 if ( $nb_msgs > 0 and @msgs ) { 2848 if ( $abletosearch ) { 2849 $imap->fetch_hash( \@msgs, "RFC822.SIZE", $hash_ref) or die_clean("$@" ) ; 2850 }else{ 2851 my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ; 2852 $imap->fetch_hash( "1:$uidnext", "RFC822.SIZE", $hash_ref ) or die_clean( "$@" ) ; 2853 } 2854 for ( keys %$hash_ref ) { 2855 my $size = $hash_ref->{ $_ }->{ "RFC822.SIZE" } ; 2856 $stot += $size ; 2857 $biggest_in_folder = max( $biggest_in_folder, $size ) ; 2858 } 2859 } 2860 2861 printf( " Size: %9s", $stot ) ; 2862 printf( " Messages: %5s", $nb_msgs ) ; 2863 printf( " Biggest: %9s\n", $biggest_in_folder ) ; 2864 $total_size += $stot ; 2865 $total_nb += $nb_msgs ; 2866 $biggest_in_all = max( $biggest_in_all, $biggest_in_folder ) ; 2867 } 2868 printf ( "%s Nb messages: %11s messages\n", $side, $total_nb ) ; 2869 printf ( "%s Total size: %11s bytes (%s)\n", $side, $total_size, bytes_display_string( $total_size ) ) ; 2870 printf ( "%s Biggest message: %11s bytes (%s)\n", $side, $biggest_in_all, bytes_display_string( $biggest_in_all ) ) ; 2871 printf ( "%s Time spent: %11.1f seconds\n", $side, timenext( ) ) ; 2872 return( $total_nb, $total_size ) ; 2873} 2874 2875sub timenext { 2876 my ( $timenow, $timediff ) ; 2877 # $timebefore is global, beurk ! 2878 $timenow = time ; 2879 $timediff = $timenow - $timebefore ; 2880 $timebefore = $timenow ; 2881 return( $timediff ) ; 2882} 2883 2884sub timesince { 2885 my $timeinit = shift ; 2886 my ( $timenow, $timediff ) ; 2887 $timenow = time ; 2888 $timediff = $timenow - $timeinit ; 2889 return( $timediff ) ; 2890} 2891 2892 2893 2894 2895sub tests_flags_regex { 2896 2897 2898 ok('' eq flags_regex(''), "flags_regex, null string ''"); 2899 ok('\Seen NonJunk $Spam' eq flags_regex('\Seen NonJunk $Spam'), 'flags_regex, nothing to do'); 2900 2901 @regexflag = ('I am BAD' ) ; 2902 ok( not ( defined( flags_regex( '' ) ) ), 'flags_regex, bad regex' ) ; 2903 2904 @regexflag = ('s/NonJunk//g'); 2905 ok('\Seen $Spam' eq flags_regex('\Seen NonJunk $Spam'), "flags_regex, remove NonJunk: 's/NonJunk//g'"); 2906 @regexflag = ('s/\$Spam//g'); 2907 ok('\Seen NonJunk ' eq flags_regex('\Seen NonJunk $Spam'), 'flags_regex, remove $Spam: '."'s/\$Spam//g'"); 2908 2909 @regexflag = ('s/\\\\Seen//g'); 2910 2911 ok(' NonJunk $Spam' eq flags_regex('\Seen NonJunk $Spam'), 'flags_regex, remove \Seen: '. "'s/\\\\\\\\Seen//g'"); 2912 2913 @regexflag = ('s/(\s|^)[^\\\\]\w+//g'); 2914 ok('\Seen \Middle \End' eq flags_regex('\Seen NonJunk \Middle $Spam \End'), 'flags_regex, only \word [' . flags_regex('\Seen NonJunk \Middle $Spam \End'.']')); 2915 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'.']')); 2916 2917 @regexflag = ('s/.*?(Keep1|Keep2|Keep3)/$1 /g'); 2918 ok('Keep1 Keep2 ReB' eq flags_regex('ReA Keep1 REM Keep2 ReB'), "Keep only regex"); 2919 #ok('Keep1 Keep2' eq flags_regex('Keep1 Keep2 Remove1'), "Keep only regex"); 2920 ok('Keep1 Keep2 ' eq flags_regex('REM REM Keep1 Keep2'), "Keep only regex"); 2921 ok('Keep1 Keep2 ' eq flags_regex('Keep1 REM REM Keep2'), "Keep only regex"); 2922 ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM REM Keep2'), "Keep only regex"); 2923 ok('Keep1 Keep2 ' eq flags_regex('Keep1 Keep2'), "Keep only regex"); 2924 ok('Keep1 ' eq flags_regex('REM Keep1'), "Keep only regex"); 2925 2926 @regexflag = ('s/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g'); 2927 ok('Keep1 Keep2 ' eq flags_regex('Keep1 Keep2 ReB'), "Keep only regex"); 2928 ok('Keep1 Keep2 ' eq flags_regex('Keep1 Keep2 REM REM REM'), "Keep only regex"); 2929 ok('Keep2 ' eq flags_regex('Keep2 REM REM REM'), "Keep only regex"); 2930 #ok('' eq flags_regex('REM REM'), "Keep only regex"); 2931 2932 @regexflag = ('s/.*?(Keep1|Keep2|Keep3)/$1 /g', 2933 's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g'); 2934 ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), "Keep only regex"); 2935 ok('Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), "Keep only regex"); 2936 ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), "Keep only regex"); 2937 ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), "Keep only regex"); 2938 ok('Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), "Keep only regex"); 2939 ok('Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), "Keep only regex"); 2940 ok('Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), "Keep only regex"); 2941 2942 @regexflag = ('s/(.*)/$1 jrdH8u/'); 2943 ok('REM REM REM REM REM jrdH8u' eq flags_regex('REM REM REM REM REM'), "Keep only regex 's/(.*)/\$1 jrdH8u/'") ; 2944 @regexflag = ('s/jrdH8u *//'); 2945 ok('REM REM REM REM REM ' eq flags_regex('REM REM REM REM REM jrdH8u'), "Keep only regex s/jrdH8u *//") ; 2946 2947 @regexflag = ( 2948 's/(.*)/$1 jrdH8u/', 2949 's/.*?(Keep1|Keep2|Keep3|jrdH8u)/$1 /g', 2950 's/(Keep1|Keep2|Keep3|jrdH8u) (?!(Keep1|Keep2|Keep3|jrdH8u)).*/$1 /g', 2951 's/jrdH8u *//' 2952 ); 2953 2954 ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), "Keep only regex 'REM Keep1 REM Keep2 REM'"); 2955 ok('Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), "Keep only regex"); 2956 ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), "Keep only regex"); 2957 ok('Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), "Keep only regex"); 2958 ok('Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), "Keep only regex"); 2959 ok('Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), "Keep only regex"); 2960 ok('Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), "Keep only regex"); 2961 ok('' eq flags_regex('REM REM REM REM REM'), "Keep only regex"); 2962 2963 @regexflag = ( 2964 's/(.*)/$1 jrdH8u/', 2965 's/.*?(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u)/$1 /g', 2966 's/(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u) (?!(\\\\Seen|\\\\Answered|\\\\Flagged|\\\\Deleted|\\\\Draft|jrdH8u)).*/$1 /g', 2967 's/jrdH8u *//' 2968 ); 2969 2970 ok('\\Deleted \\Answered ' 2971 eq flags_regex('Blabla $Junk \\Deleted machin \\Answered truc'), "Keep only regex: Exchange case"); 2972 ok('' eq flags_regex(''), "Keep only regex: Exchange case, null string"); 2973 ok('' 2974 eq flags_regex('Blabla $Junk machin truc'), "Keep only regex: Exchange case, no accepted flags "); 2975 ok('\\Deleted \\Answered \\Draft \\Flagged ' 2976 eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), "Keep only regex: Exchange case"); 2977 2978 2979 @regexflag = ( 2980 's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg' 2981 ); 2982 2983 ok('\\Deleted \\Answered ' 2984 eq flags_regex('Blabla \$Junk \\Deleted machin \\Answered truc'), 2985 "Keep only regex: Exchange case (Phil)"); 2986 2987 ok('' eq flags_regex(''), "Keep only regex: Exchange case, null string (Phil)"); 2988 2989 ok('' 2990 eq flags_regex('Blabla $Junk machin truc'), 2991 "Keep only regex: Exchange case, no accepted flags (Phil)"); 2992 2993 ok('\\Deleted \\Answered \\Draft \\Flagged ' 2994 eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), 2995 "Keep only regex: Exchange case (Phil)"); 2996 2997 return( ) ; 2998} 2999 3000sub flags_regex { 3001 my ( $h1_flags ) = @_ ; 3002 foreach my $regexflag ( @regexflag ) { 3003 my $h1_flags_orig = $h1_flags ; 3004 $debugflags and print "eval \$h1_flags =~ $regexflag\n" ; 3005 my $ret = eval( "\$h1_flags =~ $regexflag ; 1 " ) ; 3006 $debugflags and print "regexflag $regexflag [$h1_flags_orig] -> [$h1_flags]\n" ; 3007 if( not ( defined $ret ) or $@ ) { 3008 print "Error: eval regexflag '$regexflag': $@\n" ; 3009 return( undef ) ; 3010 } 3011 } 3012 return( $h1_flags ) ; 3013} 3014 3015sub acls_sync { 3016 my($h1_fold, $h2_fold) = @_ ; 3017 if ( $syncacls ) { 3018 my $h1_hash = $imap1->getacl($h1_fold) 3019 or print "Could not getacl for $h1_fold: $@\n"; 3020 my $h2_hash = $imap2->getacl($h2_fold) 3021 or print "Could not getacl for $h2_fold: $@\n"; 3022 my %users = map({ ($_, 1) } (keys(%$h1_hash), keys(%$h2_hash))); 3023 foreach my $user (sort(keys(%users))) { 3024 my $acl = $h1_hash->{$user} || "none"; 3025 print "acl $user: [$acl]\n"; 3026 next if ($h1_hash->{$user} && $h2_hash->{$user} && 3027 $h1_hash->{$user} eq $h2_hash->{$user}); 3028 unless ($dry) { 3029 print "setting acl $h2_fold $user $acl\n"; 3030 $imap2->setacl($h2_fold, $user, $acl) 3031 or print "Could not set acl: $@\n"; 3032 } 3033 } 3034 } 3035 return( ) ; 3036} 3037 3038 3039sub tests_permanentflags { 3040 3041 my $string; 3042 ok('' eq permanentflags(' * OK [PERMANENTFLAGS (\* \Draft \Answered)] Limited'), 3043 'permanentflags \*'); 3044 ok('\Draft \Answered' eq permanentflags(' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited'), 3045 'permanentflags \Draft \Answered'); 3046 ok('\Draft \Answered' 3047 eq permanentflags('Blabla', 3048 ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited', 3049 'Blabla'), 3050 'permanentflags \Draft \Answered' 3051 ); 3052 ok('' eq permanentflags('Blabla'), 'permanentflags nothing'); 3053 return( ) ; 3054} 3055 3056sub permanentflags { 3057 my @lines = @_ ; 3058 3059 foreach my $line (@lines) { 3060 if ( $line =~ m{\[PERMANENTFLAGS\s\(([^)]+?)\)\]}x ) { 3061 ( $debugflags or $debug ) and print "permanentflags: $line" ; 3062 my $permanentflags = $1 ; 3063 if ( $permanentflags =~ m{\\\*}x ) { 3064 $permanentflags = '' ; 3065 } 3066 return($permanentflags) ; 3067 } ; 3068 } 3069 return( '' ) ; 3070} 3071 3072sub tests_flags_filter { 3073 3074 ok( '\Seen' eq flags_filter('\Seen', '\Draft \Seen \Answered'), 'flags_filter ' ); 3075 ok( '' eq flags_filter('\Seen', '\Draft \Answered'), 'flags_filter ' ); 3076 ok( '\Seen' eq flags_filter('\Seen', '\Seen'), 'flags_filter ' ); 3077 ok( '\Seen' eq flags_filter('\Seen', ' \Seen '), 'flags_filter ' ); 3078 ok( '\Seen \Draft' 3079 eq flags_filter('\Seen \Draft', '\Draft \Seen \Answered'), 'flags_filter ' ); 3080 ok( '\Seen \Draft' 3081 eq flags_filter('\Seen \Draft', ' \Draft \Seen \Answered '), 'flags_filter ' ); 3082 return( ) ; 3083} 3084 3085sub flags_filter { 3086 my( $flags, $allowed_flags ) = @_ ; 3087 3088 my @flags = split( /\s+/x, $flags ) ; 3089 my %allowed_flags = map { $_ => 1 } split(' ', $allowed_flags ) ; 3090 my @flags_out = map { exists $allowed_flags{$_} ? $_ : () } @flags ; 3091 3092 my $flags_out = join( ' ', @flags_out ) ; 3093 #print "%%%$flags_out%%%\n" ; 3094 return( $flags_out ) ; 3095} 3096 3097sub flagsCase { 3098 my $flags = shift ; 3099 3100 my @flags = split( /\s+/x, $flags ); 3101 my %rfc_flags = map { $_ => 1 } split(' ', '\Answered \Flagged \Deleted \Seen \Draft' ); 3102 my @flags_out = map { exists $rfc_flags{ ucsecond( lc( $_ ) ) } ? ucsecond( lc( $_ ) ) : $_ } @flags ; 3103 3104 my $flags_out = join( ' ', @flags_out ) ; 3105 #print "%%%$flags_out%%%\n" ; 3106 return( $flags_out ) ; 3107} 3108 3109sub tests_flagsCase { 3110 ok( '\Seen' eq flagsCase( '\Seen' ), 'flagsCase: \Seen -> \Seen' ) ; 3111 ok( '\Seen' eq flagsCase( '\SEEN' ), 'flagsCase: \SEEN -> \Seen' ) ; 3112 3113 ok( '\Seen \Draft' eq flagsCase( '\SEEN \DRAFT' ), 'flagsCase: \SEEN \DRAFT -> \Seen \Draft' ) ; 3114 ok( '\Draft \Seen' eq flagsCase( '\DRAFT \SEEN' ), 'flagsCase: \DRAFT \SEEN -> \Draft \Seen' ) ; 3115 3116 ok( '\Draft LALA \Seen' eq flagsCase( '\DRAFT LALA \SEEN' ), 'flagsCase: \DRAFT LALA \SEEN -> \Draft LALA \Seen' ) ; 3117 ok( '\Draft lala \Seen' eq flagsCase( '\DRAFT lala \SEEN' ), 'flagsCase: \DRAFT lala \SEEN -> \Draft lala \Seen' ) ; 3118 return( ) ; 3119} 3120 3121sub ucsecond { 3122 my $string = shift ; 3123 my $output ; 3124 3125 return( $string ) if ( 1 >= length( $string ) ) ; 3126 $output = substr( $string, 0, 1) . uc( substr( $string, 1, 1 ) ) if ( 2 == length( $string ) ) ; 3127 $output = substr( $string, 0, 1) . uc( substr( $string, 1, 1 ) ) . substr( $string, 2 ); 3128 #print "UUU $string -> $output\n" ; 3129 return( $output ) ; 3130} 3131 3132 3133sub tests_ucsecond { 3134 ok( 'aBcde' eq ucsecond( 'abcde' ), 'ucsecond: abcde -> aBcde' ) ; 3135 ok( 'ABCDE' eq ucsecond( 'ABCDE' ), 'ucsecond: ABCDE -> ABCDE' ) ; 3136 ok( 'ABCDE' eq ucsecond( 'AbCDE' ), 'ucsecond: AbCDE -> ABCDE' ) ; 3137 ok( 'ABCde' eq ucsecond( 'AbCde' ), 'ucsecond: AbCde -> ABCde' ) ; 3138 ok( 'A' eq ucsecond( 'A' ), 'ucsecond: A -> A' ) ; 3139 ok( 'AB' eq ucsecond( 'Ab' ), 'ucsecond: Ab -> AB' ) ; 3140 ok( '\B' eq ucsecond( '\b' ), 'ucsecond: \b -> \B' ) ; 3141 ok( '\Bcde' eq ucsecond( '\bcde' ), 'ucsecond: \bcde -> \Bcde' ) ; 3142 return( ) ; 3143} 3144 3145 3146sub select_msgs { 3147 my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ; 3148 my ( @msgs ) ; 3149 3150 if ( $abletosearch ) { 3151 @msgs = select_msgs_by_search( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; 3152 }else{ 3153 @msgs = select_msgs_by_fetch( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; 3154 } 3155 3156} 3157 3158sub select_msgs_by_search { 3159 my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ; 3160 my ( @msgs, @msgs_all ) ; 3161 3162 # Need to have the whole list in msgs_all_hash_ref 3163 # without calling messages() several times. 3164 # Need all messages list to avoid deleting useful cache part 3165 # in case of --search or --minage or --maxage 3166 3167 if ( ( defined( $msgs_all_hash_ref ) and $usecache ) 3168 or ( not defined( $maxage ) and not defined( $minage ) and not defined( $search_cmd ) ) 3169 ) { 3170 3171 $debugdev and print "Calling messages()\n" ; 3172 @msgs_all = $imap->messages() ; 3173 3174 return if ( $#msgs_all == 0 && !defined( $msgs_all[0] ) ) ; 3175 3176 if ( defined( $msgs_all_hash_ref ) ) { 3177 @{ $msgs_all_hash_ref }{ @msgs_all } = () ; 3178 } 3179 # return all messages 3180 if ( not defined( $maxage ) and not defined( $minage ) and not defined( $search_cmd ) ) { 3181 return( @msgs_all ) ; 3182 } 3183 } 3184 3185 if ( defined( $search_cmd ) ) { 3186 @msgs = $imap->search( $search_cmd ) ; 3187 return( @msgs ) ; 3188 } 3189 3190 # we are here only if $maxage or $minage is defined 3191 @msgs = select_msgs_by_age( $imap ) ; 3192 return( @msgs ); 3193} 3194 3195 3196sub select_msgs_by_fetch { 3197 my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ; 3198 my ( @msgs, @msgs_all, %fetch ) ; 3199 3200 # Need to have the whole list in msgs_all_hash_ref 3201 # without calling messages() several times. 3202 # Need all messages list to avoid deleting useful cache part 3203 # in case of --search or --minage or --maxage 3204 3205 3206 $debugdev and print "Calling fetch_hash()\n" ; 3207 my $uidnext = $imap->uidnext( $folder ) or return( ) ; 3208 %fetch = %{$imap->fetch_hash( "1:$uidnext", "INTERNALDATE") } ; 3209 @msgs_all = sort { $a <=> $b } keys( %fetch ) ; 3210 $debugdev and print "Done fetch_hash()\n" ; 3211 3212 return( ) if ( $#msgs_all == 0 && !defined( $msgs_all[0] ) ) ; 3213 3214 if ( defined( $msgs_all_hash_ref ) ) { 3215 @{ $msgs_all_hash_ref }{ @msgs_all } = () ; 3216 } 3217 # return all messages 3218 if ( not defined( $maxage ) and not defined( $minage ) and not defined( $search_cmd ) ) { 3219 return( @msgs_all ) ; 3220 } 3221 3222 if ( defined( $search_cmd ) ) { 3223 print "Warning: strange to see --search with --noabletosearch, an error can happen\n" ; 3224 @msgs = $imap->search( $search_cmd ) ; 3225 return( @msgs ) ; 3226 } 3227 3228 # we are here only if $maxage or $minage is defined 3229 my( @max, @min, $maxage_epoch, $minage_epoch ) ; 3230 if ( defined( $maxage ) ) { $maxage_epoch = $timestart_int - 86400 * $maxage ; } 3231 if ( defined( $minage ) ) { $minage_epoch = $timestart_int - 86400 * $minage ; } 3232 foreach my $msg ( @msgs_all ) { 3233 my $idate = $fetch{ $msg }->{'INTERNALDATE'} ; 3234 #print "$idate\n" ; 3235 if ( defined( $maxage ) and ( epoch( $idate ) >= $maxage_epoch ) ) { 3236 push( @max, $msg ) ; 3237 } 3238 if ( defined( $minage ) and ( epoch( $idate ) <= $minage_epoch ) ) { 3239 push( @min, $msg ) ; 3240 } 3241 } 3242 @msgs = msgs_from_maxmin( \@max, \@min ) ; 3243 return( @msgs ) ; 3244} 3245 3246sub select_msgs_by_age { 3247 my( $imap ) = @_ ; 3248 3249 my( @max, @min, @msgs, @inter, @union ) ; 3250 3251 if ( defined( $maxage ) ) { 3252 @max = $imap->sentsince( $timestart_int - 86400 * $maxage ) ; 3253 } 3254 if ( defined( $minage ) ) { 3255 @min = $imap->sentbefore( $timestart_int - 86400 * $minage ) ; 3256 } 3257 3258 @msgs = msgs_from_maxmin( \@max, \@min ) ; 3259 return( @msgs ) ; 3260} 3261 3262sub msgs_from_maxmin { 3263 my( $max_ref, $min_ref ) = @_ ; 3264 my( @max, @min, @msgs, @inter, @union ) ; 3265 3266 @max = @$max_ref ; 3267 @min = @$min_ref ; 3268 3269 SWITCH: { 3270 unless( defined( $minage ) ) { @msgs = @max ; last SWITCH } ; 3271 unless( defined( $maxage ) ) { @msgs = @min ; last SWITCH } ; 3272 my ( %union, %inter ) ; 3273 foreach my $m ( @min, @max ) { $union{ $m }++ && $inter{ $m }++ } 3274 @inter = sort { $a <=> $b } keys( %inter ) ; 3275 @union = sort { $a <=> $b } keys( %union ) ; 3276 # normal case 3277 if ( $minage <= $maxage ) { @msgs = @inter ; last SWITCH } ; 3278 # just exclude messages between 3279 if ( $minage > $maxage ) { @msgs = @union ; last SWITCH } ; 3280 3281 } 3282 return( @msgs ); 3283} 3284 3285sub tests_msgs_from_maxmin { 3286 my @msgs ; 3287 $maxage = 200 ; 3288 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; 3289 ok( 0 == compare_lists( [ '1', '2' ], \@msgs ), 'msgs_from_maxmin: maxage++' ) ; 3290 $minage = 100 ; 3291 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; 3292 ok( 0 == compare_lists( [ '2' ], \@msgs ), 'msgs_from_maxmin: -maxage++minage-' ) ; 3293 $minage = 300 ; 3294 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; 3295 ok( 0 == compare_lists( [ '1', '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++maxage-minage++' ) ; 3296 $maxage = undef ; 3297 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; 3298 ok( 0 == compare_lists( [ '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++minage-' ) ; 3299} 3300 3301 3302sub lastuid { 3303 my $imap = shift ; 3304 my $folder = shift ; 3305 my $lastuid_guess = shift ; 3306 my $lastuid ; 3307 3308 # rfc3501: The only reliable way to identify recent messages is to 3309 # look at message flags to see which have the \Recent flag 3310 # set, or to do a SEARCH RECENT. 3311 # SEARCH RECENT doesn't work this way on courrier. 3312 3313 my @recent_messages ; 3314 # SEARCH RECENT for each transfer can be expensive with a big folder 3315 # Call commented for now 3316 #@recent_messages = $imap->recent( ) ; 3317 #print "Recent: @recent_messages\n"; 3318 3319 my $max_recent ; 3320 $max_recent = max( @recent_messages ) ; 3321 3322 if ( defined( $max_recent ) and ($lastuid_guess <= $max_recent ) ) { 3323 $lastuid = $max_recent ; 3324 }else{ 3325 $lastuid = $lastuid_guess 3326 } 3327 return( $lastuid ) ; 3328} 3329 3330sub size_filtered { 3331 my( $h1_size, $h1_msg, $h1_fold, $h2_fold ) = @_ ; 3332 3333 $h1_size = 0 if ( ! $h1_size ) ; # null if empty or undef 3334 if (defined $maxsize and $h1_size > $maxsize) { 3335 print "msg $h1_fold/$h1_msg skipped ($h1_size exceeds maxsize limit $maxsize bytes)\n"; 3336 $total_bytes_skipped += $h1_size; 3337 $nb_msg_skipped += 1; 3338 return( 1 ) ; 3339 } 3340 if (defined $minsize and $h1_size <= $minsize) { 3341 print "msg $h1_fold/$h1_msg skipped ($h1_size smaller than minsize $minsize bytes)\n"; 3342 $total_bytes_skipped += $h1_size; 3343 $nb_msg_skipped += 1; 3344 return( 1 ) ; 3345 } 3346 return( 0 ) ; 3347} 3348 3349sub message_exists { 3350 3351 my( $imap, $msg ) = @_ ; 3352 return( 1 ) if not $imap->Uid( ) ; 3353 3354 my $search_uid ; 3355 ( $search_uid ) = $imap->search( "UID $msg" ) ; 3356 #print "$search ? $msg\n" ; 3357 return( 1 ) if ( $search_uid eq $msg ) ; 3358 return( 0 ) ; 3359 3360} 3361 3362sub copy_message { 3363 # copy 3364 3365 my ( $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) = @_ ; 3366 ( $debug or $dry) and print "msg $h1_fold/$h1_msg copying to $h2_fold $dry_message\n"; 3367 3368 my $h1_size = $h1_fir_ref->{$h1_msg}->{"RFC822.SIZE"} || '' ; 3369 my $h1_flags = $h1_fir_ref->{$h1_msg}->{"FLAGS"} || '' ; 3370 my $h1_idate = $h1_fir_ref->{$h1_msg}->{"INTERNALDATE"} || '' ; 3371 3372 3373 if ( size_filtered( $h1_size, $h1_msg, $h1_fold, $h2_fold ) ) { 3374 $h1_nb_msg_processed +=1 ; 3375 return( ) ; 3376 } 3377 3378 do { print "SLEEP 5\n" and sleep 5 ; } if ( $debugsleep ) ; 3379 print "- msg $h1_fold/$h1_msg S[$h1_size] F[$h1_flags] I[$h1_idate] has RFC822.SIZE null!\n" if ( ! $h1_size ) ; 3380 3381 3382 if ( $checkmessageexists and not message_exists( $imap1, $h1_msg ) ) { 3383 $h1_nb_msg_processed +=1 ; 3384 return( ) ; 3385 } 3386 3387 my ( $string, $string_len ) ; 3388 ( $string, $string_len ) = message_for_host2( $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref ) ; 3389 3390 # Lines two long => do no copy 3391 if ( ( defined ( $maxlinelength ) ) 3392 and ( max_line_length( $string ) > $maxlinelength ) ) { 3393 my $subject = subject( $string ) ; 3394 #print "[$subject]\n" ; 3395 print "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] " 3396 . "(Subject:[$subject]) (line length exceeds maxlinelength $maxlinelength bytes)\n" ; 3397 return( ) ; 3398 } 3399 3400 my $h1_date = date_for_host2( $h1_msg, $h1_idate ) ; 3401 3402 ( $debug or $debugflags ) and 3403 print "Host1 flags init msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ; 3404 3405 $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ; 3406 3407 ( $debug or $debugflags ) and 3408 print "Host1 flags filt msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ; 3409 3410 $h1_date = undef if ($h1_date eq ""); 3411 3412 my $new_id = append_message_on_host2( $string, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) ; 3413 3414 if ( $new_id and $syncflagsaftercopy ) { 3415 sync_flags_after_copy( $h1_fold, $h1_msg, $h1_flags, $h2_fold, $new_id, $permanentflags2 ) ; 3416 } 3417 3418 3419 return( $new_id ) ; 3420} 3421 3422sub message_for_host2 { 3423 my ( $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref ) = @_ ; 3424 3425 my $string = $imap1->message_string( $h1_msg ) ; 3426 3427 my $string_len = defined( $string ) ? length( $string ) : '' ; # length or empty string 3428 #print "- msg $h1_fold/$h1_msg {$string_len}\n" ; 3429 unless ( defined( $string ) and $string_len ) { # undef or 0 length 3430 print 3431 "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] could not be fetched: ", 3432 $imap1->LastError || '', "\n" ; 3433 $nb_errors++ ; 3434 $total_bytes_error += $h1_size if ( $h1_size ) ; 3435 #relogin1( ) if ( $relogin1 ) ; 3436 $h1_nb_msg_processed +=1 ; 3437 return( ) ; 3438 } 3439 3440 if ( @regexmess ) { 3441 $string = regexmess( $string ) ; 3442 # string undef means the eval regex was bad. 3443 if ( not ( defined( $string ) ) ) { 3444 print 3445 "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" 3446 . " could not be transformed by --regexmess option\n" ; 3447 return( ) ; 3448 } 3449 } 3450 3451 if ( $addheader and defined $h1_fir_ref->{$h1_msg}->{"NO_HEADER"} ) { 3452 my $header = add_header( $h1_msg ) ; 3453 $debug and print "msg $h1_fold/$h1_msg adding custom header [$header]\n" ; 3454 $string = $header . "\r\n" . $string ; 3455 } 3456 3457 3458 $debugcontent and print 3459 "=" x80, "\n", 3460 "F message content begin next line\n", 3461 $string, 3462 "F message content ended on previous line\n", "=" x 80, "\n"; 3463 3464 return( $string, $string_len ) ; 3465} 3466 3467sub date_for_host2 { 3468 my( $h1_msg, $h1_idate ) = @_ ; 3469 3470 my $h1_date = "" ; 3471 3472 if ( $syncinternaldates ) { 3473 $h1_date = $h1_idate ; 3474 $debug and print "internal date from host1: [$h1_date]\n" ; 3475 $h1_date = good_date( $h1_date ) ; 3476 $debug and print "internal date from host1: [$h1_date] (fixed)\n" ; 3477 } 3478 3479 if ( $idatefromheader ) { 3480 $h1_date = $imap1->get_header($h1_msg,"Date") ; 3481 $debug and print "header date from host1: [$h1_date]\n" ; 3482 $h1_date = good_date( $h1_date ) ; 3483 $debug and print "header date from host1: [$h1_date] (fixed)\n" ; 3484 } 3485 3486 return( $h1_date ) ; 3487} 3488 3489sub flags_for_host2 { 3490 my( $h1_flags, $permanentflags2 ) = @_ ; 3491 # RFC 2060: This flag can not be altered by any client 3492 $h1_flags =~ s@\\Recent\s?@@xgi ; 3493 my $h1_flags_re ; 3494 if ( @regexflag and defined( $h1_flags_re = flags_regex( $h1_flags ) ) ) { 3495 $h1_flags = $h1_flags_re ; 3496 } 3497 $h1_flags = flagsCase( $h1_flags ) if $flagsCase ; 3498 $h1_flags = flags_filter( $h1_flags, $permanentflags2) if ( $permanentflags2 and $filterflags ) ; 3499 3500 return( $h1_flags ) ; 3501} 3502 3503sub subject { 3504 my $string = shift ; 3505 my $subject = '' ; 3506 3507 my $header = extract_header( $string ) ; 3508 3509 if( $header =~ m/^Subject:\s*([^\n\r]*)\r?$/msx ) { 3510 #print "MMM[$1]\n" ; 3511 $subject = $1 ; 3512 } 3513 return( $subject ) ; 3514} 3515 3516sub tests_subject { 3517 ok( '' eq subject( '' ), 'subject: null') ; 3518 ok( 'toto le hero' eq subject( 'Subject: toto le hero' ), 'subject: toto le hero') ; 3519 ok( 'toto le hero' eq subject( 'Subject:toto le hero' ), 'subject: toto le hero blank') ; 3520 ok( 'toto le hero' eq subject( "Subject:toto le hero\r\n" ), 'subject: toto le hero\r\n') ; 3521 3522 my $MESS ; 3523 $MESS = <<'EOF'; 3524From: lalala 3525Subject: toto le hero 3526Date: zzzzzz 3527 3528Boogie boogie 3529EOF 3530 ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 2') ; 3531 3532 $MESS = <<'EOF'; 3533Subject: toto le hero 3534From: lalala 3535Date: zzzzzz 3536 3537Boogie boogie 3538EOF 3539 ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 3') ; 3540 3541 3542 $MESS = <<'EOF'; 3543From: lalala 3544Subject: cuicui 3545Date: zzzzzz 3546 3547Subject: toto le hero 3548EOF 3549 ok( 'cuicui' eq subject( $MESS ), 'subject: cuicui') ; 3550 3551 $MESS = <<'EOF'; 3552From: lalala 3553Date: zzzzzz 3554 3555Subject: toto le hero 3556EOF 3557 ok( '' eq subject( $MESS ), 'subject: null but body could') ; 3558 3559 3560} 3561 3562 3563# GlobVar 3564# $dry 3565# $max_msg_size_in_bytes 3566# $imap2 3567# $imap1 3568# $nb_errors 3569# $total_bytes_error 3570# $h1_nb_msg_processed 3571# $h2_uidguess 3572# $total_bytes_transferred 3573# $nb_msg_transferred 3574# $begin_transfer_time 3575# $time_spent 3576# ... 3577# 3578# 3579sub append_message_on_host2 { 3580 my( $string, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) = @_ ; 3581 3582 my $new_id ; 3583 if ( ! $dry ) { 3584 $max_msg_size_in_bytes = max( $h1_size, $max_msg_size_in_bytes ) ; 3585 $new_id = $imap2->append_string( $h2_fold, $string, $h1_flags, $h1_date ) ; 3586 if ( ! $new_id){ 3587 my $subject = subject( $string ) ; 3588 my $error = $imap2->LastError || '' ; 3589 print "- msg $h1_fold/$h1_msg {$string_len} couldn't append (Subject:[$subject]) to folder $h2_fold: $error\n" ; 3590 3591 $nb_errors++; 3592 $total_bytes_error += $h1_size; 3593 $h1_nb_msg_processed +=1 ; 3594 return( ) ; 3595 } 3596 else{ 3597 # good 3598 # $new_id is an id if the IMAP server has the 3599 # UIDPLUS capability else just a ref 3600 if ( $new_id !~ m{^\d+$}x ) { 3601 $new_id = lastuid( $imap2, $h2_fold, $h2_uidguess ) ; 3602 } 3603 $h2_uidguess += 1 ; 3604 $total_bytes_transferred += $h1_size ; 3605 $nb_msg_transferred += 1 ; 3606 $h1_nb_msg_processed +=1 ; 3607 3608 my $time_spent = timesince( $begin_transfer_time ) ; 3609 my $rate = bytes_display_string( $total_bytes_transferred / $time_spent ) ; 3610 my $eta = eta( $time_spent, $h1_nb_msg_processed, $h1_nb_msg_at_start, $nb_msg_transferred ) ; 3611 3612 printf( "msg %s/%-19s copied to %s/%-10s %.2f msgs/s %s/s %s\n", 3613 $h1_fold, "$h1_msg {$string_len}", $h2_fold, $new_id, $nb_msg_transferred/$time_spent, $rate, $eta ); 3614 3615 if ( $usecache and $cacheaftercopy and $new_id =~ m{^\d+$}x ) { 3616 $debugcache and print "touch $cache_dir/${h1_msg}_$new_id\n" ; 3617 touch( "$cache_dir/${h1_msg}_$new_id" ) 3618 or croak( "Couldn't touch $cache_dir/${h1_msg}_$new_id" ) ; 3619 } 3620 if ( $delete ) { 3621 delete_message_on_host1( $h1_msg, $h1_fold ) ; 3622 } 3623 #print "PRESS ENTER" and my $a = <> ; 3624 return( $new_id ) ; 3625 } 3626 } 3627 else{ 3628 $nb_msg_skipped_dry_mode += 1; 3629 $h1_nb_msg_processed +=1 ; 3630 } 3631 3632 return( ) ; 3633} 3634 3635 3636 3637# 6 GlobVar: $dry_message $dry $imap1 $h1_nb_msg_deleted $expunge $expunge1 3638sub delete_message_on_host1 { 3639 my( $h1_msg, $h1_fold ) = @_ ; 3640 print "msg $h1_fold/$h1_msg deleted on host1 $dry_message\n"; 3641 if ( ! $dry ) { 3642 $imap1->delete_message( $h1_msg ) ; 3643 $h1_nb_msg_deleted += 1 ; 3644 $imap1->expunge() if ( $expunge or $expunge1 ) ; 3645 } 3646 return( ) ; 3647} 3648 3649 3650sub eta { 3651 my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @_ ; 3652 return( '' ) if not $foldersizes ; 3653 3654 my $time_remaining = time_remaining( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) ; 3655 my $nb_msg_remaining = $h1_nb_msg_start - $h1_nb_processed ; 3656 my $eta_date = localtime( time + $time_remaining ) ; 3657 return( sprintf( "ETA: %s %1.0f s %s msgs left", $eta_date, $time_remaining, $nb_msg_remaining ) ) ; 3658} 3659 3660sub time_remaining { 3661 3662 my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @_ ; 3663 3664 my $time_remaining = ( $my_time_spent / $nb_transferred ) * ( $h1_nb_msg_start - $h1_nb_processed ) ; 3665 return( $time_remaining ) ; 3666} 3667 3668 3669sub tests_time_remaining { 3670 3671 ok( 1 == time_remaining( 1, 1, 2, 1 ), "time_remaining: 1, 1, 2, 1 -> 1") ; 3672 ok( 1 == time_remaining( 9, 9, 10, 9 ), "time_remaining: 9, 9, 10, 9 -> 1") ; 3673 ok( 9 == time_remaining( 1, 1, 10, 1 ), "time_remaining: 1, 1, 10, 1 -> 1") ; 3674 return( ) ; 3675} 3676 3677 3678sub cache_map { 3679 my ( $cache_files_ref, $h1_msgs_ref, $h2_msgs_ref ) = @_; 3680 my ( %map1_2, %map2_1, %done2 ) ; 3681 3682 my $h1_msgs_hash_ref = { } ; 3683 my $h2_msgs_hash_ref = { } ; 3684 3685 @$h1_msgs_hash_ref{ @$h1_msgs_ref } = ( ) ; 3686 @$h2_msgs_hash_ref{ @$h2_msgs_ref } = ( ) ; 3687 3688 foreach my $file ( sort @$cache_files_ref ) { 3689 $debugcache and print "C12: $file\n" ; 3690 ( $uid1, $uid2 ) = match_a_cache_file( $file ) ; 3691 3692 if ( exists( $h1_msgs_hash_ref->{ defined( $uid1 ) ? $uid1 : q{} } ) 3693 and exists( $h2_msgs_hash_ref->{ defined( $uid2 ) ? $uid2 : q{} } ) ) { 3694 # keep only the greatest uid2 3695 # 130_2301 and 3696 # 130_231 => keep only 130 -> 2301 3697 3698 # keep only the greatest uid1 3699 # 1601_260 and 3700 # 161_260 => keep only 1601 -> 260 3701 my $max_uid2 = max( $uid2, $map1_2{ $uid1 } || -1 ) ; 3702 if ( exists( $done2{ $max_uid2 } ) ) { 3703 if ( $done2{ $max_uid2 } < $uid1 ) { 3704 $map1_2{ $uid1 } = $max_uid2 ; 3705 delete( $map1_2{ $done2{ $max_uid2 } } ) ; 3706 $done2{ $max_uid2 } = $uid1 ; 3707 } 3708 }else{ 3709 $map1_2{ $uid1 } = $max_uid2 ; 3710 $done2{ $max_uid2 } = $uid1 ; 3711 } 3712 }; 3713 3714 } 3715 %map2_1 = reverse( %map1_2 ) ; 3716 return( \%map1_2, \%map2_1) ; 3717} 3718 3719sub tests_cache_map { 3720 #$debugcache = 1 ; 3721 my @cache_files = qw ( 3722 100_200 3723 101_201 3724 120_220 3725 142_242 3726 143_243 3727 177_277 3728 177_278 3729 177_279 3730 155_255 3731 180_280 3732 181_280 3733 182_280 3734 130_231 3735 130_2301 3736 161_260 3737 1601_260 3738 ) ; 3739 3740 my $msgs_1 = [120, 142, 143, 144, 161, 1601, 177, 182, 130 ]; 3741 my $msgs_2 = [ 242, 243, 260, 299, 377, 279, 255, 280, 231, 2301 ]; 3742 3743 my( $c12, $c21 ) ; 3744 ok( ( $c12, $c21 ) = cache_map( \@cache_files, $msgs_1, $msgs_2 ), 'cache_map: 02' ); 3745 my $a1 = [ sort { $a <=> $b } keys %$c12 ] ; 3746 my $a2 = [ sort { $a <=> $b } keys %$c21 ] ; 3747 ok( 0 == compare_lists( [ 130, 142, 143, 177, 182, 1601 ], $a1 ), 'cache_map: 03' ); 3748 ok( 0 == compare_lists( [ 242, 243, 260, 279, 280, 2301 ], $a2 ), 'cache_map: 04' ); 3749 ok( ! $c12->{161}, 'cache_map: ! 161 -> 260' ); 3750 ok( 260 == $c12->{1601}, 'cache_map: 1601 -> 260' ); 3751 ok( 2301 == $c12->{130}, 'cache_map: 130 -> 2301' ); 3752 #print $c12->{1601}, "\n"; 3753 return( ) ; 3754 3755} 3756 3757sub cache_dir_fix { 3758 my $cache_dir = shift ; 3759 $cache_dir =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\])/\\$1/xg ; 3760 #print "cache_dir_fix: $cache_dir\n" ; 3761 return( $cache_dir ) ; 3762} 3763 3764sub tests_cache_dir_fix { 3765 ok( 'lalala' eq cache_dir_fix('lalala'), 'cache_dir_fix: lalala -> lalala' ); 3766 ok( 'ii\\\\ii' eq cache_dir_fix('ii\ii'), 'cache_dir_fix: ii\ii -> ii\\\\ii' ); 3767 ok( 'ii@ii' eq cache_dir_fix('ii@ii'), 'cache_dir_fix: ii@ii -> ii@ii' ); 3768 ok( 'ii@ii\\:ii' eq cache_dir_fix('ii@ii:ii'), 'cache_dir_fix: ii@ii:ii -> ii@ii\\:ii' ); 3769 ok( 'i\\\\i\\\\ii' eq cache_dir_fix('i\i\ii'), 'cache_dir_fix: i\i\ii -> i\\\\i\\\\ii' ); 3770 ok( 'i\\\\ii' eq cache_dir_fix('i\\ii'), 'cache_dir_fix: i\\ii -> i\\\\\\\\ii' ); 3771 ok( '\\\\ ' eq cache_dir_fix('\\ '), 'cache_dir_fix: \\ -> \\\\\ ' ); 3772 ok( '\\\\ ' eq cache_dir_fix('\ '), 'cache_dir_fix: \ -> \\\\\ ' ); 3773 return( ) ; 3774 3775} 3776 3777sub get_cache { 3778 my ( $cache_dir, $h1_msgs_ref, $h2_msgs_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_; 3779 3780 $debugcache and print "Entering get_cache\n"; 3781 3782 -d $cache_dir or return( undef ); # exit if cache directory doesn't exist 3783 $debugcache and print "cache_dir : $cache_dir\n"; 3784 3785 #$cache_dir =~ s{\\}{\\\\}g; 3786 $cache_dir = cache_dir_fix( $cache_dir ) if ( 'MSWin32' ne $OSNAME ) ; 3787 3788 $debugcache and print "cache_dir_fix: $cache_dir\n" ; 3789 3790 my @cache_files = bsd_glob( "$cache_dir/*" ) ; 3791 #$debugcache and print "cache_files: [@cache_files]\n" ; 3792 3793 $debugcache and print( "cache_files: ", scalar( @cache_files ), " files found\n" ) ; 3794 3795 my( $cache_1_2_ref, $cache_2_1_ref ) 3796 = cache_map( \@cache_files, $h1_msgs_ref, $h2_msgs_ref ) ; 3797 3798 clean_cache( \@cache_files, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; 3799 3800 #print "\n", map { "c12 $_ -> $cache_1_2_ref->{ $_ }\n" } keys %$cache_1_2_ref ; 3801 #print "\n", map { "c21 $_ -> $cache_2_1_ref->{ $_ }\n" } keys %$cache_2_1_ref ; 3802 3803 $debugcache and print "Exiting get_cache\n"; 3804 return ( $cache_1_2_ref, $cache_2_1_ref ) ; 3805} 3806 3807 3808sub tests_get_cache { 3809 3810 ok( not( get_cache('/cache_no_exist') ), 'get_cache: /cache_no_exist' ); 3811 ok( ( not -d 'W/tmp/cache/F1/F2' or rmtree( 'W/tmp/cache/F1/F2' )), 'get_cache: rmtree W/tmp/cache/F1/F2' ) ; 3812 ok( mkpath( 'W/tmp/cache/F1/F2' ), 'get_cache: mkpath W/tmp/cache/F1/F2' ) ; 3813 3814 my @test_files_cache = ( qw( 3815 W/tmp/cache/F1/F2/100_200 3816 W/tmp/cache/F1/F2/101_201 3817 W/tmp/cache/F1/F2/120_220 3818 W/tmp/cache/F1/F2/142_242 3819 W/tmp/cache/F1/F2/143_243 3820 W/tmp/cache/F1/F2/177_277 3821 W/tmp/cache/F1/F2/177_377 3822 W/tmp/cache/F1/F2/177_777 3823 W/tmp/cache/F1/F2/155_255 3824 ) ) ; 3825 ok( touch( @test_files_cache ), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ; 3826 3827 3828 # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 3829 # on live: 3830 my $msgs_1 = [120, 142, 143, 144, 177 ]; 3831 my $msgs_2 = [ 242, 243, 299, 377, 777, 255 ]; 3832 3833 my $msgs_all_1 = { 120 => '', 142 => '', 143 => '', 144 => '', 177 => '' } ; 3834 my $msgs_all_2 = { 242 => '', 243 => '', 299 => '', 377 => '', 777 => '', 255 => '' } ; 3835 3836 my( $c12, $c21 ) ; 3837 ok( ( $c12, $c21 ) = get_cache( 'W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' ); 3838 my $a1 = [ sort { $a <=> $b } keys %$c12 ] ; 3839 my $a2 = [ sort { $a <=> $b } keys %$c21 ] ; 3840 ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: 03' ); 3841 ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: 04' ); 3842 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); 3843 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); 3844 ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file removed 100_200'); 3845 ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file removed 101_201'); 3846 3847 # test clean_cache executed 3848 $maxage = 2 ; 3849 ok( touch(@test_files_cache), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ; 3850 ok( ( $c12, $c21 ) = get_cache('W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' ); 3851 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); 3852 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); 3853 ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file NOT removed 100_200'); 3854 ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file NOT removed 101_201'); 3855 3856 3857 # strange files 3858 #$debugcache = 1 ; 3859 $maxage = undef ; 3860 ok( ( not -d 'W/tmp/cache/rr\uee' or rmtree( 'W/tmp/cache/rr\uee' )), 'get_cache: rmtree W/tmp/cache/rr\uee' ) ; 3861 ok( mkpath( 'W/tmp/cache/rr\uee' ), 'get_cache: mkpath W/tmp/cache/rr\uee' ) ; 3862 3863 @test_files_cache = ( qw( 3864 W/tmp/cache/rr\uee/100_200 3865 W/tmp/cache/rr\uee/101_201 3866 W/tmp/cache/rr\uee/120_220 3867 W/tmp/cache/rr\uee/142_242 3868 W/tmp/cache/rr\uee/143_243 3869 W/tmp/cache/rr\uee/177_277 3870 W/tmp/cache/rr\uee/177_377 3871 W/tmp/cache/rr\uee/177_777 3872 W/tmp/cache/rr\uee/155_255 3873 ) ) ; 3874 ok( touch(@test_files_cache), 'get_cache: touch strange W/tmp/cache/...' ) ; 3875 3876 # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 3877 # on live: 3878 $msgs_1 = [120, 142, 143, 144, 177 ] ; 3879 $msgs_2 = [ 242, 243, 299, 377, 777, 255 ] ; 3880 3881 $msgs_all_1 = { 120 => '', 142 => '', 143 => '', 144 => '', 177 => '' } ; 3882 $msgs_all_2 = { 242 => '', 243 => '', 299 => '', 377 => '', 777 => '', 255 => '' } ; 3883 3884 ok( ( $c12, $c21 ) = get_cache('W/tmp/cache/rr\uee', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2), 'get_cache: strange path 02' ); 3885 $a1 = [ sort { $a <=> $b } keys %$c12 ] ; 3886 $a2 = [ sort { $a <=> $b } keys %$c21 ] ; 3887 ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: strange path 03' ); 3888 ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: strange path 04' ); 3889 ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 142_242'); 3890 ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 143_243'); 3891 ok( ! -f 'W/tmp/cache/rr\uee/100_200', 'get_cache: strange path file removed 100_200'); 3892 ok( ! -f 'W/tmp/cache/rr\uee/101_201', 'get_cache: strange path file removed 101_201'); 3893 return( ) ; 3894} 3895 3896sub match_a_cache_file { 3897 my $file = shift ; 3898 my ( $cache_uid1, $cache_uid2 ) ; 3899 3900 return( ( undef, undef ) ) if ( ! $file ) ; 3901 if ( $file =~ m{(?:^|/)(\d+)_(\d+)$}x ) { 3902 $cache_uid1 = $1 ; 3903 $cache_uid2 = $2 ; 3904 } 3905 return( $cache_uid1, $cache_uid2 ) ; 3906} 3907 3908sub tests_match_a_cache_file { 3909 my ( $tuid1, $tuid2 ) ; 3910 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( ), 'match_a_cache_file: no arg' ) ; 3911 ok( ! defined( $tuid1 ), 'match_a_cache_file: no arg 1' ) ; 3912 ok( ! defined( $tuid2 ), 'match_a_cache_file: no arg 2' ) ; 3913 3914 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '' ), 'match_a_cache_file: empty arg' ) ; 3915 ok( ! defined( $tuid1 ), 'match_a_cache_file: empty arg 1' ) ; 3916 ok( ! defined( $tuid2 ), 'match_a_cache_file: empty arg 2' ) ; 3917 3918 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '000_000' ), 'match_a_cache_file: 000_000' ) ; 3919 ok( '000' eq $tuid1, 'match_a_cache_file: 000_000 1' ) ; 3920 ok( '000' eq $tuid2, 'match_a_cache_file: 000_000 2' ) ; 3921 3922 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '123_456' ), 'match_a_cache_file: 123_456' ) ; 3923 ok( '123' eq $tuid1, 'match_a_cache_file: 123_456 1' ) ; 3924 ok( '456' eq $tuid2, 'match_a_cache_file: 123_456 2' ) ; 3925 3926 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/tmp/truc/123_456' ), 'match_a_cache_file: /tmp/truc/123_456' ) ; 3927 ok( '123' eq $tuid1, 'match_a_cache_file: /tmp/truc/123_456 1' ) ; 3928 ok( '456' eq $tuid2, 'match_a_cache_file: /tmp/truc/123_456 2' ) ; 3929 3930 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/lala123_456' ), 'match_a_cache_file: NO /lala123_456' ) ; 3931 ok( ! $tuid1, 'match_a_cache_file: /lala123_456 1' ) ; 3932 ok( ! $tuid2, 'match_a_cache_file: /lala123_456 2' ) ; 3933 3934 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( 'la123_456' ), 'match_a_cache_file: NO la123_456' ) ; 3935 ok( ! $tuid1, 'match_a_cache_file: la123_456 1' ) ; 3936 ok( ! $tuid2, 'match_a_cache_file: la123_456 2' ) ; 3937 3938 return( ) ; 3939} 3940 3941sub clean_cache { 3942 my ( $cache_files_ref, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_ ; 3943 3944 $debugcache and print "Entering clean_cache\n"; 3945 3946 $debugcache and print map { "$_ -> " . $cache_1_2_ref->{ $_ } . "\n" } keys %$cache_1_2_ref ; 3947 foreach my $file ( @$cache_files_ref ) { 3948 $debugcache and print "$file\n" ; 3949 my ( $cache_uid1, $cache_uid2 ) = match_a_cache_file( $file ) ; 3950 $debugcache and print( "u1: $cache_uid1 u2: $cache_uid2 c12: ", $cache_1_2_ref->{ $cache_uid1 } || '', "\n") ; 3951# or ( ! exists( $cache_1_2_ref->{ $cache_uid1 } ) ) 3952# or ( ! ( $cache_uid2 == $cache_1_2_ref->{ $cache_uid1 } ) ) 3953 if ( ( not defined( $cache_uid1 ) ) 3954 or ( not defined( $cache_uid2 ) ) 3955 or ( not exists( $h1_msgs_all_hash_ref->{ $cache_uid1 } ) ) 3956 or ( not exists( $h2_msgs_all_hash_ref->{ $cache_uid2 } ) ) 3957 ) { 3958 $debugcache and print "remove $file\n" ; 3959 unlink( $file ) or print "$!" ; 3960 } 3961 } 3962 3963 $debugcache and print "Exiting clean_cache\n"; 3964 return( 1 ) ; 3965} 3966 3967sub tests_clean_cache { 3968 3969 ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache: rmtree W/tmp/cache/G1/G2' ) ; 3970 ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache: mkpath W/tmp/cache/G1/G2' ) ; 3971 3972 my @test_files_cache = ( qw( 3973 W/tmp/cache/G1/G2/100_200 3974 W/tmp/cache/G1/G2/101_201 3975 W/tmp/cache/G1/G2/120_220 3976 W/tmp/cache/G1/G2/142_242 3977 W/tmp/cache/G1/G2/143_243 3978 W/tmp/cache/G1/G2/177_277 3979 W/tmp/cache/G1/G2/177_377 3980 W/tmp/cache/G1/G2/177_777 3981 W/tmp/cache/G1/G2/155_255 3982 ) ) ; 3983 ok( touch(@test_files_cache), 'clean_cache: touch W/tmp/cache/G1/G2/...' ) ; 3984 3985 ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 before' ); 3986 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 before' ); 3987 ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 before' ); 3988 ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 before' ); 3989 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 before' ); 3990 ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 before' ); 3991 3992 my $cache = { 3993 142 => 242, 3994 177 => 777, 3995 } ; 3996 3997 my $all_1 = { 3998 142 => '', 3999 177 => '', 4000 } ; 4001 4002 my $all_2 = { 4003 200 => '', 4004 242 => '', 4005 777 => '', 4006 } ; 4007 ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache: ' ) ; 4008 4009 ok( ! -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 after' ); 4010 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 after' ); 4011 ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 after' ); 4012 ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 after' ); 4013 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 after' ); 4014 ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 after' ); 4015 return( ) ; 4016} 4017 4018sub tests_clean_cache_2 { 4019 4020 ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache_2: rmtree W/tmp/cache/G1/G2' ) ; 4021 ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache_2: mkpath W/tmp/cache/G1/G2' ) ; 4022 4023 my @test_files_cache = ( qw( 4024 W/tmp/cache/G1/G2/100_200 4025 W/tmp/cache/G1/G2/101_201 4026 W/tmp/cache/G1/G2/120_220 4027 W/tmp/cache/G1/G2/142_242 4028 W/tmp/cache/G1/G2/143_243 4029 W/tmp/cache/G1/G2/177_277 4030 W/tmp/cache/G1/G2/177_377 4031 W/tmp/cache/G1/G2/177_777 4032 W/tmp/cache/G1/G2/155_255 4033 ) ) ; 4034 ok( touch(@test_files_cache), 'clean_cache_2: touch W/tmp/cache/G1/G2/...' ) ; 4035 4036 ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 before' ); 4037 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 before' ); 4038 ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 before' ); 4039 ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 before' ); 4040 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 before' ); 4041 ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 before' ); 4042 4043 my $cache = { 4044 142 => 242, 4045 177 => 777, 4046 } ; 4047 4048 my $all_1 = { 4049 100 => '', 4050 142 => '', 4051 177 => '', 4052 } ; 4053 4054 my $all_2 = { 4055 200 => '', 4056 242 => '', 4057 777 => '', 4058 } ; 4059 4060 4061 4062 ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache_2: ' ) ; 4063 4064 ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 after' ); 4065 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 after' ); 4066 ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 after' ); 4067 ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 after' ); 4068 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 after' ); 4069 ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 after' ); 4070 return( ) ; 4071} 4072 4073 4074 4075sub tests_mkpath { 4076 4077 my $long_path = "123456789/" x 30 ; 4078 ok( (-d "W/tmp/tests/long/$long_path" or mkpath( "W/tmp/tests/long/$long_path" )), 'tests_mkpath: mkpath > 300 char' ) ; 4079 ok( (-d "W/tmp/tests/long/$long_path" and rmtree( "W/tmp/tests/long/" )), 'tests_mkpath: rmtree > 300 char' ) ; 4080 ok( 1 == 1, 'tests_mkpath: 1 == 1' ) ; 4081 return( ) ; 4082} 4083 4084sub tests_touch { 4085 4086 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'tests_touch: mkpath W/tmp/tests/' ) ; 4087 ok( 1 == touch( 'W/tmp/tests/lala'), 'tests_touch: W/tmp/tests/lala') ; 4088 ok( 1 == touch( 'W/tmp/tests/\y'), 'tests_touch: W/tmp/tests/\y') ; 4089 ok( 0 == touch( '/aaa'), 'tests_touch: not /aaa') ; 4090 ok( 1 == touch( 'W/tmp/tests/lili', 'W/tmp/tests/lolo'), 'tests_touch: 2 files') ; 4091 ok( 0 == touch( 'W/tmp/tests/\y', '/aaa'), 'tests_touch: 2 files, 1 fails' ) ; 4092 return( ) ; 4093} 4094 4095 4096sub touch { 4097 my @files = @_ ; 4098 my $failures = 0 ; 4099 4100 foreach my $file ( @files ) { 4101 my $fh = IO::File->new ; 4102 if ( $fh->open(">> $file" ) ) { 4103 $fh->close ; 4104 }else{ 4105 print "Could not open file $file in write/append mode\n" ; 4106 $failures++ ; 4107 } 4108 } 4109 return( ! $failures ); 4110} 4111 4112sub tests_cache_folder { 4113 4114 ok( '/path/fold1/fold2' eq cache_folder( '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ; 4115 ok( '/pa_th/fold1/fold2' eq cache_folder( '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ; 4116 ok( '/_p_a__th/fol_d1/fold2' eq cache_folder( '/>p<a|*th', 'fol*d1', 'fold2'), 'cache_folder: />p<a|*th, fol*d1, fold2 -> /path/fol_d1/fold2' ) ; 4117 return( ) ; 4118} 4119 4120sub cache_folder { 4121 my( $cache_dir, $h1_fold, $h2_fold ) = @_ ; 4122 4123 my $sep_1 = $h1_sep || '/'; 4124 my $sep_2 = $h2_sep || '/'; 4125 4126 #print "$cache_dir h1_fold $h1_fold sep1 $sep_1 h2_fold $h2_fold sep2 $sep_2\n"; 4127 $h1_fold = convert_sep_to_slash( $h1_fold, $sep_1 ) ; 4128 $h2_fold = convert_sep_to_slash( $h2_fold, $sep_2 ) ; 4129 4130 my $cache_folder = "$cache_dir/$h1_fold/$h2_fold" ; 4131 $cache_folder = filter_forbidden_characters( $cache_folder ) ; 4132 #print "cache_folder [$cache_folder]\n" ; 4133 return( $cache_folder ) ; 4134} 4135 4136sub filter_forbidden_characters { 4137 my $string = shift ; 4138 4139 $string =~ s{[\Q*|?:"<>\E]}{_}xg ; 4140 return ( $string ) ; 4141} 4142 4143sub tests_filter_forbidden_characters { 4144 4145 ok( 'a_b' eq filter_forbidden_characters( 'a_b' ), 'filter_forbidden_characters: a_b -> a_b' ) ; 4146 ok( 'a_b' eq filter_forbidden_characters( 'a*b' ), 'filter_forbidden_characters: a*b -> a_b' ); 4147 ok( 'a_b' eq filter_forbidden_characters( 'a|b' ), 'filter_forbidden_characters: a|b -> a_b' ); 4148 ok( 'a_b' eq filter_forbidden_characters( 'a?b' ), 'filter_forbidden_characters: a?*b -> a_b' ); 4149 ok( 'a_______b' eq filter_forbidden_characters( 'a*|?:"<>b' ), 'filter_forbidden_characters: a*|?:"<>b -> a_______b' ); 4150 return( ) ; 4151} 4152 4153sub convert_sep_to_slash { 4154 my ( $folder, $sep ) = @_ ; 4155 4156 $folder =~ s{\Q$sep\E}{/}xg ; 4157 return( $folder ) ; 4158} 4159 4160sub tests_convert_sep_to_slash { 4161 4162 ok('' eq convert_sep_to_slash('', '/'), 'convert_sep_to_slash: no folder'); 4163 ok('INBOX' eq convert_sep_to_slash('INBOX', '/'), 'convert_sep_to_slash: INBOX'); 4164 ok('INBOX/foo' eq convert_sep_to_slash('INBOX/foo', '/'), 'convert_sep_to_slash: INBOX/foo'); 4165 ok('INBOX/foo' eq convert_sep_to_slash('INBOX_foo', '_'), 'convert_sep_to_slash: INBOX_foo'); 4166 ok('INBOX/foo/zob' eq convert_sep_to_slash('INBOX_foo_zob', '_'), 'convert_sep_to_slash: INBOX_foo_zob'); 4167 ok('INBOX/foo' eq convert_sep_to_slash('INBOX.foo', '.'), 'convert_sep_to_slash: INBOX.foo'); 4168 ok('INBOX/foo/hi' eq convert_sep_to_slash('INBOX.foo.hi', '.'), 'convert_sep_to_slash: INBOX.foo.hi'); 4169 return( ) ; 4170} 4171 4172 4173sub tests_regexmess { 4174 4175 ok("blabla" eq regexmess("blabla"), "regexmess, no regexmess, nothing to do"); 4176 4177 @regexmess = ('lalala') ; 4178 ok( not( defined( regexmess("popopo") ) ), "regexmess, bad regex lalala") ; 4179 4180 @regexmess = ('s/p/Z/g'); 4181 ok("ZoZoZo" eq regexmess("popopo"), "regexmess, s/p/Z/g"); 4182 4183 @regexmess = 's{c}{C}gxms'; 4184 ok("H1: abC\nH2: Cde\n\nBody abC" 4185 eq regexmess("H1: abc\nH2: cde\n\nBody abc"), 4186 "regexmess, c->C"); 4187 4188 @regexmess = 's{\AFrom\ }{From:}gxms'; 4189 ok( '' 4190 eq regexmess(''), 4191 'From mbox 1 add colon blank'); 4192 4193 ok( 'From:<tartanpion@machin.truc>' 4194 eq regexmess('From <tartanpion@machin.truc>'), 4195 'From mbox 2 add colo'); 4196 4197 ok( "\n" . 'From <tartanpion@machin.truc>' 4198 eq regexmess("\n" . 'From <tartanpion@machin.truc>'), 4199 'From mbox 3 add colo'); 4200 4201 ok( "From: zzz\n" . 'From <tartanpion@machin.truc>' 4202 eq regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), 4203 'From mbox 4 add colo'); 4204 4205 @regexmess = 's{\AFrom\ [^\n]*(\n)?}{}gxms'; 4206 ok( '' 4207 eq regexmess(''), 4208 'From mbox 1 remove, blank'); 4209 4210 ok( '' 4211 eq regexmess('From <tartanpion@machin.truc>'), 4212 'From mbox 2 remove'); 4213 4214 ok( "\n" . 'From <tartanpion@machin.truc>' 4215 eq regexmess("\n" . 'From <tartanpion@machin.truc>'), 4216 'From mbox 3 remove'); 4217 4218 #print "[", regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), "]"; 4219 ok( "" . 'From <tartanpion@machin.truc>' 4220 eq regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), 4221 'From mbox 4 remove'); 4222 4223 4224 ok( 4225<<'EOM' 4226Date: Sat, 10 Jul 2010 05:34:45 -0700 4227From:<tartanpion@machin.truc> 4228 4229Hello, 4230Bye. 4231EOM 4232 eq regexmess( 4233<<'EOM' 4234From zzz 4235Date: Sat, 10 Jul 2010 05:34:45 -0700 4236From:<tartanpion@machin.truc> 4237 4238Hello, 4239Bye. 4240EOM 4241), 'From mbox 5 remove'); 4242 4243 4244@regexmess = 's{\A(.*?(?! ^$))(^Disposition-Notification-To:.*?\n)}{$1}gxms'; 4245 4246 ok( 4247<<'EOM' 4248Date: Sat, 10 Jul 2010 05:34:45 -0700 4249From:<tartanpion@machin.truc> 4250 4251Hello, 4252Bye. 4253EOM 4254 eq regexmess( 4255<<'EOM' 4256Date: Sat, 10 Jul 2010 05:34:45 -0700 4257Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net> 4258From:<tartanpion@machin.truc> 4259 4260Hello, 4261Bye. 4262EOM 4263 ), 4264 'regexmess: 1 Delete header Disposition-Notification-To:'); 4265 4266 ok( 4267<<'EOM' 4268Date: Sat, 10 Jul 2010 05:34:45 -0700 4269From:<tartanpion@machin.truc> 4270 4271Hello, 4272Bye. 4273EOM 4274 eq regexmess( 4275<<'EOM' 4276Date: Sat, 10 Jul 2010 05:34:45 -0700 4277From:<tartanpion@machin.truc> 4278Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net> 4279 4280Hello, 4281Bye. 4282EOM 4283), 4284 'regexmess: 2 Delete header Disposition-Notification-To:'); 4285 4286 ok( 4287<<'EOM' 4288Date: Sat, 10 Jul 2010 05:34:45 -0700 4289From:<tartanpion@machin.truc> 4290 4291Hello, 4292Bye. 4293EOM 4294 eq regexmess( 4295<<'EOM' 4296Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net> 4297Date: Sat, 10 Jul 2010 05:34:45 -0700 4298From:<tartanpion@machin.truc> 4299 4300Hello, 4301Bye. 4302EOM 4303), 4304 'regexmess: 3 Delete header Disposition-Notification-To:'); 4305 4306 ok( 4307<<'EOM' 4308Date: Sat, 10 Jul 2010 05:34:45 -0700 4309From:<tartanpion@machin.truc> 4310 4311Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net> 4312Bye. 4313EOM 4314 eq regexmess( 4315<<'EOM' 4316Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net> 4317Date: Sat, 10 Jul 2010 05:34:45 -0700 4318From:<tartanpion@machin.truc> 4319 4320Disposition-Notification-To: Gilles LAMIRAL <gilles.lamiral@laposte.net> 4321Bye. 4322EOM 4323), 4324 'regexmess: 4 Delete header Disposition-Notification-To:'); 4325 4326 4327 4328return( ) ; 4329 4330} 4331 4332sub regexmess { 4333 my ($string) = @_ ; 4334 foreach my $regexmess ( @regexmess ) { 4335 $debug and print "eval \$string =~ $regexmess\n" ; 4336 my $ret = eval( "\$string =~ $regexmess ; 1" ) ; 4337 #print "eval [$ret]\n" ; 4338 if ( ( not $ret ) or $@ ) { 4339 print "Error: eval regexmess '$regexmess': $@" ; 4340 return( undef ) ; 4341 } 4342 } 4343 return( $string ) ; 4344} 4345 4346 4347sub tests_bytes_display_string { 4348 4349 ok( '0.000 KiB' eq bytes_display_string( 0 ), 'bytes_display_string: 0' ) ; 4350 ok( '0.001 KiB' eq bytes_display_string( 1 ), 'bytes_display_string: 1' ) ; 4351 ok( '0.010 KiB' eq bytes_display_string( 10 ), 'bytes_display_string: 10' ) ; 4352 ok( '1.000 MiB' eq bytes_display_string( 1048575 ), 'bytes_display_string: 1048575' ) ; 4353 ok( '1.000 MiB' eq bytes_display_string( 1048576 ), 'bytes_display_string: 1048576' ) ; 4354 4355 ok( '1.000 GiB' eq bytes_display_string( 1073741823 ), 'bytes_display_string: 1073741823 ' ) ; 4356 ok( '1.000 GiB' eq bytes_display_string( 1073741824 ), 'bytes_display_string: 1073741824 ' ) ; 4357 4358 ok( '1.000 TiB' eq bytes_display_string( 1099511627775 ), 'bytes_display_string: 1099511627775' ) ; 4359 ok( '1.000 TiB' eq bytes_display_string( 1099511627776 ), 'bytes_display_string: 1099511627776' ) ; 4360 4361 ok( '1.000 PiB' eq bytes_display_string( 1125899906842623 ), 'bytes_display_string: 1125899906842623' ) ; 4362 ok( '1.000 PiB' eq bytes_display_string( 1125899906842624 ), 'bytes_display_string: 1125899906842624' ) ; 4363 4364 ok( '1024.000 PiB' eq bytes_display_string( 1152921504606846975 ), 'bytes_display_string: 1152921504606846975' ) ; 4365 ok( '1024.000 PiB' eq bytes_display_string( 1152921504606846976 ), 'bytes_display_string: 1152921504606846976' ) ; 4366 4367 ok( '1048576.000 PiB' eq bytes_display_string( 1180591620717411303424 ), 'bytes_display_string: 1180591620717411303424' ) ; 4368 4369 #print bytes_display_string( 1180591620717411303424 ), "\n" ; 4370 return( ) ; 4371} 4372 4373sub bytes_display_string { 4374 my ( $bytes ) = @_ ; 4375 4376 my $readable_value = '' ; 4377 4378 SWITCH: { 4379 if ( abs( $bytes ) < ( 1000 * 1024 ) ) { 4380 $readable_value = sprintf( "%.3f KiB", $bytes / 1024) ; 4381 last SWITCH ; 4382 } 4383 if ( abs( $bytes ) < ( 1000 * 1024 * 1024 ) ) { 4384 $readable_value = sprintf( "%.3f MiB", $bytes / (1024 * 1024) ) ; 4385 last SWITCH ; 4386 } 4387 if ( abs( $bytes ) < ( 1000 * 1024 * 1024 * 1024) ) { 4388 $readable_value = sprintf("%.3f GiB", $bytes / (1024 * 1024 * 1024) ) ; 4389 last SWITCH ; 4390 } 4391 if ( abs( $bytes ) < ( 1000 * 1024 * 1024 * 1024 * 1024) ) { 4392 $readable_value = sprintf( "%.3f TiB", $bytes / (1024 * 1024 * 1024 * 1024) ) ; 4393 last SWITCH ; 4394 } else { 4395 $readable_value = sprintf( "%.3f PiB", $bytes / (1024 * 1024 * 1024 * 1024 * 1024) ) ; 4396 } 4397 # if you have exabytes (EiB) of email to transfer, you have too much email 4398 } 4399 #print "$bytes = $readable_value\n" ; 4400 return( $readable_value ) ; 4401} 4402 4403sub stats { 4404 $timeend = time( ); 4405 my $timediff = $timeend - $timestart ; 4406 4407 my $timeend_str = localtime( $timeend ) ; 4408 4409 my $memory_consumption = memory_consumption( ) || 0 ; 4410 my $memory_ratio = ($max_msg_size_in_bytes) ? 4411 sprintf('%.1f', $memory_consumption / $max_msg_size_in_bytes) : "NA" ; 4412 4413 my $host1_reconnect_count = $imap1->Reconnect_counter() || 0 ; 4414 my $host2_reconnect_count = $imap2->Reconnect_counter() || 0 ; 4415 4416 print "++++ Statistics\n" ; 4417 print "Transfer started on : $timestart_str\n"; 4418 print "Transfer ended on : $timeend_str\n"; 4419 printf( "Transfer time : %.1f sec\n", $timediff ) ; 4420 print "Messages transferred : $nb_msg_transferred "; 4421 print "(could be $nb_msg_skipped_dry_mode without dry mode)" if ($dry); 4422 print "\n"; 4423 print "Messages skipped : $nb_msg_skipped\n"; 4424 print "Messages found duplicate on host1 : $h1_nb_msg_duplicate\n"; 4425 print "Messages found duplicate on host2 : $h2_nb_msg_duplicate\n"; 4426 print "Messages void (noheader) on host1 : $h1_nb_msg_noheader\n"; 4427 print "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n"; 4428 print "Messages deleted on host1 : $h1_nb_msg_deleted\n"; 4429 print "Messages deleted on host2 : $h2_nb_msg_deleted\n"; 4430 printf( "Total bytes transferred : %d (%s)\n", 4431 $total_bytes_transferred, 4432 bytes_display_string($total_bytes_transferred)); 4433 printf( "Total bytes duplicate host1 : %d (%s)\n", 4434 $h1_total_bytes_duplicate, 4435 bytes_display_string($h1_total_bytes_duplicate)); 4436 printf( "Total bytes duplicate host2 : %d (%s)\n", 4437 $h2_total_bytes_duplicate, 4438 bytes_display_string($h2_total_bytes_duplicate)); 4439 printf( "Total bytes skipped : %d (%s)\n", 4440 $total_bytes_skipped, 4441 bytes_display_string($total_bytes_skipped)); 4442 printf( "Total bytes error : %d (%s)\n", 4443 $total_bytes_error, 4444 bytes_display_string($total_bytes_error)); 4445 $timediff ||= 1; # No division per 0 4446 printf ("Message rate : %.1f messages/s\n", $nb_msg_transferred / $timediff); 4447 printf ("Average bandwidth rate : %.1f KiB/s\n", $total_bytes_transferred / 1024 / $timediff); 4448 print "Reconnections to host1 : $host1_reconnect_count\n"; 4449 print "Reconnections to host2 : $host2_reconnect_count\n"; 4450 printf ("Memory consumption : %.1f MiB\n", $memory_consumption / 1024 / 1024); 4451 print "Biggest message : $max_msg_size_in_bytes bytes\n"; 4452# print "Memory/biggest message ratio : $memory_ratio\n"; 4453 if ( $foldersizesatend and $foldersizes ) { 4454 printf("Initial difference host2 - host1 : %s messages, %s bytes (%s)\n", $h2_nb_msg_start - $h1_nb_msg_at_start, 4455 $h2_bytes_start - $h1_bytes_start, 4456 bytes_display_string( $h2_bytes_start - $h1_bytes_start ) ) ; 4457 printf("Final difference host2 - host1 : %s messages, %s bytes (%s)\n", $h2_nb_msg_end - $h1_nb_msg_end, 4458 $h2_bytes_end - $h1_bytes_end, 4459 bytes_display_string( $h2_bytes_end - $h1_bytes_end ) ) ; 4460 } 4461 print "Detected $nb_errors errors\n\n" ; 4462 4463 print $warn_release, "\n" ; 4464 print thank_author(); 4465 return( ) ; 4466} 4467 4468sub thank_author { 4469 return("Homepage: http://imapsync.lamiral.info/\n"); 4470} 4471 4472 4473sub load_modules { 4474 4475 if ( $ssl1 or $ssl2 or $tls1 or $tls2 ) { 4476 require IO::Socket::SSL ; 4477 #$IO::Socket::SSL::DEBUG = 4 ; 4478 } 4479 4480 require Term::ReadKey if ( 4481 ((not($password1 or $passfile1)) 4482 or (not($password2 or $passfile2))) 4483 and (not $help)); 4484 4485 #require Data::Dumper if ($debug); 4486 return( ) ; 4487} 4488 4489 4490 4491sub parse_header_msg { 4492 my ($imap, $m_uid, $s_heads, $s_fir, $side, $s_hash) = @_; 4493 4494 my $head = $s_heads->{$m_uid}; 4495 my $headnum = scalar(keys(%$head)); 4496 $debug and print "$side uid $m_uid head nb pass one: ", $headnum, "\n"; 4497 4498 if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){ 4499 print "$side uid $m_uid no header by parse_headers so taking whole header with BODY.PEEK[HEADER]\n" ; 4500 $imap->fetch($m_uid, "BODY.PEEK[HEADER]"); 4501 my $whole_header = $imap->_transaction_literals; 4502 4503 #print $whole_header; 4504 $head = decompose_header( $whole_header ) ; 4505 4506 $headnum = scalar( keys( %$head ) ) ; 4507 $debug and print "$side uid $m_uid head nb pass two: ", $headnum, "\n"; 4508 } 4509 4510 #require Data::Dumper ; 4511 #print Data::Dumper->Dump( [ $head, \%useheader ] ) ; 4512 4513 my $headstr ; 4514 4515 $headstr = header_construct( $head, $side, $m_uid ) ; 4516 4517 if ( ( ! $headstr) and ( $addheader ) and ( $side eq "Host1" )){ 4518 my $header = add_header( $m_uid ) ; 4519 print "Host1 uid $m_uid no header found so adding our own [$header]\n"; 4520 $headstr .= uc( $header ) ; 4521 $s_fir->{$m_uid}->{"NO_HEADER"} = 1; 4522 } 4523 4524 return( ) if ( ! $headstr ) ; 4525 4526 my $size = $s_fir->{$m_uid}->{"RFC822.SIZE"}; 4527 my $flags = $s_fir->{$m_uid}->{"FLAGS"}; 4528 my $idate = $s_fir->{$m_uid}->{"INTERNALDATE"}; 4529 $size = length( $headstr ) unless ( $size ) ; 4530 my $m_md5 = md5_base64( $headstr ) ; 4531 $debug and print "$side uid $m_uid sig $m_md5 size $size idate $idate\n"; 4532 my $key; 4533 if ($skipsize) { 4534 $key = "$m_md5"; 4535 } 4536 else { 4537 $key = "$m_md5:$size"; 4538 } 4539 # 0 return code is used to identify duplicate message hash 4540 return 0 if exists $s_hash->{"$key"}; 4541 $s_hash->{"$key"}{'5'} = $m_md5; 4542 $s_hash->{"$key"}{'s'} = $size; 4543 $s_hash->{"$key"}{'D'} = $idate; 4544 $s_hash->{"$key"}{'F'} = $flags; 4545 $s_hash->{"$key"}{'m'} = $m_uid; 4546 4547 return( 1 ) ; 4548} 4549 4550sub header_construct { 4551 4552 my( $head, $side, $m_uid ) = @_ ; 4553 4554 my $headstr ; 4555 foreach my $h ( sort keys( %$head ) ) { 4556 next if ( not exists( $useheader{ uc( $h ) } ) 4557 and not exists( $useheader{ 'ALL' } ) 4558 ) ; 4559 foreach my $val ( sort @{$head->{$h}} ) { 4560 4561 my $H = header_line_normalize( $h, $val ) ; 4562 4563 # show stuff in debug mode 4564 $debug and print "$side uid $m_uid header [$H]", "\n" ; 4565 4566 if ($skipheader and $H =~ m/$skipheader/xi) { 4567 $debug and print "$side uid $m_uid skipping header [$H]\n" ; 4568 next ; 4569 } 4570 $headstr .= "$H" ; 4571 } 4572 } 4573 return( $headstr ) ; 4574} 4575 4576 4577sub header_line_normalize { 4578 my( $header_key, $header_val ) = @_ ; 4579 4580 # no 8-bit data in headers ! 4581 $header_val =~ s/[\x80-\xff]/X/xog; 4582 4583 # change tabulations to space (Gmail bug on with "Received:" on multilines) 4584 $header_val =~ s/\t/\ /xg ; 4585 4586 # remove the first blanks ( dbmail bug? ) 4587 $header_val =~ s/^\s*//xo; 4588 4589 # remove successive blanks ( Mailenable does it ) 4590 $header_val =~ s/\s+/ /gxo; 4591 4592 # remove Message-Id value domain part ( Mailenable changes it ) 4593 if ( ( $messageidnodomain ) and ( 'MESSAGE-ID' eq uc( $header_key ) ) ) { $header_val =~ s/^([^@]+).*$/$1/xo ; } 4594 4595 # and uppercase header line 4596 # (dbmail and dovecot) 4597 4598 my $header_line = uc("$header_key: $header_val") ; 4599 4600 return( $header_line ) ; 4601 4602} 4603 4604sub tests_header_line_normalize { 4605 4606 ok( ': ' eq header_line_normalize( '', '' ), 'header_line_normalize: empty args' ) ; 4607 ok( 'HHH: VVV' eq header_line_normalize( 'hhh', 'vvv' ), 'header_line_normalize: hhh vvv ' ) ; 4608 ok( 'HHH: VVV' eq header_line_normalize( 'hhh', ' vvv' ), 'header_line_normalize: remove first blancs' ) ; 4609 ok( 'HHH: AA BB CCC ' eq header_line_normalize( 'hhh', 'aa bb ccc ' ), 'header_line_normalize: remove succesive blancs' ) ; 4610 ok( 'HHH: VVV XX YY' eq header_line_normalize( 'hhh', "vvv\t\txx\tyy" ), 'header_line_normalize: tabs' ) ; 4611 ok( 'HHH: XABX' eq header_line_normalize( 'hhh', "\x80AB\xff" ), 'header_line_normalize: 8bit' ) ; 4612 4613 return( ) ; 4614} 4615 4616 4617sub firstline { 4618 # extract the first line of a file (without \n) 4619 4620 my($file) = @_ ; 4621 my $line = "" ; 4622 4623 open( my $FILE, '<', $file ) or die_clean( "error [$file]: $! " ) ; 4624 chomp( $line = <$FILE> ) ; 4625 close $FILE ; 4626 $line = ( $line ) ? $line: "error !EMPTY! [$file]" ; 4627 return $line ; 4628} 4629 4630 4631sub file_to_string { 4632 my( $file ) = @_ ; 4633 my @string ; 4634 open( my $FILE, '<', $file ) or die_clean( "error [$file]: $! " ) ; 4635 @string = <$FILE> ; 4636 close $FILE ; 4637 return join('', @string) ; 4638} 4639 4640 4641sub string_to_file { 4642 my($string, $file) = @_; 4643 sysopen(FILE, $file,O_WRONLY|O_TRUNC|O_CREAT, 0600) or die_clean("$! $file"); 4644 print FILE $string; 4645 close FILE; 4646 return( ) ; 4647} 4648 4649sub tests_is_a_release_number { 4650 ok(is_a_release_number(1.351), 'is_a_release_number 1.351'); 4651 ok(is_a_release_number(42.4242), 'is_a_release_number 42.4242'); 4652 ok(is_a_release_number(imapsync_version()), 'is_a_release_number imapsync_version()'); 4653 ok(! is_a_release_number('blabla' ), '! is_a_release_number blabla'); 4654 return( ) ; 4655} 4656 4657sub is_a_release_number { 4658 my $number = shift; 4659 4660 return( $number =~ m{\d\.\d+}xo ) ; 4661} 4662 4663sub check_last_release { 4664 4665 my $public_release = not_long_imapsync_version_public( ) ; 4666 #print "check_last_release: [$public_release]\n" ; 4667 return('unknown') if ($public_release eq 'unknown'); 4668 return('timeout') if ($public_release eq 'timeout'); 4669 return('unknown') if (! is_a_release_number($public_release)); 4670 4671 my $imapsync_here = imapsync_version(); 4672 4673 if ($public_release > $imapsync_here) { 4674 return("New imapsync release $public_release available"); 4675 }else{ 4676 return("This current imapsync is up to date"); 4677 } 4678} 4679 4680sub imapsync_version { 4681 my $rcs_imapsync = '$Id: imapsync,v 1.564 2013/08/18 19:28:47 gilles Exp gilles $ ' ; 4682 my $imapsync_version ; 4683 4684 if ( $rcs_imapsync =~ m{,v\s+(\d+\.\d+)}xo ) { 4685 $imapsync_version = $1 4686 } else { 4687 $imapsync_version = "UNKNOWN" ; 4688 } 4689 return( $imapsync_version ) ; 4690} 4691 4692sub tests_imapsync_basename { 4693 4694 ok('imapsync' eq imapsync_basename(), 'imapsync_basename: imapsync'); 4695 ok('blabla' ne imapsync_basename(), '! imapsync_basename: blabla'); 4696 return( ) ; 4697} 4698 4699sub imapsync_basename { 4700 4701 return basename($0); 4702 4703} 4704 4705sub imapsync_version_public { 4706 4707 my $local_version = imapsync_version(); 4708 my $imapsync_basename = imapsync_basename(); 4709 my $agent_info = "$OSNAME system, perl " 4710 . sprintf("%vd", $PERL_VERSION) 4711 . ", Mail::IMAPClient $Mail::IMAPClient::VERSION" 4712 . " $imapsync_basename"; 4713 my $sock = IO::Socket::INET->new( 4714 PeerAddr => 'imapsync.lamiral.info', 4715 PeerPort => '80', 4716 Proto => 'tcp' 4717 ) ; 4718 return( 'unknown' ) if not $sock ; 4719 print $sock 4720 "GET /prj/imapsync/VERSION HTTP/1.0\n", 4721 "User-Agent: imapsync/$local_version ($agent_info)\n", 4722 "Host: ks.lamiral.info\n\n"; 4723 my @line = <$sock>; 4724 close($sock); 4725 my $last_release = $line[-1]; 4726 chomp($last_release); 4727 return($last_release); 4728} 4729 4730sub not_long_imapsync_version_public { 4731 #print "Entering not_long_imapsync_version_public\n"; 4732 4733 my $val; 4734 4735 # Doesn't work with gethostbyname (see perlipc) 4736 #local $SIG{ALRM} = sub { die "alarm\n" }; 4737 4738 if ('MSWin32' eq $OSNAME) { 4739 local $SIG{ALRM} = sub { die "alarm\n" }; 4740 }else{ 4741 4742 POSIX::sigaction(SIGALRM, 4743 POSIX::SigAction->new(sub { croak "alarm" })) 4744 or print "Error setting SIGALRM handler: $!\n"; 4745 } 4746 4747 my $ret = eval { 4748 alarm(3) ; 4749 { 4750 $val = imapsync_version_public( ) ; 4751 #sleep 4 ; 4752 #print "End of imapsync_version_public\n" ; 4753 } 4754 alarm(0) ; 4755 1 ; 4756 } ; 4757 #print "eval [$ret]\n" ; 4758 if ( ( not $ret ) or $@ ) { 4759 #print "$@"; 4760 if ($@ =~ /alarm/) { 4761 # timed out 4762 return('timeout'); 4763 }else{ 4764 alarm(0); 4765 return('unknown'); # propagate unexpected errors 4766 } 4767 }else { 4768 # Good! 4769 return($val); 4770 } 4771} 4772 4773sub localhost_info { 4774 4775 my($infos) = join("", 4776 "Here is a [$OSNAME] system (", 4777 join(" ", 4778 uname(), 4779 ), 4780 ")\n", 4781 "With perl ", 4782 sprintf("%vd", $PERL_VERSION), 4783 " Mail::IMAPClient $Mail::IMAPClient::VERSION", 4784 ) ; 4785 return($infos); 4786} 4787 4788sub memory_consumption { 4789 # memory consumed by imapsync until now in bytes 4790 return( ( memory_consumption_of_pids( ) )[0] ); 4791} 4792 4793sub memory_consumption_of_pids { 4794 4795 my @pid = @_; 4796 @pid = (@pid) ? @pid : ($PROCESS_ID) ; 4797 4798 #print "PIDs: @PID\n"; 4799 my @val; 4800 if ('MSWin32' eq $OSNAME) { 4801 @val = memory_consumption_of_pids_win32(@pid); 4802 }else{ 4803 # Unix 4804 #my @ps = qx{ ps -o vsz -p @pid }; 4805 my @ps = backtick( "ps -o vsz -p @pid" ) ; 4806 shift @ps; # First line is column name "VSZ" 4807 chomp @ps; 4808 # convert to 4809 @val = map { $_ * 1024 } @ps; 4810 } 4811 return( @val ) ; 4812} 4813 4814sub memory_consumption_of_pids_win32 { 4815 # Windows 4816 my @PID = @_; 4817 my %PID; 4818 # hash of pids as key values 4819 map { $PID{$_}++ } @PID; 4820 4821 # Does not work but should reading the tasklist documentation 4822 #@ps = qx{ tasklist /FI "PID eq @PID" }; 4823 4824 #my @ps = qx{ tasklist /NH /FO CSV } ; 4825 my @ps = backtick( 'tasklist /NH /FO CSV' ) ; 4826 #print "-" x 80, "\n", @ps, "-" x 80, "\n"; 4827 my @val; 4828 foreach my $line (@ps) { 4829 my($name, $pid, $mem) = (split(',', $line))[0,1,4]; 4830 next if (! $pid); 4831 #print "[$name][$pid][$mem]"; 4832 if ($PID{remove_qq($pid)}) { 4833 #print "MATCH !\n"; 4834 chomp($mem); 4835 $mem = remove_qq($mem); 4836 $mem = remove_Ko($mem); 4837 $mem = remove_not_num($mem); 4838 #print "[$mem]\n"; 4839 push(@val, $mem * 1024); 4840 } 4841 } 4842 return(@val); 4843} 4844 4845sub backtick { 4846 my $command = shift ; 4847 my ($writer, $reader, $err); 4848 open3( $writer, $reader, $err, $command ) ; 4849 my @output = <$reader>; #Output here 4850 #my @errors = <$err>; #Errors here, instead of the console 4851 $debugdev and print @output ; 4852 return( @output ) ; 4853} 4854 4855sub tests_backtick { 4856 4857 my @output ; 4858 @output = backtick( "echo Hello World!" ) ; 4859 ok( "Hello World!\n" eq $output[0], 'backtick: echo Hello World!' ) ; 4860 4861 @output = backtick( "echo Hello\necho World!" ) ; 4862 ok( "Hello\n" eq $output[0], 'backtick: echo Hello; echo World!' ) ; 4863 ok( "World!\n" eq $output[1], 'backtick: echo Hello; echo World!' ) ; 4864 #print @output ; 4865 if ('MSWin32' ne $OSNAME) { 4866 my @output_1 = backtick( 'ls /' ) ; 4867 #my @output_2 = `ls /` ; 4868 #ok( 0 == compare_lists( \@output_1, \@output_2 ), 'backtick: ls /' ) ; 4869 } 4870 return( ) ; 4871} 4872 4873sub remove_not_num { 4874 4875 my $string = shift; 4876 $string =~ tr/0-9//cd; 4877 #print "tr [$string]\n"; 4878 return($string); 4879} 4880 4881sub tests_remove_not_num { 4882 4883 ok('123' eq remove_not_num(123), 'remove_not_num( 123 )'); 4884 ok('123' eq remove_not_num('123'), "remove_not_num( '123' )"); 4885 ok('123' eq remove_not_num('12 3'), "remove_not_num( '12 3' )"); 4886 ok('123' eq remove_not_num('a 12 3 Ko'), "remove_not_num( 'a 12 3 Ko' )"); 4887 return( ) ; 4888} 4889 4890sub remove_Ko { 4891 my $string = shift; 4892 if ($string =~ /^(.*)\sKo$/xo) { 4893 return($1); 4894 }else{ 4895 return($string); 4896 } 4897} 4898 4899sub remove_qq { 4900 my $string = shift; 4901 if ($string =~ /^"(.*)"$/xo) { 4902 return($1); 4903 }else{ 4904 return($string); 4905 } 4906} 4907 4908sub memory_consumption_ratio { 4909 4910 my ($base) = @_; 4911 $base ||= 1; 4912 my $consu = memory_consumption(); 4913 return($consu / $base); 4914} 4915 4916sub tests_memory_consumption { 4917 4918 ok(print join("\n", memory_consumption_of_pids()), " memory_consumption_of_pids\n"); 4919 ok(print join("\n", memory_consumption_of_pids('1')), " memory_consumption_of_pids 1\n"); 4920 ok(print join("\n", memory_consumption_of_pids('1', $PROCESS_ID)), " memory_consumption_of_pids 1 $PROCESS_ID\n"); 4921 4922 ok(print memory_consumption_ratio(), " memory_consumption_ratio \n"); 4923 ok(print memory_consumption_ratio(1), " memory_consumption_ratio 1\n"); 4924 ok(print memory_consumption_ratio(10), " memory_consumption_ratio 10\n"); 4925 4926 ok(print memory_consumption(), " memory_consumption\n"); 4927 return( ) ; 4928} 4929 4930sub good_date { 4931 # two incoming formats: 4932 # header Tue, 24 Aug 2010 16:00:00 +0200 4933 # internal 24-Aug-2010 16:00:00 +0200 4934 4935 # outgoing format: internal date format 4936 # 24-Aug-2010 16:00:00 +0200 4937 4938 my $d = shift ; 4939 return ('') if not defined($d); 4940 4941 SWITCH: { 4942 if ( $d =~ m{(\d?)(\d-...-\d{4})(\s\d{2}:\d{2}:\d{2})(\s(?:\+|-)\d{4})?}xo ) { 4943 #print "internal: [$1][$2][$3][$4]\n" ; 4944 my ($day_1, $date_rest, $hour, $zone) = ($1,$2,$3,$4) ; 4945 $day_1 = '0' if ($day_1 eq '') ; 4946 $zone = ' +0000' if not defined($zone) ; 4947 $d = $day_1 . $date_rest . $hour . $zone ; 4948 last SWITCH ; 4949 } 4950 4951 if ($d =~ m{(?:\w{3,},\s)?(\d{1,2}),?\s+(\w{3,})\s+(\d{2,4})\s+(\d{1,2})(?::|\.)(\d{1,2})(?:(?::|\.)(\d{1,2}))?\s*((?:\+|-)\d{4})?}xo ) { 4952 # Handles any combination of following formats 4953 # Tue, 24 Aug 2010 16:00:00 +0200 -- Standard 4954 # 24 Aug 2010 16:00:00 +0200 -- Missing Day of Week 4955 # Tue, 24 Aug 97 16:00:00 +0200 -- Two digit year 4956 # Tue, 24 Aug 1997 16.00.00 +0200 -- Periods instead of colons 4957 # Tue, 24 Aug 1997 16:00:00 +0200 -- Extra whitespace between year and hour 4958 # Tue, 24 Aug 1997 6:5:2 +0200 -- Single digit hour, min, or second 4959 # Tue, 24, Aug 1997 16:00:00 +0200 -- Extra comma 4960 4961 #print "header: [$1][$2][$3][$4][$5][$6][$7][$8]\n"; 4962 my ($day, $month, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7,$8); 4963 $year = '19' . $year if length($year) == 2 && $year =~ m/^[789]/xo; 4964 $year = '20' . $year if length($year) == 2; 4965 4966 $month = substr $month, 0, 3 if length($month) > 4; 4967 $day = sprintf("%02d", $day); 4968 $hour = sprintf("%02d", $hour); 4969 $min = sprintf("%02d", $min); 4970 $sec = '00' if not defined($sec); 4971 $sec = sprintf("%02d", $sec); 4972 $zone = '+0000' if not defined($zone); 4973 $d = "$day-$month-$year $hour:$min:$sec $zone"; 4974 last SWITCH ; 4975 } 4976 4977 if ($d =~ m{(?:.{3})\s(...)\s+(\d{1,2})\s(\d{1,2}):(\d{1,2}):(\d{1,2})\s(?:\w{3})?\s?(\d{4})}xo ) { 4978 # Handles any combination of following formats 4979 # Sun Aug 20 11:55:09 2006 4980 # Wed Jan 24 11:58:38 MST 2007 4981 # Wed Jan 2 08:40:57 2008 4982 4983 #print "header: [$1][$2][$3][$4][$5][$6]\n"; 4984 my ($month, $day, $hour, $min, $sec, $year) = ($1,$2,$3,$4,$5,$6); 4985 $day = sprintf("%02d", $day); 4986 $hour = sprintf("%02d", $hour); 4987 $min = sprintf("%02d", $min); 4988 $sec = sprintf("%02d", $sec); 4989 $d = "$day-$month-$year $hour:$min:$sec +0000"; 4990 last SWITCH ; 4991 } 4992 4993 if ($d =~ m{(\d{2})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) { 4994 # Handles the following format 4995 # 02/06/09 22:18:08 -- Generated by AVTECH TemPageR devices 4996 4997 #print "header: [$1][$2][$3][$4][$5][$6]\n"; 4998 my ($month, $day, $year, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6); 4999 $year = '20' . $year; 5000 my %num2mon = qw(01 Jan 02 Feb 03 Mar 04 Apr 05 May 06 Jun 07 Jul 08 Aug 09 Sep 10 Oct 11 Nov 12 Dec); 5001 $month = $num2mon{$month}; 5002 $d = "$day-$month-$year $hour:$min:$sec +0000"; 5003 last SWITCH ; 5004 } 5005 5006 if ($d =~ m{\w{6,},\s(\w{3})\w+\s+(\d{1,2}),\s(\d{4})\s(\d{2}):(\d{2})\s(AM|PM)}xo ) { 5007 # Handles the following format 5008 # Saturday, December 14, 2002 05:00 PM - KBtoys.com order confirmations 5009 5010 my ($month, $day, $year, $hour, $min, $apm) = ($1,$2,$3,$4,$5,$6); 5011 5012 $hour += 12 if $apm eq 'PM'; 5013 $day = sprintf("%02d", $day); 5014 $d = "$day-$month-$year $hour:$min:00 +0000"; 5015 last SWITCH ; 5016 } 5017 5018 if ($d =~ m{(\w{3})\s(\d{1,2})\s(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-)\d{4})}xo ) { 5019 # Handles the following format 5020 # Saturday, December 14, 2002 05:00 PM - jr.com order confirmations 5021 5022 my ($month, $day, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7); 5023 5024 $day = sprintf("%02d", $day); 5025 $d = "$day-$month-$year $hour:$min:$sec $zone"; 5026 last SWITCH ; 5027 } 5028 5029 if ($d =~ m{(\d{1,2})-(\w{3})-(\d{4})}xo ) { 5030 # Handles the following format 5031 # 21-Jun-2001 - register.com domain transfer email circa 2001 5032 5033 my ($day, $month, $year) = ($1,$2,$3); 5034 $day = sprintf("%02d", $day); 5035 $d = "$day-$month-$year 11:11:11 +0000"; 5036 last SWITCH ; 5037 } 5038 5039 # unknown or unmatch => return same string 5040 return($d); 5041 } 5042 5043 $d = qq("$d") ; 5044 return( $d ) ; 5045} 5046 5047 5048sub tests_good_date { 5049 5050 ok('' eq good_date(), 'good_date no arg'); 5051 ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24-Aug-2010 16:00:00 +0200'), 'good_date internal 2digit zone'); 5052 ok('"24-Aug-2010 16:00:00 +0000"' eq good_date('24-Aug-2010 16:00:00'), 'good_date internal 2digit no zone'); 5053 ok('"01-Sep-2010 16:00:00 +0200"' eq good_date( '1-Sep-2010 16:00:00 +0200'), 'good_date internal SP 1digit'); 5054 ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('Tue, 24 Aug 2010 16:00:00 +0200'), 'good_date header 2digit zone'); 5055 ok('"01-Sep-2010 16:00:00 +0000"' eq good_date('Wed, 1 Sep 2010 16:00:00'), 'good_date header SP 1digit zone'); 5056 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'); 5057 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'); 5058 ok('"06-Feb-2009 22:18:08 +0000"' eq good_date('02/06/09 22:18:08'), 'good_date header TemPageR'); 5059 ok('"02-Jan-2008 08:40:57 +0000"' eq good_date('Wed Jan 2 08:40:57 2008'), 'good_date header dice.com support 1digit day'); 5060 ok('"20-Aug-2006 11:55:09 +0000"' eq good_date('Sun Aug 20 11:55:09 2006'), 'good_date header dice.com support 2digit day'); 5061 ok('"24-Jan-2007 11:58:38 +0000"' eq good_date('Wed Jan 24 11:58:38 MST 2007'), 'good_date header status-now.com'); 5062 ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24 Aug 2010 16:00:00 +0200'), 'good_date header missing date of week'); 5063 ok('"24-Aug-2067 16:00:00 +0200"' eq good_date('Tue, 24 Aug 67 16:00:00 +0200'), 'good_date header 2digit year'); 5064 ok('"24-Aug-1977 16:00:00 +0200"' eq good_date('Tue, 24 Aug 77 16:00:00 +0200'), 'good_date header 2digit year'); 5065 ok('"24-Aug-1987 16:00:00 +0200"' eq good_date('Tue, 24 Aug 87 16:00:00 +0200'), 'good_date header 2digit year'); 5066 ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 97 16:00:00 +0200'), 'good_date header 2digit year'); 5067 ok('"24-Aug-2004 16:00:00 +0200"' eq good_date('Tue, 24 Aug 04 16:00:00 +0200'), 'good_date header 2digit year'); 5068 ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 1997 16.00.00 +0200'), 'good_date header period time sep'); 5069 ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 1997 16:00:00 +0200'), 'good_date header extra white space type1'); 5070 ok('"24-Aug-1997 05:06:02 +0200"' eq good_date('Tue, 24 Aug 1997 5:6:2 +0200'), 'good_date header 1digit time vals'); 5071 ok('"24-Aug-1997 05:06:02 +0200"' eq good_date('Tue, 24, Aug 1997 05:06:02 +0200'), 'good_date header extra commas'); 5072 ok('"01-Oct-2003 12:45:24 +0000"' eq good_date('Wednesday, 01 October 2003 12:45:24 CDT'), 'good_date header no abbrev'); 5073 ok('"11-Jan-2005 17:58:27 -0500"' eq good_date('Tue, 11 Jan 2005 17:58:27 -0500'), 'good_date extra white space'); 5074 ok('"18-Dec-2002 15:07:00 +0000"' eq good_date('Wednesday, December 18, 2002 03:07 PM'), 'good_date kbtoys.com orders'); 5075 ok('"16-Dec-2004 02:01:49 -0500"' eq good_date('Dec 16 2004 02:01:49 -0500'), 'good_date jr.com orders'); 5076 ok('"21-Jun-2001 11:11:11 +0000"' eq good_date('21-Jun-2001'), 'good_date register.com domain transfer'); 5077 5078 return( ) ; 5079} 5080 5081 5082sub tests_list_keys_in_2_not_in_1 { 5083 5084 my @list; 5085 ok( ! list_keys_in_2_not_in_1( {}, {}), 'list_keys_in_2_not_in_1: {} {}'); 5086 ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {}, {} ) ] ), 'list_keys_in_2_not_in_1: {} {}'); 5087 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}'); 5088 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}'); 5089 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}'); 5090 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}'); 5091 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}'); 5092 5093 return( ) ; 5094} 5095 5096sub list_keys_in_2_not_in_1 { 5097 5098 my $folders1_ref = shift; 5099 my $folders2_ref = shift; 5100 my @list; 5101 5102 foreach my $folder ( sort keys %$folders2_ref ) { 5103 next if exists($folders1_ref->{$folder}); 5104 push(@list, $folder); 5105 } 5106 return(@list); 5107} 5108 5109 5110sub list_folders_in_2_not_in_1 { 5111 5112 my (@h2_folders_not_in_h1, %h2_folders_not_in_h1) ; 5113 @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h1_folders_all, \%h2_folders_all) ; 5114 map { $h2_folders_not_in_h1{$_} = 1} @h2_folders_not_in_h1 ; 5115 @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h2_folders_from_1_all, \%h2_folders_not_in_h1) ; 5116 5117 return( reverse @h2_folders_not_in_h1 ); 5118} 5119 5120sub delete_folders_in_2_not_in_1 { 5121 5122 foreach my $folder (@h2_folders_not_in_1) { 5123 if ( defined( $delete2foldersonly ) and eval( "\$folder !~ $delete2foldersonly" ) ) { 5124 print "Not deleting $folder because of --delete2foldersonly $delete2foldersonly\n"; 5125 next; 5126 } 5127 if ( defined( $delete2foldersbutnot ) and eval( "\$folder =~ $delete2foldersbutnot" ) ) { 5128 print "Not deleting $folder because of --delete2foldersbutnot $delete2foldersbutnot\n"; 5129 next; 5130 } 5131 my $res = $dry ; # always success in dry mode! 5132 $imap2->unsubscribe( $folder ) if ( ! $dry ) ; 5133 $res = $imap2->delete( $folder ) if ( ! $dry ) ; 5134 if ( $res ) { 5135 print "Delete $folder", "$dry_message", "\n" ; 5136 }else{ 5137 print "Delete $folder failure", "\n" ; 5138 } 5139 } 5140 return( ) ; 5141} 5142 5143 5144sub extract_header { 5145 my $string = shift ; 5146 5147 my ( $header ) = split( /\n\n/x, $string ) ; 5148 if ( ! $header ) { return( '' ) ; } 5149 #print "[$header]\n" ; 5150 return( $header ) ; 5151} 5152 5153sub tests_extract_header { 5154 5155 5156my $h = <<'EOM'; 5157Message-Id: <20100428101817.A66CB162474E@plume.est.belle> 5158Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) 5159From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) 5160EOM 5161chomp( $h ) ; 5162ok( $h eq extract_header( 5163<<'EOM' 5164Message-Id: <20100428101817.A66CB162474E@plume.est.belle> 5165Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) 5166From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) 5167 5168body 5169lalala 5170EOM 5171), 'extract_header: 1') ; 5172 5173 5174 5175 return( ) ; 5176} 5177 5178sub decompose_header{ 5179 my $string = shift ; 5180 5181 # a hash, for a keyword header KEY value are list of strings [VAL1, VAL1_other, etc] 5182 # Think of multiple "Received:" header lines. 5183 my $header = { } ; 5184 5185 my ($key, $val ) ; 5186 my @line = split( /\n|\r\n/x, $string ) ; 5187 foreach my $line ( @line ) { 5188 #print "DDD $line\n" ; 5189 # End of header 5190 last if ( $line =~ m{^$}xo ) ; 5191 # Key: value 5192 if ( $line =~ m/(^[^:]+):\s(.*)/xo ) { 5193 $key = $1 ; 5194 $val = $2 ; 5195 $debugdev and print "DDD KV [$key] [$val]\n" ; 5196 push( @{ $header->{ $key } }, $val ) ; 5197 # blanc and value => value from previous line continues 5198 }elsif( $line =~ m/^(\s+)(.*)/xo ) { 5199 $val = $2 ; 5200 $debugdev and print "DDD V [$val]\n" ; 5201 @{ $header->{ $key } }[ -1 ] .= " $val" if $key ; 5202 # dirty line? 5203 }else{ 5204 next ; 5205 } 5206 } 5207 #require Data::Dumper ; 5208 #print Data::Dumper->Dump( [ $header ] ) ; 5209 5210 return( $header ) ; 5211} 5212 5213 5214sub tests_decompose_header{ 5215 5216 my $header_dec ; 5217 5218 $header_dec = decompose_header( 5219<<'EOH' 5220KEY_1: VAL_1 5221KEY_2: VAL_2 5222 VAL_2_+ 5223 VAL_2_++ 5224KEY_3: VAL_3 5225KEY_1: VAL_1_other 5226KEY_4: VAL_4 5227 VAL_4_+ 5228KEY_5 BLANC: VAL_5 5229 5230KEY_6_BAD_BODY: VAL_6 5231EOH 5232 ) ; 5233 5234 ok( 'VAL_3' 5235 eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: VAL_3' ) ; 5236 5237 ok( 'VAL_1' 5238 eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: VAL_1' ) ; 5239 5240 ok( 'VAL_1_other' 5241 eq $header_dec->{ 'KEY_1' }[1], 'decompose_header: VAL_1_other' ) ; 5242 5243 ok( 'VAL_2 VAL_2_+ VAL_2_++' 5244 eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: VAL_2 VAL_2_+ VAL_2_++' ) ; 5245 5246 ok( 'VAL_4 VAL_4_+' 5247 eq $header_dec->{ 'KEY_4' }[0], 'decompose_header: VAL_4 VAL_4_+' ) ; 5248 5249 ok( ' VAL_5' 5250 eq $header_dec->{ 'KEY_5 BLANC' }[0], 'decompose_header: KEY_5 BLANC' ) ; 5251 5252 ok( not( defined( $header_dec->{ 'KEY_6_BAD_BODY' }[0] ) ), 'decompose_header: KEY_6_BAD_BODY' ) ; 5253 5254 5255 $header_dec = decompose_header( 5256<<'EOH' 5257Message-Id: <20100428101817.A66CB162474E@plume.est.belle> 5258Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) 5259From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) 5260EOH 5261 ) ; 5262 5263 ok( '<20100428101817.A66CB162474E@plume.est.belle>' 5264 eq $header_dec->{ 'Message-Id' }[0], 'decompose_header: 1' ) ; 5265 5266 $header_dec = decompose_header( 5267<<'EOH' 5268Return-Path: <gilles@louloutte.dyndns.org> 5269Received: by plume.est.belle (Postfix, from userid 1000) 5270 id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST) 5271Subject: test:eekahceishukohpe 5272EOH 5273) ; 5274 ok( 5275'by plume.est.belle (Postfix, from userid 1000) id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST)' 5276 eq $header_dec->{ 'Received' }[0], 'decompose_header: 2' ) ; 5277 5278 $header_dec = decompose_header( 5279<<'EOH' 5280Received: from plume (localhost [127.0.0.1]) 5281 by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9 5282 for <gilles@localhost>; Mon, 26 Nov 2007 10:39:06 +0100 (CET) 5283Received: from plume [192.168.68.7] 5284 by plume with POP3 (fetchmail-6.3.6) 5285 for <gilles@localhost> (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET) 5286EOH 5287 ) ; 5288 ok( 5289 'from plume (localhost [127.0.0.1]) by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9 for <gilles@localhost>; Mon, 26 Nov 2007 10:39:06 +0100 (CET)' 5290 eq $header_dec->{ 'Received' }[0], 'decompose_header: 3' ) ; 5291 ok( 5292 'from plume [192.168.68.7] by plume with POP3 (fetchmail-6.3.6) for <gilles@localhost> (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET)' 5293 eq $header_dec->{ 'Received' }[1], 'decompose_header: 3' ) ; 5294 5295# Bad header beginning with a blank character 5296 $header_dec = decompose_header( 5297<<'EOH' 5298 KEY_1: VAL_1 5299KEY_2: VAL_2 5300 VAL_2_+ 5301 VAL_2_++ 5302KEY_3: VAL_3 5303KEY_1: VAL_1_other 5304EOH 5305 ) ; 5306 5307 ok( 'VAL_3' 5308 eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: Bad header VAL_3' ) ; 5309 5310 ok( 'VAL_1_other' 5311 eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: Bad header VAL_1_other' ) ; 5312 5313 ok( 'VAL_2 VAL_2_+ VAL_2_++' 5314 eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: Bad header VAL_2 VAL_2_+ VAL_2_++' ) ; 5315 5316 return( ) ; 5317} 5318 5319sub epoch { 5320 # incoming format: 5321 # internal date 24-Aug-2010 16:00:00 +0200 5322 5323 # outgoing format: epoch 5324 5325 5326 my $d = shift ; 5327 return ('') if not defined($d); 5328 5329 my ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) ; 5330 my $time ; 5331 5332 if ( $d =~ m{(\d{1,2})-([A-Z][a-z]{2})-(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-))(\d{2})(\d{2})}xo ) { 5333 #print "internal: [$1][$2][$3][$4][$5][$6][$7][$8][$9]\n" ; 5334 ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) 5335 = ( $1, $2, $3, $4, $5, $6, $7, $8, $9 ) ; 5336 #print "( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m )\n" ; 5337 5338 $sign = +1 if ( '+' eq $sign ) ; 5339 $sign = -1 if ( '-' eq $sign ) ; 5340 5341 $time = timegm( $sec, $min, $hour, $mday, $month_abrev{$month}, $year ) 5342 - $sign * ( 3600 * $zone_h + 60 * $zone_m ) ; 5343 5344 #print( "$time ", scalar(localtime($time)), "\n"); 5345 } 5346 return( $time ) ; 5347} 5348 5349sub tests_epoch { 5350 ok( '1282658400' eq epoch( '24-Aug-2010 16:00:00 +0200' ), 'epoch 24-Aug-2010 16:00:00 +0200 -> 1282658400' ) ; 5351 ok( '1282658400' eq epoch( '24-Aug-2010 14:00:00 +0000' ), 'epoch 24-Aug-2010 14:00:00 +0000 -> 1282658400' ) ; 5352 ok( '1282658400' eq epoch( '24-Aug-2010 12:00:00 -0200' ), 'epoch 24-Aug-2010 12:00:00 -0200 -> 1282658400' ) ; 5353 ok( '1282658400' eq epoch( '24-Aug-2010 16:01:00 +0201' ), 'epoch 24-Aug-2010 16:01:00 +0201 -> 1282658400' ) ; 5354 ok( '1282658400' eq epoch( '24-Aug-2010 14:01:00 +0001' ), 'epoch 24-Aug-2010 14:01:00 +0001 -> 1282658400' ) ; 5355 5356 ok( '1280671200' eq epoch( '1-Aug-2010 16:00:00 +0200' ), 'epoch 1-Aug-2010 16:00:00 +0200 -> 1280671200' ) ; 5357 ok( '1280671200' eq epoch( '1-Aug-2010 14:00:00 +0000' ), 'epoch 1-Aug-2010 14:00:00 +0000 -> 1280671200' ) ; 5358 ok( '1280671200' eq epoch( '1-Aug-2010 12:00:00 -0200' ), 'epoch 1-Aug-2010 12:00:00 -0200 -> 1280671200' ) ; 5359 ok( '1280671200' eq epoch( '1-Aug-2010 16:01:00 +0201' ), 'epoch 1-Aug-2010 16:01:00 +0201 -> 1280671200' ) ; 5360 ok( '1280671200' eq epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ; 5361 return( ) ; 5362} 5363 5364sub add_header { 5365 my $header_uid = shift || 'mistake' ; 5366 my $header_Message_Id = 'Message-Id: <' . $header_uid . '@imapsync>' ; 5367 return( $header_Message_Id ) ; 5368} 5369 5370sub tests_add_header { 5371 ok( 'Message-Id: <mistake@imapsync>' eq add_header(), 'add_header no arg' ) ; 5372 ok( 'Message-Id: <123456789@imapsync>' eq add_header(123456789), 'add_header 123456789' ) ; 5373 5374 return( ) ; 5375} 5376 5377sub tests_Banner{ 5378 5379 my $imap = Mail::IMAPClient->new( ) ; 5380 ok( 'lalala' eq $imap->Banner('lalala'), "Banner set lalala" ) ; 5381 ok( 'lalala' eq $imap->Banner(), "Banner get lalala" ) ; 5382 return( ) ; 5383} 5384 5385 5386 5387 5388sub max_line_length { 5389 my $string = shift ; 5390 my $max = 0 ; 5391 my $i ; 5392 while ( $string =~ m/([^\n]*\n?)/msxg ) { 5393 $max = max( $max, length( $1 ) ) ; 5394 #++$i ; 5395 #print "max $max $i\n" ; 5396 } 5397 #print "MAX $max $i\n\n" ; 5398 return( $max ) ; 5399} 5400 5401sub tests_max_line_length { 5402 ok( 0 == max_line_length( '' ), 'max_line_length: 0 == null string' ) ; 5403 ok( 1 == max_line_length( "\n" ), 'max_line_length: 1 == \n' ) ; 5404 ok( 1 == max_line_length( "\n\n" ), 'max_line_length: 1 == \n\n' ) ; 5405 ok( 1 == max_line_length( "\n" x 500 ), 'max_line_length: 1 == 500 \n' ) ; 5406 ok( 1 == max_line_length( "a" ), 'max_line_length: 1 == a' ) ; 5407 ok( 2 == max_line_length( "a\na" ), 'max_line_length: 2 == a\na' ) ; 5408 ok( 2 == max_line_length( "a\na\n" ), 'max_line_length: 2 == a\na\n' ) ; 5409 ok( 3 == max_line_length( "a\nab\n" ), 'max_line_length: 3 == a\nab\n' ) ; 5410 ok( 3 == max_line_length( "a\nab\n" x 10000 ), 'max_line_length: 3 == 10000 a\nab\n' ) ; 5411 ok( 3 == max_line_length( "a\nab\nabc" ), 'max_line_length: 3 == a\nab\nabc' ) ; 5412 5413 ok( 4 == max_line_length( "a\nab\nabc\n" ), 'max_line_length: 4 == a\nab\nabc\n' ) ; 5414 ok( 5 == max_line_length( "a\nabcd\nabc\n" ), 'max_line_length: 5 == a\nabcd\nabc\n' ) ; 5415 ok( 5 == max_line_length( "a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd" ), 'max_line_length: 5 == a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd' ) ; 5416 return( ) ; 5417} 5418 5419sub usage { 5420 my $localhost_info = localhost_info(); 5421 my $thank = thank_author(); 5422 my $imapsync_release = ''; 5423 $imapsync_release = check_last_release() if (not defined($releasecheck)); 5424 my $escape_char = ( 'MSWin32' eq $OSNAME ) ? '^' : '\\'; 5425 print <<"EOF"; 5426 5427usage: $0 [options] 5428 5429Several options are mandatory. 5430 5431--dry : Makes imapsync doing nothing, just print what would 5432 be done without --dry. 5433 5434--host1 <string> : Source or "from" imap server. Mandatory. 5435--port1 <int> : Port to connect on host1. Default is 143. 5436--user1 <string> : User to login on host1. Mandatory. 5437--showpasswords : Shows passwords on output instead of "MASKED". 5438 Useful to restart a complete run by just reading a log. 5439--password1 <string> : Password for the user1. 5440--host2 <string> : "destination" imap server. Mandatory. 5441--port2 <int> : Port to connect on host2. Default is 143. 5442--user2 <string> : User to login on host2. Mandatory. 5443--password2 <string> : Password for the user2. 5444 5445--passfile1 <string> : Password file for the user1. It must contain the 5446 password on the first line. This option avoids to show 5447 the password on the command line like --password1 does. 5448--passfile2 <string> : Password file for the user2. Contains the password. 5449--domain1 <string> : Domain on host1 (NTLM authentication). 5450--domain2 <string> : Domain on host2 (NTLM authentication). 5451--authuser1 <string> : User to auth with on host1 (admin user). 5452 Avoid using --authmech1 SOMETHING with --authuser1. 5453--authuser2 <string> : User to auth with on host2 (admin user). 5454--proxyauth1 : Use proxyauth on host1. Requires --authuser1. 5455 Required by Sun/iPlanet/Netscape IMAP servers to 5456 be able to use an administrative user. 5457--proxyauth2 : Use proxyauth on host2. Requires --authuser2. 5458 Required by Sun/iPlanet/Netscape IMAP servers to 5459 be able to use an administrative user 5460 5461--authmd51 : Use MD5 authentification for host1. 5462--authmd52 : Use MD5 authentification for host2. 5463--authmech1 <string> : Auth mechanism to use with host1: 5464 PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE. 5465--authmech2 <string> : Auth mechanism to use with host2. See --authmech1 5466--ssl1 : Use an SSL connection on host1. 5467--ssl2 : Use an SSL connection on host2. 5468--tls1 : Use an TLS connection on host1. 5469--tls2 : Use an TLS connection on host2. 5470--timeout <int> : Connections timeout in seconds. Default is 120. 5471 0 means no timeout. 5472 5473--folder <string> : Sync this folder. 5474--folder <string> : and this one, etc. 5475--folderrec <string> : Sync this folder recursively. 5476--folderrec <string> : and this one, etc. 5477--include <regex> : Sync folders matching this regular expression 5478 Blancs like in "foo bar" have to be written "foo\\ bar" 5479--include <regex> : or this one, etc. 5480 in case both --include --exclude options are 5481 use, include is done before. 5482--exclude <regex> : Skips folders matching this regular expression 5483 Several folders to avoid: 5484 --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3. 5485--exclude <regex> : or this one, etc. 5486--regextrans2 <regex> : Apply the whole regex to each destination folders. 5487--regextrans2 <regex> : and this one. etc. 5488 When you play with the --regextrans2 option, first 5489 add also the safe options --dry --justfolders 5490 Then, when happy, remove --dry, remove --justfolders. 5491 Have in mind that --regextrans2 is applied after prefix 5492 and separator inversion. 5493 5494--tmpdir <string> : Where to store temporary files and subdirectories. 5495 Will be created if it doesn't exist. 5496 Default is system specific, Unix is /tmp but 5497 it's often small and deleted at reboot. 5498 --tmpdir /var/tmp should be better. 5499--pidfile <string> : The file where imapsync pid is written. 5500--pidfilelocking : Abort if pidfile already exists. Usefull to avoid 5501 concurrent transfers on the same mailbox. 5502 5503--prefix1 <string> : Remove prefix to all destination folders 5504 (usually INBOX. or INBOX/ or an empty string "") 5505 you have to use --prefix1 if host1 imap server 5506 does not have NAMESPACE capability, all other 5507 cases are bad. 5508--prefix2 <string> : Add prefix to all host2 folders. See --prefix1 5509--sep1 <string> : Host1 separator in case NAMESPACE is not supported. 5510--sep2 <string> : Host2 separator in case NAMESPACE is not supported. 5511 5512--regexmess <regex> : Apply the whole regex to each message before transfer. 5513 Example: 's/\\000/ /g' # to replace null by space. 5514--regexmess <regex> : and this one. 5515--regexmess <regex> : and this one, etc. 5516--regexflag <regex> : Apply the whole regex to each flags list. 5517 Example: 's/\"Junk"//g' # to remove "Junk" flag. 5518--regexflag <regex> : and this one, etc. 5519 5520--delete : Deletes messages on host1 server after a successful 5521 transfer. Option --delete has the following behavior: 5522 it marks messages as deleted with the IMAP flag 5523 \\Deleted, then messages are really deleted with an 5524 EXPUNGE IMAP command. 5525--delete2 : Delete messages in host2 that are not in 5526 host1 server. Useful for backup or pre-sync. 5527--delete2duplicates : Delete messages in host2 that are duplicates. 5528 Works only without --useuid since duplicates are 5529 detected with header part of each message. 5530--delete2folders : Delete folders in host2 that are not in host1 server. 5531 For safety, first try it like this (it is safe): 5532 --delete2folders --dry --justfolders --nofoldersizes 5533--delete2foldersonly <regex>: Deleted only folders matching regex. 5534--delete2foldersbutnot <regex>: Do not delete folders matching regex. 5535 Example: --delete2foldersbutnot "/Tasks|Contacts|Foo/" 5536--noexpunge : Do not expunge messages on host1. 5537 Expunge really deletes messages marked deleted. 5538 Expunge is made at the beginning, on host1 only. 5539 Newly transferred messages are also expunged if 5540 option --delete is given. 5541 No expunge is done on host2 account (unless --expunge2) 5542--expunge1 : Expunge messages on host1 after messages transfer. 5543--expunge2 : Expunge messages on host2 after messages transfer. 5544--uidexpunge2 : uidexpunge messages on the host2 account 5545 that are not on the host1 account, requires --delete2 5546 5547--syncinternaldates : Sets the internal dates on host2 same as host1. 5548 Turned on by default. Internal date is the date 5549 a message arrived on a host (mtime). 5550--idatefromheader : Sets the internal dates on host2 same as the 5551 "Date:" headers. 5552 5553--maxsize <int> : Skip messages larger (or equal) than <int> bytes 5554--minsize <int> : Skip messages smaller (or equal) than <int> bytes 5555--maxage <int> : Skip messages older than <int> days. 5556 final stats (skipped) don't count older messages 5557 see also --minage 5558--minage <int> : Skip messages newer than <int> days. 5559 final stats (skipped) don't count newer messages 5560 You can do (+ are the messages selected): 5561 past|----maxage+++++++++++++++>now 5562 past|+++++++++++++++minage---->now 5563 past|----maxage+++++minage---->now (intersection) 5564 past|++++minage-----maxage++++>now (union) 5565 5566--search <string> : Selects only messages returned by this IMAP SEARCH 5567 command. Applied on both sides. 5568--search1 <string> : Same as --search for selecting host1 messages only. 5569--search2 <string> : Same as --search for selecting host2 messages only. 5570 --search CRIT equals --search1 CRIT --search2 CRIT 5571 5572--exitwhenover <int> : Stop syncing when total bytes transferred reached. 5573 Gmail per day allows 2500000000 down 500000000 upload. 5574 5575--maxlinelength <int> : skip messages with line length longer than <int> bytes. 5576 RFC 2822 says it must be no more than 1000 bytes. 5577 5578--useheader <string> : Use this header to compare messages on both sides. 5579 Ex: Message-ID or Subject or Date. 5580--useheader <string> and this one, etc. 5581 5582--subscribed : Transfers subscribed folders. 5583--subscribe : Subscribe to the folders transferred on the 5584 host2 that are subscribed on host1. On by default. 5585--subscribe_all : Subscribe to the folders transferred on the 5586 host2 even if they are not subscribed on host1. 5587 5588--nofoldersizes : Do not calculate the size of each folder in bytes 5589 and message counts. Default is to calculate them. 5590--nofoldersizesatend : Do not calculate the size of each folder in bytes 5591 and message counts at the end. Default is on. 5592--justfoldersizes : Exit after having printed the folder sizes. 5593 5594--syncacls : Synchronises acls (Access Control Lists). 5595--nosyncacls : Does not synchronize acls. This is the default. 5596 Acls in IMAP are not standardized, be careful. 5597 5598--usecache : Use cache to speedup. 5599--nousecache : Do not use cache. Caveat: --useuid --nousecache creates 5600 duplicates on multiple runs. 5601--useuid : Use uid instead of header as a criterium to recognize 5602 messages. Option --usecache is then implied unless 5603 --nousecache is used. 5604 5605--debug : Debug mode. 5606--debugcontent : Debug content of the messages transfered. 5607--debugflags : Debug flags. 5608--debugimap1 : IMAP debug mode for host1. imap debug is very verbose. 5609--debugimap2 : IMAP debug mode for host2. 5610--debugimap : IMAP debug mode for host1 and host2. 5611 5612--version : Print software version. 5613--noreleasecheck : Do not check for new imapsync release (a http request). 5614--justconnect : Just connect to both servers and print useful 5615 information. Need only --host1 and --host2 options. 5616--justlogin : Just login to both host1 and host2 with users 5617 credentials, then exit. 5618--justfolders : Do only things about folders (ignore messages). 5619 5620--help : print this help. 5621 5622Example: to synchronize imap account "foo" on "imap.truc.org" 5623 to imap account "bar" on "imap.trac.org" 5624 with foo password "secret1" 5625 and bar password "secret2" 5626 5627$0 $escape_char 5628 --host1 imap.truc.org --user1 foo --password1 secret1 $escape_char 5629 --host2 imap.trac.org --user2 bar --password2 secret2 5630 5631$localhost_info 5632$rcs 5633$imapsync_release 5634 5635$thank 5636EOF 5637 return( 1 ) ; 5638} 5639 5640sub usage_complete { 5641 print <<'EOF' ; 5642--skipheader <regex> : Don't take into account header keyword 5643 matching <string> ex: --skipheader 'X.*' 5644 5645--skipsize : Don't take message size into account to compare 5646 messages on both sides. On by default. 5647 Use --no-skipsize for using size comparaison. 5648--allowsizemismatch : allow RFC822.SIZE != fetched msg size 5649 consider also --skipsize to avoid duplicate messages 5650 when running syncs more than one time per mailbox 5651 5652--reconnectretry1 <int>: reconnect to host1 if connection is lost up to 5653 <int> times per imap command (default is 3) 5654--reconnectretry2 <int>: same as --reconnectretry1 but for host2 5655--split1 <int> : split the requests in several parts on host1. 5656 <int> is the number of messages handled per request. 5657 default is like --split1 500. 5658--split2 <int> : same thing on host2. 5659EOF 5660 return( ) ; 5661} 5662 5663 5664 5665sub get_options { 5666 my $numopt = scalar(@ARGV); 5667 my $argv = join("�", @ARGV); 5668 5669 $test_builder = Test::More->builder; 5670 $test_builder->no_ending(1); 5671 5672 if($argv =~ m/-delete�2/x) { 5673 print "May be you mean --delete2 instead of --delete 2\n"; 5674 exit 1; 5675 } 5676 my $opt_ret = GetOptions( 5677 "debug!" => \$debug, 5678 "debugLIST!" => \$debugLIST, 5679 "debugcontent!" => \$debugcontent, 5680 "debugsleep!" => \$debugsleep, 5681 "debugflags!" => \$debugflags, 5682 "debugimap!" => \$debugimap, 5683 "debugimap1!" => \$debugimap1, 5684 "debugimap2!" => \$debugimap2, 5685 "debugdev!" => \$debugdev, 5686 "host1=s" => \$host1, 5687 "host2=s" => \$host2, 5688 "port1=i" => \$port1, 5689 "port2=i" => \$port2, 5690 "user1=s" => \$user1, 5691 "user2=s" => \$user2, 5692 "domain1=s" => \$domain1, 5693 "domain2=s" => \$domain2, 5694 "password1=s" => \$password1, 5695 "password2=s" => \$password2, 5696 "passfile1=s" => \$passfile1, 5697 "passfile2=s" => \$passfile2, 5698 "authmd5!" => \$authmd5, 5699 "authmd51!" => \$authmd51, 5700 "authmd52!" => \$authmd52, 5701 "sep1=s" => \$sep1, 5702 "sep2=s" => \$sep2, 5703 "folder=s" => \@folder, 5704 "folderrec=s" => \@folderrec, 5705 "include=s" => \@include, 5706 "exclude=s" => \@exclude, 5707 "prefix1=s" => \$prefix1, 5708 "prefix2=s" => \$prefix2, 5709 "fixslash2!" => \$fixslash2, 5710 "fixInboxINBOX!" => \$fixInboxINBOX, 5711 "regextrans2=s" => \@regextrans2, 5712 "regexmess=s" => \@regexmess, 5713 "regexflag=s" => \@regexflag, 5714 "filterflags!" => \$filterflags, 5715 "flagsCase!" => \$flagsCase, 5716 "syncflagsaftercopy!" => \$syncflagsaftercopy, 5717 "delete|delete1!" => \$delete, 5718 "delete2!" => \$delete2, 5719 "delete2duplicates!" => \$delete2duplicates, 5720 "delete2folders!" => \$delete2folders, 5721 "delete2foldersonly=s" => \$delete2foldersonly, 5722 "delete2foldersbutnot=s" => \$delete2foldersbutnot, 5723 "syncinternaldates!" => \$syncinternaldates, 5724 "idatefromheader!" => \$idatefromheader, 5725 "syncacls!" => \$syncacls, 5726 "maxsize=i" => \$maxsize, 5727 "minsize=i" => \$minsize, 5728 "maxage=i" => \$maxage, 5729 "minage=i" => \$minage, 5730 "search=s" => \$search, 5731 "search1=s" => \$search1, 5732 "search2=s" => \$search2, 5733 "foldersizes!" => \$foldersizes, 5734 "foldersizesatend!" => \$foldersizesatend, 5735 "dry!" => \$dry, 5736 "expunge!" => \$expunge, 5737 "expunge1!" => \$expunge1, 5738 "expunge2!" => \$expunge2, 5739 "uidexpunge2!" => \$uidexpunge2, 5740 "subscribed!" => \$subscribed, 5741 "subscribe!" => \$subscribe, 5742 "subscribe_all!" => \$subscribe_all, 5743 "justbanner!" => \$justbanner, 5744 "justconnect!"=> \$justconnect, 5745 "justfolders!"=> \$justfolders, 5746 "justfoldersizes!" => \$justfoldersizes, 5747 "fast!" => \$fast, 5748 "version" => \$version, 5749 "help" => \$help, 5750 "timeout=i" => \$timeout, 5751 "skipheader=s" => \$skipheader, 5752 "useheader=s" => \@useheader, 5753 "wholeheaderifneeded!" => \$wholeheaderifneeded, 5754 "messageidnodomain!" => \$messageidnodomain, 5755 "skipsize!" => \$skipsize, 5756 "allowsizemismatch!" => \$allowsizemismatch, 5757 "fastio1!" => \$fastio1, 5758 "fastio2!" => \$fastio2, 5759 "ssl1!" => \$ssl1, 5760 "ssl2!" => \$ssl2, 5761 "ssl1_SSL_version=s" => \$ssl1_SSL_version, 5762 "ssl2_SSL_version=s" => \$ssl2_SSL_version, 5763 "tls1!" => \$tls1, 5764 "tls2!" => \$tls2, 5765 "uid1!" => \$uid1, 5766 "uid2!" => \$uid2, 5767 "authmech1=s" => \$authmech1, 5768 "authmech2=s" => \$authmech2, 5769 "authuser1=s" => \$authuser1, 5770 "authuser2=s" => \$authuser2, 5771 "proxyauth1" => \$proxyauth1, 5772 "proxyauth2" => \$proxyauth2, 5773 "split1=i" => \$split1, 5774 "split2=i" => \$split2, 5775 "buffersize=i" => \$buffersize, 5776 "reconnectretry1=i" => \$reconnectretry1, 5777 "reconnectretry2=i" => \$reconnectretry2, 5778 "relogin1=i" => \$relogin1, 5779 "relogin2=i" => \$relogin2, 5780 "tests" => \$tests, 5781 "tests_debug" => \$tests_debug, 5782 "allow3xx!" => \$allow3xx, 5783 "justlogin!" => \$justlogin, 5784 "tmpdir=s" => \$tmpdir, 5785 "pidfile=s" => \$pidfile, 5786 "pidfilelocking!" => \$pidfilelocking, 5787 "releasecheck!" => \$releasecheck, 5788 "modules_version!" => \$modules_version, 5789 "usecache!" => \$usecache, 5790 "cacheaftercopy!" => \$cacheaftercopy, 5791 "debugcache!" => \$debugcache, 5792 "useuid!" => \$useuid, 5793 "addheader!" => \$addheader, 5794 "exitwhenover=i" => \$exitwhenover, 5795 "checkselectable!" => \$checkselectable, 5796 "checkmessageexists!" => \$checkmessageexists, 5797 "expungeaftereach!" => \$expungeaftereach, 5798 "abletosearch!" => \$abletosearch, 5799 "showpasswords!" => \$showpasswords, 5800 "maxlinelength=i" => \$maxlinelength, 5801 ); 5802 5803 $debug and print "get options: [$opt_ret]\n"; 5804 5805 # just the version 5806 print imapsync_version(), "\n" and exit if ($version) ; 5807 5808 if ($tests) { 5809 $test_builder->no_ending(0); 5810 tests(); 5811 exit; 5812 } 5813 if ($tests_debug) { 5814 $test_builder->no_ending(0); 5815 tests_debug(); 5816 exit; 5817 } 5818 5819 $help = 1 if ! $numopt; 5820 load_modules(); 5821 5822 # exit with --help option or no option at all 5823 usage( ) and exit( ) if ( $help or not $numopt ) ; 5824 5825 # don't go on if options are not all known. 5826 exit( EX_USAGE( ) ) unless ( $opt_ret ) ; 5827 return( ) ; 5828} 5829 5830 5831sub tests_debug { 5832 5833 SKIP: { 5834 skip "No test in normal run" if ( not $tests_debug ); 5835 tests_msgs_from_maxmin( ) ; 5836 } 5837 return( ) ; 5838} 5839 5840sub tests { 5841 5842 SKIP: { 5843 skip "No test in normal run" if (not $tests); 5844 tests_folder_routines(); 5845 tests_compare_lists(); 5846 tests_regexmess(); 5847 tests_flags_regex(); 5848 tests_permanentflags(); 5849 tests_flags_filter( ) ; 5850 tests_separator_invert( ) ; 5851 tests_imap2_folder_name(); 5852 tests_command_line_nopassword(); 5853 tests_good_date(); 5854 tests_max(); 5855 tests_remove_not_num(); 5856 tests_memory_consumption(); 5857 tests_is_a_release_number(); 5858 tests_imapsync_basename(); 5859 tests_list_keys_in_2_not_in_1(); 5860 tests_convert_sep_to_slash( ) ; 5861 tests_match_a_cache_file( ) ; 5862 tests_cache_map( ) ; 5863 tests_get_cache( ) ; 5864 tests_clean_cache( ) ; 5865 tests_clean_cache_2( ) ; 5866 tests_touch( ) ; 5867 tests_ucsecond( ) ; 5868 tests_flagsCase( ) ; 5869 tests_mkpath( ) ; 5870 tests_extract_header( ) ; 5871 tests_decompose_header( ) ; 5872 tests_epoch( ) ; 5873 tests_add_header( ) ; 5874 tests_cache_dir_fix( ) ; 5875 tests_filter_forbidden_characters( ) ; 5876 tests_cache_folder( ) ; 5877 tests_time_remaining( ) ; 5878 tests_decompose_regex( ) ; 5879 tests_Banner( ) ; 5880 tests_backtick( ) ; 5881 tests_bytes_display_string( ) ; 5882 tests_header_line_normalize( ) ; 5883 tests_fix_Inbox_INBOX_mapping( ) ; 5884 tests_max_line_length( ) ; 5885 tests_subject( ) ; 5886 tests_msgs_from_maxmin( ) ; 5887 } 5888 return( ) ; 5889} 5890 5891 5892 5893# IMAPClient 3.xx ads 5894 5895package Mail::IMAPClient; 5896 5897sub Tls { 5898 my $self = shift ; 5899 my $value = shift ; 5900 if ( defined( $value ) ) { $self->{TLS} = $value } 5901 return $self->{TLS}; 5902} 5903 5904sub Reconnect_counter { 5905 my $self = shift ; 5906 my $value = shift ; 5907 $self->{Reconnect_counter} = 0 if ( not defined( $self->{Reconnect_counter} ) ) ; 5908 if ( defined( $value ) ) { $self->{Reconnect_counter} = $value } 5909 return( $self->{Reconnect_counter} ) ; 5910} 5911 5912 5913sub Banner { 5914 my $self = shift ; 5915 my $value = shift ; 5916 if ( defined( $value ) ) { $self->{ BANNER } = $value } 5917 return $self->{ BANNER }; 5918} 5919 5920sub capability_update { 5921 my $self = shift ; 5922 5923 delete $self->{CAPABILITY} ; 5924 return( $self->capability ) ; 5925} 5926 5927