1#!/usr/bin/perl -w 2 3use lib '/usr/share/imapsync/'; 4 5=pod 6 7=head1 NAME 8 9imapsync - IMAP synchronisation, sync, copy or migration 10tool. Synchronise mailboxes between two imap servers. Good 11at IMAP migration. More than 32 different IMAP server softwares 12supported with success. 13 14$Revision: 1.241 $ 15 16=head1 INSTALL 17 18 imapsync works fine under any Unix OS with perl. 19 imapsync works fine under Windows 2000 (at least) and ActiveState's 5.8 Perl 20 21 imapsync is already available directly on the following distributions (at least): 22 FreeBSD, Debian, Ubuntu, Gentoo, NetBSD, Darwin, Mandriva. 23 24 Get imapsync at 25 http://www.linux-france.org/prj/imapsync/dist/ 26 27 You'll find a compressed tarball called imapsync-x.xx.tgz 28 where x.xx is the version number. Untar the tarball where 29 you want (on Unix): 30 31 tar xzvf imapsync-x.xx.tgz 32 33 Go into the directory imapsync-x.xx and read the INSTALL file. 34 The INSTALL file is also at 35 http://www.linux-france.org/prj/imapsync/INSTALL (for windows users) 36 37 The freshmeat record is at http://freshmeat.net/projects/imapsync/ 38 39=head1 SYNOPSIS 40 41 imapsync [options] 42 43To get a description of each option just run imapsync like this : 44 45 imapsync --help 46 imapsync 47 48The option list : 49 50 imapsync [--host1 server1] [--port1 <num>] 51 [--user1 <string>] [--passfile1 <string>] 52 [--host2 server2] [--port2 <num>] 53 [--user2 <string>] [--passfile2 <string>] 54 [--ssl1] [--ssl2] 55 [--authmech1 <string>] [--authmech2 <string>] 56 [--noauthmd5] 57 [--folder <string> --folder <string> ...] 58 [--folderrec <string> --folderrec <string> ...] 59 [--include <regex>] [--exclude <regex>] 60 [--prefix2 <string>] [--prefix1 <string>] 61 [--regextrans2 <regex> --regextrans2 <regex> ...] 62 [--sep1 <char>] 63 [--sep2 <char>] 64 [--justfolders] [--justfoldersizes] [--justconnect] 65 [--syncinternaldates] 66 [--buffersize <int>] 67 [--syncacls] 68 [--regexmess <regex>] [--regexmess <regex>] 69 [--maxsize <int>] 70 [--maxage <int>] 71 [--minage <int>] 72 [--skipheader <regex>] 73 [--useheader <string>] [--useheader <string>] 74 [--skipsize] 75 [--delete] [--delete2] 76 [--expunge] [--expunge1] [--expunge2] 77 [--subscribed] [--subscribe] 78 [--nofoldersizes] 79 [--dry] 80 [--debug] [--debugimap] 81 [--timeout <int>] [--fast] 82 [--split1] [--split2] 83 [--version] [--help] 84 85=cut 86# comment 87 88=pod 89 90=head1 DESCRIPTION 91 92The command imapsync is a tool allowing incremental and 93recursive imap transfer from one mailbox to another. 94 95By default all folders are transfered, recursively. 96 97We sometimes need to transfer mailboxes from one imap server to 98another. This is called migration. 99 100imapsync is the adequate tool because it reduces the amount 101of data transferred by not transferring a given message if it 102is already on both sides. Same headers, same message size 103and the transfer is done only once. All flags are 104preserved, unread will stay unread, read will stay read, 105deleted will stay deleted. You can stop the transfer at any 106time and restart it later, imapsync is adapted to a bad 107connection. imapsync is CPU hungry so nice and renice 108commands can be a good help. imapsync can be memory hungry too, 109especially with large messages. 110 111You can decide to delete the messages from the source mailbox 112after a successful transfer (it is a good feature when migrating). 113In that case, use the --delete --expunge1 options. 114 115You can also just synchronize a mailbox A from another mailbox B 116in case you just want to keep a "live" copy of B in A. 117 118=head1 OPTIONS 119 120To get a description of each option just invoke: 121 122imapsync --help 123 124=head1 HISTORY 125 126I wrote imapsync because an enterprise (basystemes) paid me to install 127a new imap server without loosing huge old mailboxes located on a far 128away remote imap server accessible by a low bandwith link. The tool 129imapcp (written in python) could not help me because I had to verify 130every mailbox was well transferred and delete it after a good 131transfer. imapsync started its life being a copy_folder.pl patch. 132The tool copy_folder.pl comes from the Mail-IMAPClient-2.1.3 perl 133module tarball source (in the examples/ directory of the tarball). 134 135=head1 EXAMPLE 136 137While working on imapsync parameters please run imapsync in 138dry mode (no modification induced) with the --dry 139option. Nothing bad can be done this way. 140 141To synchronize the imap account "buddy" on host 142"imap.src.fr" to the imap account "max" on host 143"imap.dest.fr" (the passwords are located in two files 144"/etc/secret1" for "buddy", "/etc/secret2" for "max") : 145 146 imapsync --host1 imap.src.fr --user1 buddy --passfile1 /etc/secret1 \ 147 --host2 imap.dest.fr --user2 max --passfile2 /etc/secret2 148 149Then, you will have max's mailbox updated from buddy's 150mailbox. 151 152=head1 SECURITY 153 154You can use --password1 instead of --passfile1 to give the 155password but it is dangerous because any user on your host 156can see the password by using the 'ps auxwwww' 157command. Using a variable (like $PASSWORD1) is also 158dangerous because of the 'ps auxwwwwe' command. So, saving 159the password in a well protected file (600 or rw-------) is 160the best solution. 161 162imasync is not totally protected against sniffers on the 163network since passwords may be transferred in plain text in 164case CRAM-MD5 is not supported by your imap servers. Use 165--ssl1 and --ssl2 to enable encryption on host1 and host2. 166 167You may authenticate as one user (typically an admin user), 168but be authorized as someone else, which means you don't 169need to know every user's personal password. Specify 170--authuser1 "adminuser" to enable this on host1. In this 171case, --authmech1 PLAIN will be used by default since it 172is the only way to go for now. So don't use --authmech1 SOMETHING 173with --authuser1 "adminuser", it will not work. 174Same behavior with the --authuser2 option. 175 176 177=head1 EXIT STATUS 178 179imapsync will exit with a 0 status (return code) if everything went good. 180Otherwise, it exits with a non-zero status. 181 182So if you have a buggy internet connection, you can use this loop 183in a Bourne shell: 184 185 while ! imapsync ...; do 186 echo imapsync not complete 187 done 188 189=head1 AUTHOR 190 191Gilles LAMIRAL <lamiral@linux-france.org> 192 193Feedback good or bad is always welcome. 194 195The newsgroup comp.mail.imap is a good place to talk about 196imapsync. I read it when imapsync is concerned. 197 198Gilles LAMIRAL earn his living writing, installing, 199configuring and teaching free open and gratis 200softwares. Do not hesitate to pay him for that services. 201 202 203=head1 LICENSE 204 205imapsync is free, gratis and open source software cover by 206the GNU General Public License. See the GPL file included in 207the distribution or the web site 208http://www.gnu.org/licenses/licenses.html 209 210=head1 BUGS 211 212No known serious bug. Report any bug to the author. 213Before reporting bugs, read the FAQ, this README and the 214TODO files. 215 216Don't write imapsync in uppercase in the email title, I'll 217know you run windows. 218 219Make a good title, not just "imapsync" or "problem", 220a good title is made of keywords summary, not too long (one visible line). 221 222In your report, please include: 223 224 - imapsync version. 225 - IMAPClient.pm version. 226 - perl version. 227 - operating system running imapsync. 228 - imap servers softwares on both side and their version. 229 230 Those values can be found with the command line 231 232 imapsync --host1 imap.host1.net --host2 imap.host2.org --justconnect 233 234 And also, if it can help : 235 236 - operating systems on both sides and the third side in case 237 you run imapsync on a foreign host from the both. 238 - imapsync with all the options you use, the full command line 239 you use (except the passwords of course). This can be found 240 at the beginning of the output. 241 - output given with --debug --debugimap near the failure point. 242 243=head1 IMAP SERVERS 244 245Failure stories reported with the following 4 imap servers : 246 247 - MailEnable 1.54 (Proprietary) http://www.mailenable.com/ 248 - DBMail 0.9, 2.0.7 (GPL). But DBMail 1.2.1 works. 249 Patient and confident testers are welcome. 250 - dkimap4 2.39 251 - Imail 7.04 (maybe). 252 253Success stories reported with the following 35 imap servers 254(softwares names are in alphabetic order) : 255 256 - Archiveopteryx 2.03, 2.04 (OSL 3.0) http://www.archiveopteryx.org/ 257 - BincImap 1.2.3 (GPL) (http://www.bincimap.org/) 258 - CommuniGatePro server (Redhat 8.0) 259 - Courier IMAP 1.5.1, 2.2.0, 2.1.1, 2.2.1, 3.0.8, 3.0.3, 4.1.1 (GPL) 260 (http://www.courier-mta.org/) 261 - Critical Path (7.0.020) 262 - Cyrus IMAP 1.5, 1.6, 2.1, 2.1.15, 2.1.16, 2.1.18 263 2.2.1, 2.2.2-BETA, 2.2.10, 2.2.12, 264 v2.2.3-Invoca-RPM-2.2.3-8, 265 2.3-alpha (OSI Approved), 266 v2.2.12-Invoca-RPM-2.2.12-3.RHEL4.1, 267 2.2.13, 268 v2.3.1-Invoca-RPM-2.3.1-2.7.fc5, 269 (http://asg.web.cmu.edu/cyrus/) 270 - David Tobit V8 (proprietary Message system). 271 - DBMail 1.2.1, 2.0.4, 2.0.9, 2.2rc1 (GPL) (http://www.dbmail.org/). 272 2.0.7 seems buggy. 273 - Deerfield VisNetic MailServer 5.8.6 [from] 274 - Dovecot 0.99.10.4, 0.99.14, 0.99.14-8.fc4, 1.0-0.beta2.7, 275 1.0.0 [dest] (LGPL) (http://www.dovecot.org/) 276 - Domino (Notes) 6.5, 5.0.6, 5.0.7, 7.0.2, 6.0.2CF1, 7.0.1 [from] 277 - Eudora WorldMail v2 278 - GMX IMAP4 StreamProxy. 279 - Groupwise IMAP (Novell) 6.x and 7.0. Buggy so see the FAQ. 280 - iPlanet Messaging server 4.15, 5.1, 5.2 281 - IMail 7.15 (Ipswitch/Win2003), 8.12 282 - MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform) 283 - Mercury 4.1 (Windows server 2000 platform) 284 - Microsoft Exchange Server 5.5, 6.5.7638.1 [dest] 285 - Netscape Mail Server 3.6 (Wintel !) 286 - Netscape Messaging Server 4.15 Patch 7 287 - OpenMail IMAP server B.07.00.k0 (Samsung Contact ?) 288 - OpenWave 289 - Qualcomm Worldmail (NT) 290 - Rockliffe Mailsite 5.3.11, 4.5.6 291 - Samsung Contact IMAP server 8.5.0 292 - Scalix v10.1, 10.0.1.3, 11.0.0.431 293 - SmarterMail 294 - SunONE Messaging server 5.2, 6.0 (SUN JES - Java Enterprise System) 295 - Sun Java System Messaging Server 6.2-2.05 296 - Surgemail 3.6f5-5 297 - UW-imap servers (imap-2000b) rijkkramer IMAP4rev1 2000.287 298 (RedHat uses UW like 2003.338rh), v12.264 Solaris 5.7 (OSI Approved) 299 (http://www.washington.edu/imap/) 300 - UW - QMail v2.1 301 - Imap part of TCP/IP suite of VMS 7.3.2 302 - Zimbra-IMAP 3.0.1 GA 160, 3.1.0 Build 279, 4.0.5, 4.5.2, 4.5.6, 5.5. 303 304Please report to the author any success or bad story with 305imapsync and don't forget to mention the IMAP server 306software names and version on both sides. This will help 307future users. To help the author maintaining this section 308report the two lines at the begining of the output if they 309are useful to know the softwares. Example: 310 311 From software :* OK louloutte Cyrus IMAP4 v1.5.19 server ready 312 To software :* OK Courier-IMAP ready 313 314You can use option --justconnect to get those lines. 315Example : 316 317 imapsync --host1 imap.troc.org --host2 imap.trac.org --justconnect 318 319Please rate imapsync at http://freshmeat.net/projects/imapsync/ 320or better give the author a book, he likes books: 321http://www.amazon.com/gp/registry/wishlist/1C9UNDIH3P7R7/ 322(or its paypal account gilles.lamiral@laposte.net) 323 324=head1 HUGE MIGRATION 325 326 327Have a special attention on options 328--subscribed 329--subscribe 330--delete 331--delete2 332--expunge 333--expunge1 334--expunge2 335--maxage 336--minage 337--maxsize 338--useheader 339 340If you have many mailboxes to migrate think about a little 341shell program. Write a file called file.csv (for example) 342containing users and passwords. 343The separator used in this example is ';' 344 345The file.csv file content is : 346 347user0001;password0001;user0002;password0002 348user0011;password0011;user0012;password0012 349... 350 351And the shell program is just : 352 353 { while IFS=';' read u1 p1 u2 p2; do 354 imapsync --user1 "$u1" --password1 "$p1" --user2 "$u2" --password2 "$p2" ... 355 done ; } < file.csv 356 357Welcome in shell programming ! 358 359=head1 Hacking 360 361Feel free to hack imapsync as the GPL Licence permits it. 362 363=head1 Links 364 365Entries for imapsync: 366 http://www.imap.org/products/showall.php 367 368 369=head1 SIMILAR SOFTWARES 370 371 imap_tools : http://www.athensfbc.com/imap_tools 372 offlineimap : http://software.complete.org/offlineimap 373 mailsync : http://mailsync.sourceforge.net/ 374 imapxfer : http://www.washington.edu/imap/ 375 part of the imap-utils from UW. 376 mailutil : replace imapxfer in 377 part of the imap-utils from UW. 378 http://www.gsp.com/cgi-bin/man.cgi?topic=mailutil 379 imaprepl : http://www.bl0rg.net/software/ 380 http://freshmeat.net/projects/imap-repl/ 381 imap_migrate : http://freshmeat.net/projects/imapmigration/ 382 imapcopy : http://home.arcor.de/armin.diehl/imapcopy/imapcopy.html 383 migrationtool : http://sourceforge.net/projects/migrationtool/ 384 imapmigrate : http://sourceforge.net/projects/cyrus-utils/ 385 wonko_imapsync: http://wonko.com/article/554 386 see also tools/wonko_ruby_imapsync 387 pop2imap : http://www.linux-france.org/prj/pop2imap/ 388 389 390Feedback (good or bad) will be always welcome. 391 392$Id: imapsync,v 1.241 2007/12/31 13:39:02 gilles Exp gilles $ 393 394 395 396=cut 397 398 399++$|; 400use strict; 401use Getopt::Long; 402use Mail::IMAPClient; 403use Digest::MD5 qw(md5_base64); 404#use Term::ReadKey; 405#use IO::Socket::SSL; 406use MIME::Base64; 407use English; 408use POSIX qw(uname); 409use Fcntl; 410 411#use Test::Simple tests => 1; 412use Test::More 'no_plan'; 413 414eval { require 'usr/include/sysexits.ph' }; 415 416 417my( 418 $rcs, $debug, $debugimap, $error,$is_yahoo, 419 $host1, $host2, $port1, $port2, 420 $user1, $user2, $password1, $password2, $passfile1, $passfile2, 421 @folder, @include, @exclude, @folderrec, 422 $prefix1, $prefix2, 423 @regextrans2, @regexmess, @regexflag, 424 $sep1, $sep2, 425 $syncinternaldates, $syncacls, 426 $fastio1, $fastio2, 427 $maxsize, $maxage, $minage, 428 $skipheader, @useheader, 429 $skipsize, $foldersizes, $buffersize, 430 $delete, $delete2, 431 $expunge, $expunge1, $expunge2, $dry, 432 $justfoldersizes, 433 $authmd5, 434 $subscribed, $subscribe, 435 $version, $VERSION, $help, 436 $justconnect, $justfolders, 437 $fast, 438 $mess_size_total_trans, 439 $mess_size_total_skipped, 440 $mess_size_total_error, 441 $mess_trans, $mess_skipped, $mess_skipped_dry, 442 $timeout, # whr (ESS/PRW) 443 $timestart, $timeend, $timediff, 444 $timesize, $timebefore, 445 $ssl1, $ssl2, 446 $authuser1, $authuser2, 447 $authmech1, $authmech2, 448 $split1, $split2, 449 $tests, $test_builder, 450); 451 452use vars qw ($opt_G); # missing code for this will be option. 453 454 455$rcs = ' $Id: imapsync,v 1.241 2007/12/31 13:39:02 gilles Exp gilles $ '; 456$rcs =~ m/,v (\d+\.\d+)/; 457$VERSION = ($1) ? $1 : "UNKNOWN"; 458 459my $VERSION_IMAPClient = $Mail::IMAPClient::VERSION; 460 461check_lib_version() or 462 die "imapsync needs perl lib Mail::IMAPClient release 2.2.9 exactly, future imapsync release may suppoort 3.0.x, but sorry not now\n"; 463 464 465$mess_size_total_trans = 0; 466$mess_size_total_skipped = 0; 467$mess_size_total_error = 0; 468$mess_trans = $mess_skipped = $mess_skipped_dry = 0; 469 470 471sub check_lib_version { 472 if ($VERSION_IMAPClient =~ m/(\d+)\.(\d+)\.(\d+)/) { 473 $debug and print "VERSION_IMAPClient $1 $2 $3\n"; 474 #my($major,$minor,$sub) = ($1, $2, $3); 475 476 return(1) if($VERSION_IMAPClient eq '2.2.9'); 477 478 } 479 else{ 480 return 0; # don't match regex => bad 481 } 482} 483 484$error=0; 485 486my $banner = join("", 487 '$RCSfile: imapsync,v $ ', 488 '$Revision: 1.241 $ ', 489 '$Date: 2007/12/31 13:39:02 $ ', 490 "\n",localhost_info(), 491 " and the module Mail::IMAPClient version used here is ", 492 $VERSION_IMAPClient,"\n", 493 "Command line used :\n", 494 "$0 @ARGV\n", 495 ); 496 497unless(defined(&_SYSEXITS_H)) { 498 # 64 on my linux box. 499 eval 'sub EX_USAGE () {64;}' unless defined(&EX_USAGE); 500} 501 502get_options(); 503print $banner; 504 505sub missing_option { 506 my ($option) = @_; 507 die "$option option must be used, run $0 --help for help\n"; 508} 509 510# By default, 1000 at a time, not more. 511$split1 ||= 1000; 512$split2 ||= 1000; 513 514$host1 || missing_option("--host1") ; 515# $port1 = (defined($port1)) ? $port1 : 143; 516$port1 ||= defined $ssl1 ? 993 : 143; 517 518$host2 || missing_option("--host2") ; 519# $port2 = (defined($port2)) ? $port2 : 143; 520$port2 ||= defined $ssl2 ? 993 : 143; 521 522sub connect_imap { 523 my($host, $port, $debugimap) = @_; 524 my $imap = Mail::IMAPClient->new(); 525 $imap->Server($host); 526 $imap->Port($port); 527 $imap->Debug($debugimap); 528 $imap->connect2() 529 or die "Can not open imap connection on [$host] : $@\n"; 530} 531 532sub localhost_info { 533 534 my($infos) = join("", 535 "Here is a [$OSNAME] system (", 536 join(" ", 537 uname(), 538 ), 539 ")\n", 540 "with perl ", 541 sprintf("%vd", $PERL_VERSION)); 542 return($infos); 543 544} 545 546if ($justconnect) { 547 my $from = (); 548 my $to = (); 549 550 $from = connect_imap($host1, $port1); 551 print "From software : ", server_banner($from); 552 print "From capability : ", join(" ", $from->capability()), "\n"; 553 $to = connect_imap($host2, $port2); 554 print "To software : ", server_banner($to); 555 print "To capability : ", join(" ", $to->capability()), "\n"; 556 $from->logout(); 557 $to->logout(); 558 exit(0); 559} 560 561$user1 || missing_option("--user1"); 562$user2 || missing_option("--user2"); 563 564if(defined($authmd5) and not($authmd5)) { 565 $authmech1 ||= 'LOGIN'; 566 $authmech2 ||= 'LOGIN'; 567} 568else{ 569 $authmech1 ||= $authuser1 ? 'PLAIN' : 'CRAM-MD5'; 570 $authmech2 ||= $authuser2 ? 'PLAIN' : 'CRAM-MD5'; 571} 572 573$authmech1 = uc($authmech1); 574$authmech2 = uc($authmech2); 575 576$authuser1 ||= $user1; 577$authuser2 ||= $user2; 578 579print "will try to use $authmech1 authentication on host1\n"; 580print "will try to use $authmech2 authentication on host2\n"; 581 582$syncacls = (defined($syncacls)) ? $syncacls : 0; 583$foldersizes = (defined($foldersizes)) ? $foldersizes : 1; 584 585$fastio1 = (defined($fastio1)) ? $fastio1 : 0; 586$fastio2 = (defined($fastio2)) ? $fastio2 : 0; 587 588 589@useheader = ("ALL") unless (@useheader); 590 591print "From imap server [$host1] port [$port1] user [$user1]\n"; 592print "To imap server [$host2] port [$port2] user [$user2]\n"; 593 594 595sub ask_for_password { 596 require Term::ReadKey; 597 my ($user, $host) = @_; 598 print "What's the password for $user\@$host? "; 599 Term::ReadKey::ReadMode(2); 600 my $password = <>; 601 chomp $password; 602 printf "\n"; 603 Term::ReadKey::ReadMode(0); 604 return $password; 605} 606 607 608$password1 || $passfile1 || do { 609 $password1 = ask_for_password($authuser1 || $user1, $host1); 610}; 611 612$password1 = (defined($passfile1)) ? firstline ($passfile1) : $password1; 613 614$password2 || $passfile2 || do { 615 $password2 = ask_for_password($authuser2 || $user2, $host2); 616}; 617 618$password2 = (defined($passfile2)) ? firstline ($passfile2) : $password2; 619 620my $from = (); 621my $to = (); 622 623$timestart = time(); 624$timebefore = $timestart; 625 626$debugimap and print "From connection\n"; 627$from = login_imap($host1, $port1, $user1, $password1, 628 $debugimap, $timeout, $fastio1, $ssl1, 629 $authmech1, $authuser1); 630 631$debugimap and print "To connection\n"; 632$to = login_imap($host2, $port2, $user2, $password2, 633 $debugimap, $timeout, $fastio2, $ssl2, 634 $authmech2, $authuser2); 635 636# history 637 638$debug and print "From Buffer I/O : ", $from->Buffer(), "\n"; 639$debug and print "To Buffer I/O : ", $to->Buffer(), "\n"; 640 641 642sub login_imap { 643 my($host, $port, $user, $password, 644 $debugimap, $timeout, $fastio, 645 $ssl, $authmech, $authuser) = @_; 646 my ($imap); 647 if ($ssl) { 648 require IO::Socket::SSL; 649 my $socssl = new IO::Socket::SSL("$host:$port"); 650 die "Error connecting to $host:$port: $@\n" unless $socssl; 651 $socssl->autoflush(1); 652 653 $imap = Mail::IMAPClient->new( 654 Socket => $socssl, 655 Server => $host, 656 ); 657 } 658 else { 659 $imap = Mail::IMAPClient->new(); 660 } 661 $imap->Clear(20); 662 $imap->Server($host); 663 $imap->Port($port); 664 $imap->Fast_io($fastio); 665 $imap->Buffer($buffersize || 4096); 666 $imap->Uid(1); 667 $imap->Peek(1); 668 $imap->Debug($debugimap); 669 $timeout and $imap->Timeout($timeout); 670 671 if ($ssl) { 672 $imap->State(Mail::IMAPClient::Connected); 673 } 674 else { 675 $imap->connect2() 676 or die "Can not open imap connection on [$host] with user [$user] : $@\n"; 677 } 678 print "Banner : ", server_banner($imap); 679 680 if ($imap->has_capability("AUTH=$authmech") 681 or $imap->has_capability($authmech) 682 ) { 683 printf("Host %s says it has CAPABILITY for AUTHENTICATE %s\n", 684 $imap->Server, $authmech); 685 } 686 else { 687 printf("Host %s says it has NO CAPABILITY for AUTHENTICATE %s\n", 688 $imap->Server, $authmech); 689 if ($authmech eq 'PLAIN') { 690 print "Frequently PLAIN is only supported with SSL, ", 691 "try --ssl1 or --ssl2 option\n"; 692 } 693 } 694 695 $imap->Authmechanism($authmech) unless ($authmech eq 'LOGIN'); 696 $imap->Authcallback(\&plainauth) if $authmech eq "PLAIN"; 697 698 $imap->User($user); 699 $imap->Authuser($authuser); 700 $imap->Password($password); 701 $is_yahoo = 0; 702 $is_yahoo = index($host,"yahoo"); 703 # Allow Login to Yahoo www.bwebcentral.com 704 705 706 unless ($imap->login2()) { 707 print "Error login : [$host] with user [$user] auth [$authmech]: $@\n"; 708 die if ($authmech eq 'LOGIN'); 709 die if $imap->IsUnconnected(); 710 print "Trying LOGIN Auth mechanism on [$host] with user [$user]\n"; 711 $imap->Authmechanism(""); 712 $imap->login2() or 713 die "Error login : [$host] with user [$user] auth [LOGIN] : $@"; 714 } 715 print "Success login on [$host] with user [$user] auth [$authmech]\n"; 716 return($imap); 717} 718 719sub plainauth() { 720 my $code = shift; 721 my $imap = shift; 722 723 my $string = sprintf("%s\x00%s\x00%s", $imap->User, 724 $imap->Authuser, $imap->Password); 725 return encode_base64("$string", ""); 726} 727 728 729sub server_banner { 730 my $imap = shift; 731 for my $line ($imap->Results()) { 732 #print "LR: $line"; 733 return $line if $line =~ /^\* (OK|NO|BAD)/; 734 } 735 return "No banner\n"; 736 } 737 738 739 740print "From capability : ", join(" ", $from->capability()), "\n"; 741print "To capability : ", join(" ", $to->capability()), "\n"; 742 743die unless $from->IsAuthenticated(); 744print "From state Authenticated\n"; 745die unless $to->IsAuthenticated(); 746print "To state Authenticated\n"; 747 748$split1 and $from->Split($split1); 749$split2 and $to->Split($split2); 750 751# 752# Folder stuff 753# 754 755my (@f_folders, %requested_folder, @t_folders, %subscribed_folder, %t_folders); 756 757sub tests_folder_routines { 758 ok( !give_requested_folders() ,"no requested folders" ); 759 ok( !is_requested_folder('folder_foo') ); 760 ok( add_to_requested_folders('folder_foo') ); 761 ok( is_requested_folder('folder_foo') ); 762 ok( !is_requested_folder('folder_NO_EXIST') ); 763 ok( !remove_from_requested_folders('folder_foo'), "removed folder_foo"); 764 ok( !is_requested_folder('folder_foo') ); 765 my @f; 766 ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f"); 767 ok( is_requested_folder('folder_bar') ); 768 ok( is_requested_folder('folder_toto') ); 769 ok( remove_from_requested_folders('folder_toto') ); 770 ok( !is_requested_folder('folder_toto') ); 771 ok( init_requested_folders() , 'empty requested folders'); 772 ok( !give_requested_folders() , 'no requested folders' ); 773} 774 775sub give_requested_folders { 776 return(keys(%requested_folder)); 777} 778 779sub init_requested_folders { 780 781 %requested_folder = (); 782 return(1); 783 784} 785 786sub is_requested_folder { 787 my ( $folder ) = @_; 788 789 defined( $requested_folder{ $folder } ); 790} 791 792 793sub add_to_requested_folders { 794 my @wanted_folders = @_; 795 796 foreach my $folder ( @wanted_folders ) { 797 ++$requested_folder{ $folder }; 798 } 799 return( keys( %requested_folder ) ); 800} 801 802sub remove_from_requested_folders { 803 my @wanted_folders = @_; 804 805 foreach my $folder (@wanted_folders) { 806 delete $requested_folder{$folder}; 807 } 808 return( keys(%requested_folder) ); 809} 810 811 812# Make a hash of subscribed folders in source server. 813map { $subscribed_folder{$_} = 1 } $from->subscribed(); 814 815 816my @all_source_folders = sort $from->folders(); 817 818if (scalar(@folder) or $subscribed or scalar(@folderrec)) { 819 # folders given by option --folder 820 if (scalar(@folder)) { 821 add_to_requested_folders(@folder); 822 } 823 824 # option --subscribed 825 if ($subscribed) { 826 add_to_requested_folders(keys (%subscribed_folder)); 827 } 828 829 # option --folderrec 830 if (scalar(@folderrec)) { 831 foreach my $folderrec (@folderrec) { 832 add_to_requested_folders($from->folders($folderrec)); 833 } 834 } 835} 836else { 837 838 # no include, no folder/subscribed/folderrec options => all folders 839 if (not scalar(@include)) { 840 add_to_requested_folders(@all_source_folders); 841 } 842} 843 844 845# consider (optional) includes and excludes 846if (scalar(@include)) { 847 foreach my $include (@include) { 848 my @included_folders = grep /$include/, @all_source_folders; 849 add_to_requested_folders(@included_folders); 850 print "Including folders matching pattern '$include': @included_folders\n"; 851 } 852} 853 854if (scalar(@exclude)) { 855 foreach my $exclude (@exclude) { 856 my @requested_folder = sort(keys(%requested_folder)); 857 my @excluded_folders = grep /$exclude/, @requested_folder; 858 remove_from_requested_folders(@excluded_folders); 859 print "Excluding folders matching pattern '$exclude': @excluded_folders\n"; 860 } 861} 862 863 864my @requested_folder = sort(keys(%requested_folder)); 865 866@f_folders = @requested_folder; 867 868sub compare_lists { 869 my ($list_1_ref, $list_2_ref) = @_; 870 871 return(-1) if ((not defined($list_1_ref)) and defined($list_2_ref)); 872 return(0) if (! $list_1_ref); # end if no list 873 return(1) if (! $list_2_ref); # end if only one list 874 875 if (not ref($list_1_ref)) {$list_1_ref = [$list_1_ref]}; 876 if (not ref($list_2_ref)) {$list_2_ref = [$list_2_ref]}; 877 878 879 my $last_used_indice = 0; 880 ELEMENT: 881 foreach my $indice ( 0 .. $#$list_1_ref ) { 882 $last_used_indice = $indice; 883 884 # End of list_2 885 return 1 if ($indice > $#$list_2_ref); 886 887 my $element_list_1 = $list_1_ref->[$indice]; 888 my $element_list_2 = $list_2_ref->[$indice]; 889 my $balance = $element_list_1 cmp $element_list_2 ; 890 next ELEMENT if ($balance == 0) ; 891 return $balance; 892 } 893 # each element equal until last indice of list_1 894 return -1 if ($last_used_indice < $#$list_2_ref); 895 896 # same size, each element equal 897 return 0 898} 899 900sub tests_compare_lists { 901 902 903 my $empty_list_ref = []; 904 905 ok( 0 == compare_lists() , 'compare_lists, no args'); 906 ok( 0 == compare_lists(undef) , 'compare_lists, undef = nothing'); 907 ok( 0 == compare_lists(undef, undef) , 'compare_lists, undef = undef'); 908 ok(-1 == compare_lists(undef , []) , 'compare_lists, undef < []'); 909 ok(+1 == compare_lists([]) , 'compare_lists, [] > nothing'); 910 ok(+1 == compare_lists([], undef) , 'compare_lists, [] > undef'); 911 ok( 0 == compare_lists([] , []) , 'compare_lists, [] = []'); 912 913 ok( 0 == compare_lists([1], 1 ) , "compare_lists, [1] = 1 ") ; 914 ok( 0 == compare_lists( 1 , [1]) , "compare_lists, 1 = [1]") ; 915 ok( 0 == compare_lists( 1 , 1 ) , "compare_lists, 1 = 1 ") ; 916 ok(-1 == compare_lists( 1 , 2 ) , "compare_lists, 1 = 1 ") ; 917 ok(+1 == compare_lists( 2 , 1 ) , "compare_lists, 1 = 1 ") ; 918 919 920 ok( 0 == compare_lists([1,2], [1,2]) , "compare_lists, [1,2] = [1,2]") ; 921 ok(-1 == compare_lists([1], [1,2]) , "compare_lists, [1] < [1,2]") ; 922 ok(-1 == compare_lists([1], [1,1]) , "compare_lists, [1] < [1,1]") ; 923 ok(+1 == compare_lists([1, 1], [1]) , "compare_lists, [1, 1] > [1]") ; 924 ok( 0 == compare_lists([1 .. 20_000] , [1 .. 20_000]) 925 , "compare_lists, [1..20_000] = [1..20_000]") ; 926 ok(-1 == compare_lists([1], [3]) , 'compare_lists, [1] < [3]') ; 927 ok( 0 == compare_lists([2], [2]) , 'compare_lists, [0] = [2]') ; 928 ok(+1 == compare_lists([3], [1]) , 'compare_lists, [3] > [1]') ; 929 930 ok(-1 == compare_lists(["a"], ["b"]) , 'compare_lists, ["a"] < ["b"]') ; 931 ok( 0 == compare_lists(["a"], ["a"]) , 'compare_lists, ["a"] = ["a"]') ; 932 ok( 0 == compare_lists(["ab"], ["ab"]) , 'compare_lists, ["ab"] = ["ab"]') ; 933 ok(+1 == compare_lists(["b"], ["a"]) , 'compare_lists, ["b"] > ["a"]') ; 934 ok(-1 == compare_lists(["a"], ["aa"]) , 'compare_lists, ["a"] < ["aa"]') ; 935 ok(-1 == compare_lists(["a"], ["a", "a"]), 'compare_lists, ["a"] < ["a", "a"]') ; 936} 937 938 939@t_folders = sort @{$to->folders()}; 940 941my($f_sep,$t_sep); 942# what are the private folders separators for each server ? 943 944 945$debug and print "Getting separators\n"; 946$f_sep = get_separator($from, $sep1, "--sep1"); 947$t_sep = get_separator($to, $sep2, "--sep2"); 948 949#my $f_namespace = $from->namespace(); 950#my $t_namespace = $to->namespace(); 951#$debug and print "From namespace:\n", Data::Dumper->Dump([$f_namespace]); 952#$debug and print "To namespace:\n", Data::Dumper->Dump([$t_namespace]); 953 954my($f_prefix,$t_prefix); 955$f_prefix = get_prefix($from, $prefix1, "--prefix1"); 956$t_prefix = get_prefix($to, $prefix2, "--prefix2"); 957 958sub get_prefix { 959 my($imap, $prefix_in, $prefix_opt) = @_; 960 my($prefix_out); 961 962 $debug and print "Getting prefix namespace\n"; 963 if (defined($prefix_in)) { 964 print "Using [$prefix_in] given by $prefix_opt\n"; 965 $prefix_out = $prefix_in; 966 return($prefix_out); 967 } 968 $debug and print "Calling namespace capability\n"; 969 if ($imap->has_capability("namespace")) { 970 my $r_namespace = $imap->namespace(); 971 $prefix_out = $r_namespace->[0][0][0]; 972 return($prefix_out); 973 } 974 else{ 975 print 976 "No NAMESPACE capability in imap server ", 977 $imap->Server(),"\n", 978 "Give the prefix namespace with the $prefix_opt option\n"; 979 exit(1); 980 } 981} 982 983 984sub get_separator { 985 my($imap, $sep_in, $sep_opt) = @_; 986 my($sep_out); 987 988 989 if ($sep_in) { 990 print "Using [$sep_in] given by $sep_opt\n"; 991 $sep_out = $sep_in; 992 return($sep_out); 993 } 994 $debug and print "Calling namespace capability\n"; 995 if ($imap->has_capability("namespace")) { 996 $sep_out = $imap->separator(); 997 return($sep_out); 998 } 999 else{ 1000 print 1001 "No NAMESPACE capability in imap server ", 1002 $imap->Server(),"\n", 1003 "Give the separator caracter with the $sep_opt option\n"; 1004 exit(1); 1005 } 1006} 1007 1008 1009print "From separator and prefix : [$f_sep][$f_prefix]\n"; 1010print "To separator and prefix : [$t_sep][$t_prefix]\n"; 1011 1012 1013sub foldersizes { 1014 1015 my ($side, $imap, $folders_r) = @_; 1016 my $tot = 0; 1017 my $tmess = 0; 1018 my @folders = @{$folders_r}; 1019 print "++++ Calculating sizes ++++\n"; 1020 foreach my $folder (@folders) { 1021 my $stot = 0; 1022 my $smess = 0; 1023 printf("$side Folder %-35s", "[$folder]"); 1024 unless($imap->exists($folder)) { 1025 print("does not exist yet\n"); 1026 next; 1027 } 1028 unless ($imap->select($folder)) { 1029 warn 1030 "$side Folder $folder : Could not select ", 1031 $imap->LastError, "\n"; 1032 $error++; 1033 next; 1034 } 1035 if (defined($maxage) or defined($minage)) { 1036 # The pb is fetch_hash() can only be applied on ALL messages 1037 my @msgs = select_msgs($imap); 1038 $smess = scalar(@msgs); 1039 foreach my $m (@msgs) { 1040 my $s = $imap->size($m) 1041 or warn "Could not find size of message $m: $@\n"; 1042 $stot += $s; 1043 } 1044 } 1045 else{ 1046 my $hashref = {}; 1047 $smess = $imap->message_count(); 1048 unless ($smess == 0) { 1049 #$imap->Ranges(1); 1050 $imap->fetch_hash2("RFC822.SIZE",$hashref) or die "$@"; 1051 #$imap->Ranges(0); 1052 #print map {$hashref->{$_}->{"RFC822.SIZE"}, " "} keys %$hashref; 1053 map {$stot += $hashref->{$_}->{"RFC822.SIZE"}} keys %$hashref; 1054 } 1055 } 1056 printf(" Size: %9s", $stot); 1057 printf(" Messages: %5s\n", $smess); 1058 $tot += $stot; 1059 $tmess += $smess; 1060 } 1061 print "Total size: $tot\n"; 1062 print "Total messages: $tmess\n"; 1063 print "Time : ", timenext(), " s\n"; 1064} 1065 1066 1067foreach my $f_fold (@f_folders) { 1068 my $t_fold; 1069 $t_fold = to_folder_name($f_fold); 1070 $t_folders{$t_fold}++; 1071} 1072 1073@t_folders = sort keys(%t_folders); 1074 1075 1076if ($foldersizes) { 1077 foldersizes("From", $from, \@f_folders); 1078 foldersizes("To ", $to, \@t_folders); 1079} 1080 1081 1082 1083 1084sub timenext { 1085 my ($timenow, $timerel); 1086 # $timebefore is global, beurk ! 1087 $timenow = time; 1088 $timerel = $timenow - $timebefore; 1089 $timebefore = $timenow; 1090 return($timerel); 1091} 1092 1093exit if ($justfoldersizes); 1094 1095# needed for setting flags 1096my $tohasuidplus = $to->has_capability("UIDPLUS"); 1097 1098 1099 1100print 1101 "++++ Listing folders ++++\n", 1102 "From folders list : ", map("[$_] ",@f_folders),"\n", 1103 "To folders list : ", map("[$_] ",@t_folders),"\n"; 1104 1105print 1106 "From subscribed folders list : ", 1107 map("[$_] ", sort keys(%subscribed_folder)), "\n" 1108 if ($subscribed); 1109 1110sub separator_invert { 1111 # The separator we hope we'll never encounter 1112 my $o_sep="\000"; 1113 1114 my($f_fold, $f_sep, $t_sep) = @_; 1115 1116 my $t_fold = $f_fold; 1117 $t_fold =~ s@\Q$t_sep@$o_sep@g; 1118 $t_fold =~ s@\Q$f_sep@$t_sep@g; 1119 $t_fold =~ s@\Q$o_sep@$f_sep@g; 1120 return($t_fold); 1121} 1122 1123sub to_folder_name { 1124 my ($t_fold); 1125 my ($x_fold) = @_; 1126 # first we remove the prefix 1127 $x_fold =~ s/^$f_prefix//; 1128 $debug and print "removed source prefix : [$x_fold]\n"; 1129 $t_fold = separator_invert($x_fold,$f_sep, $t_sep); 1130 $debug and print "inverted separators : [$t_fold]\n"; 1131 # Adding the prefix supplied by namespace or the --prefix2 option 1132 $t_fold = $t_prefix . $t_fold 1133 unless(($t_prefix eq "INBOX.") and ($t_fold =~ m/^INBOX$/i)); 1134 $debug and print "added target prefix : [$t_fold]\n"; 1135 1136 # Transforming the folder name by the --regextrans2 option(s) 1137 foreach my $regextrans2 (@regextrans2) { 1138 $debug and print "eval \$t_fold =~ $regextrans2\n"; 1139 eval("\$t_fold =~ $regextrans2"); 1140 } 1141 return($t_fold); 1142} 1143 1144sub flags_regex { 1145 my ($flags_f) = @_; 1146 foreach my $regexflag (@regexflag) { 1147 $debug and print "eval \$flags_f =~ $regexflag\n"; 1148 eval("\$flags_f =~ $regexflag"); 1149 } 1150 return($flags_f); 1151} 1152 1153sub acls_sync { 1154 my($f_fold, $t_fold) = @_; 1155 if ($syncacls) { 1156 my $f_hash = $from->getacl($f_fold) 1157 or warn "Could not getacl for $f_fold: $@\n"; 1158 my $t_hash = $to->getacl($t_fold) 1159 or warn "Could not getacl for $t_fold: $@\n"; 1160 my %users = map({ ($_, 1) } (keys(%$f_hash), keys(%$t_hash))); 1161 foreach my $user (sort(keys(%users))) { 1162 my $acl = $f_hash->{$user} || "none"; 1163 print "acl $user : [$acl]\n"; 1164 next if ($f_hash->{$user} && $t_hash->{$user} && 1165 $f_hash->{$user} eq $t_hash->{$user}); 1166 unless ($dry) { 1167 print "setting acl $t_fold $user $acl\n"; 1168 $to->setacl($t_fold, $user, $acl) 1169 or warn "Could not set acl: $@\n"; 1170 } 1171 } 1172 } 1173} 1174 1175 1176print "++++ Looping on each folder ++++\n"; 1177 1178FOLDER: foreach my $f_fold (@f_folders) { 1179 my $t_fold; 1180 print "From Folder [$f_fold]\n"; 1181 $t_fold = to_folder_name($f_fold); 1182 print "To Folder [$t_fold]\n"; 1183 1184 last FOLDER if $from->IsUnconnected(); 1185 last FOLDER if $to->IsUnconnected(); 1186 1187 unless ($from->select($f_fold)) { 1188 warn 1189 "From Folder $f_fold : Could not select ", 1190 $from->LastError, "\n"; 1191 $error++; 1192 next FOLDER; 1193 } 1194 1195 unless ($to->exists($t_fold) or $to->select($t_fold)) { 1196 print "To Folder $t_fold does not exist\n"; 1197 print "Creating folder [$t_fold]\n"; 1198 unless ($dry){ 1199 unless ($to->create($t_fold)){ 1200 warn "Couldn't create [$t_fold]", 1201 $to->LastError,"\n"; 1202 $error++; 1203 next FOLDER; 1204 } 1205 } 1206 else{ 1207 next FOLDER; 1208 } 1209 } 1210 1211 acls_sync($f_fold, $t_fold); 1212 1213 unless ($to->select($t_fold)) { 1214 warn 1215 "To Folder $t_fold : Could not select ", 1216 $to->LastError, "\n"; 1217 $error++; 1218 next FOLDER; 1219 } 1220 1221 if ($expunge){ 1222 print "Expunging $f_fold and $t_fold\n"; 1223 unless($dry) { $from->expunge() }; 1224 #unless($dry) { $to->expunge() }; 1225 } 1226 1227 if ($subscribe and exists $subscribed_folder{$f_fold}) { 1228 print "Subscribing to folder $t_fold on destination server\n"; 1229 unless($dry) { $to->subscribe($t_fold) }; 1230 } 1231 1232 next FOLDER if ($justfolders); 1233 1234 last FOLDER if $from->IsUnconnected(); 1235 last FOLDER if $to->IsUnconnected(); 1236 1237 my @f_msgs = select_msgs($from); 1238 1239 1240 1241 $debug and print "LIST FROM : ", scalar(@f_msgs), " messages [@f_msgs]\n"; 1242 # internal dates on "TO" are after the ones on "FROM" 1243 # normally... 1244 my @t_msgs = select_msgs($to); 1245 1246 $debug and print "LIST TO : ", scalar(@t_msgs), " messages [@t_msgs]\n"; 1247 1248 my %f_hash = (); 1249 my %t_hash = (); 1250 1251 print "++++ From [$f_fold] Parse 1 ++++\n"; 1252 last FOLDER if $from->IsUnconnected(); 1253 last FOLDER if $to->IsUnconnected(); 1254 1255 my $f_heads = $from->parse_headers2([@f_msgs], 1256 @useheader)if (@f_msgs) ; 1257 $debug and print "Time headers: ", timenext(), " s\n"; 1258 my $f_fir = $from->fetch_hash2("FLAGS", 1259 "INTERNALDATE", 1260 "RFC822.SIZE") if (@f_msgs); 1261 $debug and print "Time fir : ", timenext(), " s\n"; 1262 1263 foreach my $m (@f_msgs) { 1264 parse_header_msg1($from, $m, $f_heads, $f_fir, "F", \%f_hash); 1265 } 1266 $debug and print "Time headers: ", timenext(), " s\n"; 1267 1268 print "++++ To [$t_fold] Parse 1 ++++\n"; 1269 last FOLDER if $from->IsUnconnected(); 1270 last FOLDER if $to->IsUnconnected(); 1271 1272 my $t_heads = $to->parse_headers2([@t_msgs], 1273 @useheader) if (@t_msgs); 1274 $debug and print "Time headers: ", timenext(), " s\n"; 1275 my $t_fir = $to->fetch_hash2("FLAGS", 1276 "INTERNALDATE", 1277 "RFC822.SIZE") if (@t_msgs); 1278 $debug and print "Time fir : ", timenext(), " s\n"; 1279 foreach my $m (@t_msgs) { 1280 parse_header_msg1($to, $m, $t_heads, $t_fir, "T", \%t_hash); 1281 } 1282 $debug and print "Time headers: ", timenext(), " s\n"; 1283 1284 print "++++ Verifying [$f_fold] -> [$t_fold] ++++\n"; 1285 # messages in "from" that are not good in "to" 1286 1287 my @f_hash_keys_sorted_by_uid 1288 = sort {$f_hash{$a}{'m'} <=> $f_hash{$b}{'m'}} keys(%f_hash); 1289 1290 #print map { $f_hash{$_}{'m'} . " "} @f_hash_keys_sorted_by_uid; 1291 1292 my @t_hash_keys_sorted_by_uid 1293 = sort {$t_hash{$a}{'m'} <=> $t_hash{$b}{'m'}} keys(%t_hash); 1294 1295 1296 if($delete2) { 1297 foreach my $m_id (@t_hash_keys_sorted_by_uid) { 1298 #print "$m_id "; 1299 unless (exists($f_hash{$m_id})) { 1300 my $t_msg = $t_hash{$m_id}{'m'}; 1301 print "deleting message $m_id $t_msg\n"; 1302 $to->delete_message($t_msg) unless ($dry); 1303 } 1304 } 1305 } 1306 1307 MESS: foreach my $m_id (@f_hash_keys_sorted_by_uid) { 1308 my $f_size = $f_hash{$m_id}{'s'}; 1309 my $f_msg = $f_hash{$m_id}{'m'}; 1310 my $f_idate = $f_hash{$m_id}{'D'}; 1311 1312 if (defined $maxsize and $f_size > $maxsize) { 1313 print "+ Skipping msg #$f_msg:$f_size in folder $f_fold (exceeds maxsize limit $maxsize bytes)\n"; 1314 $mess_size_total_skipped += $f_size; 1315 $mess_skipped += 1; 1316 next MESS; 1317 } 1318 $debug and print "+ key $m_id #$f_msg\n"; 1319 unless (exists($t_hash{$m_id})) { 1320 print "+ NO msg #$f_msg [$m_id] in $t_fold\n"; 1321 # copy 1322 print "+ Copying msg #$f_msg:$f_size to folder $t_fold\n"; 1323 last FOLDER if $from->IsUnconnected(); 1324 #my $string = $from->message_string($f_msg); 1325 my $message_file = "tmp_imapsync_$$"; 1326 unlink($message_file); 1327 $from->message_to_file($message_file, $f_msg); 1328 my $string = file_to_string($message_file); 1329 #unlink($message_file); 1330 if (@regexmess) { 1331 foreach my $regexmess (@regexmess) { 1332 $debug and print "eval \$string =~ $regexmess\n"; 1333 eval("\$string =~ $regexmess"); 1334 } 1335 string_to_file($string, $message_file); 1336 } 1337 $debug and print "F message content begin next line\n", 1338 $string, 1339 "F message content ended on previous line\n"; 1340 my $d = ""; 1341 if ($syncinternaldates) { 1342 $d = $f_idate; 1343 $debug and print "internal date from 1: [$d]\n"; 1344 require Date::Manip; 1345 Date::Manip->import(qw(ParseDate Date_Cmp UnixDate)); 1346 $d = UnixDate(ParseDate($d), "%d-%b-%Y %H:%M:%S %z"); 1347 $d = "\"$d\""; 1348 $debug and print "internal date from 1: [$d] (fixed)\n"; 1349 } 1350 1351 my $flags_f = $f_hash{$m_id}{'F'} || ""; 1352 # RFC 2060 : This flag can not be altered by any client 1353 $flags_f =~ s@\\Recent@@gi; 1354 $flags_f = flags_regex($flags_f) if @regexflag; 1355 1356 my $new_id; 1357 print "flags from : [$flags_f][$d]\n"; 1358 last FOLDER if $to->IsUnconnected(); 1359 unless ($dry) { 1360 1361 if ($OSNAME eq "MSWin32") { 1362 $new_id = $to->append_string($t_fold,$string, $flags_f, $d); 1363 } 1364 else { 1365 $new_id = $to->append_file2($t_fold, $message_file, "", $flags_f, $d); 1366 } 1367 unless($new_id){ 1368 warn "Couldn't append msg #$f_msg (Subject:[". 1369 $from->subject($f_msg)."]) to folder $t_fold: ", 1370 $to->LastError, "\n"; 1371 $error++; 1372 $mess_size_total_error += $f_size; 1373 next MESS; 1374 } 1375 else{ 1376 # good 1377 # $new_id is an id if the IMAP server has the 1378 # UIDPLUS capability else just a ref 1379 print "Copied msg id [$f_msg] to folder $t_fold msg id [$new_id]\n"; 1380 $mess_size_total_trans += $f_size; 1381 $mess_trans += 1; 1382 if($delete) { 1383 print "Deleting msg #$f_msg in folder $f_fold\n"; 1384 $from->delete_message($f_msg) unless ($dry); 1385 $from->expunge() if ($expunge and not $dry); 1386 } 1387 } 1388 } 1389 else{ 1390 $mess_skipped_dry += 1; 1391 } 1392 unlink($message_file); 1393 next MESS; 1394 } 1395 else{ 1396 $debug and print "Message id [$m_id] found in t:$t_fold\n"; 1397 $mess_size_total_skipped += $f_size; 1398 $mess_skipped += 1; 1399 } 1400 1401 $fast and next MESS; 1402 #$debug and print "MESSAGE $m_id\n"; 1403 my $t_size = $t_hash{$m_id}{'s'}; 1404 my $t_msg = $t_hash{$m_id}{'m'}; 1405 1406 1407 $debug and print "Setting flags\n"; 1408 last FOLDER if $from->IsUnconnected(); 1409 last FOLDER if $to->IsUnconnected(); 1410 1411 my (@flags_f,@flags_t); 1412 my $flags_f_rv = $from->flags($f_msg); 1413 @flags_f = @{$flags_f_rv} if ref($flags_f_rv); 1414 1415 # No flag \Recent here, no ? 1416 my $flags_f = join(" ", @flags_f); 1417 1418 $flags_f = flags_regex($flags_f) if @regexflag; 1419 1420 # This add or change flags but no flag are removed with this 1421 $to->store($t_msg, 1422 "+FLAGS (" . $flags_f . ")" 1423 ) unless ($dry) ; 1424 1425 my $flags_t_rv = $to->flags($t_msg); 1426 @flags_t = @{$flags_t_rv} if ref($flags_t_rv); 1427 my $flags_t = join(" ", @flags_t); 1428 $debug and print 1429 "flags from : $flags_f\n", 1430 "flags to : $flags_t\n"; 1431 1432 1433 $debug and do { 1434 print "Looking dates\n"; 1435 #my $d_f = $from->internaldate($f_msg); 1436 #my $d_t = $to->internaldate($t_msg); 1437 my $d_f = $f_hash{$m_id}{'D'}; 1438 my $d_t = $t_hash{$m_id}{'D'}; 1439 print 1440 "idate from : $d_f\n", 1441 "idate to : $d_t\n"; 1442 1443 #unless ($d_f eq $d_t) { 1444 # print "!!! Dates differ !!!\n"; 1445 #} 1446 }; 1447 unless (($f_size == $t_size) or $skipsize) { 1448 # Bad size 1449 print 1450 "Message $m_id SZ_BAD f:$f_msg:$f_size t:$t_msg:$t_size\n"; 1451 # delete in to and recopy ? 1452 # NO recopy CODE HERE. to be written if needed. 1453 $error++; 1454 if ($opt_G){ 1455 print "Deleting msg f:#$t_msg in folder $t_fold\n"; 1456 $to->delete_message($t_msg) unless ($dry); 1457 } 1458 } 1459 else { 1460 # Good 1461 $debug and print 1462 "Message $m_id SZ_GOOD f:$f_msg:$f_size t:$t_msg:$t_size\n"; 1463 if($delete) { 1464 print "Deleting msg #$f_msg in folder $f_fold\n"; 1465 $from->delete_message($f_msg) unless ($dry); 1466 $from->expunge() if ($expunge and not $dry); 1467 } 1468 } 1469 } 1470 if ($expunge1){ 1471 print "Expunging source folder $f_fold\n"; 1472 unless($dry) { $from->expunge() }; 1473 } 1474 if ($expunge2){ 1475 print "Expunging target folder $t_fold\n"; 1476 unless($dry) { $to->expunge() }; 1477 } 1478 1479print "Time : ", timenext(), " s\n"; 1480} 1481$from->logout(); 1482$to->logout(); 1483 1484$timeend = time(); 1485 1486$timediff = $timeend - $timestart; 1487 1488stats(); 1489 1490 1491 1492 1493exit(1) if($error); 1494 1495sub select_msgs { 1496 my ($imap) = @_; 1497 my (@msgs,@max,@min,@union,@inter); 1498 1499 unless (defined($maxage) or defined($minage)) { 1500 @msgs = $imap->search("ALL"); 1501 return(@msgs); 1502 } 1503 if (defined($maxage)) { 1504 @max = $imap->sentsince(time - 86400 * $maxage); 1505 } 1506 if (defined($minage)) { 1507 @min = $imap->sentbefore(time - 86400 * $minage); 1508 } 1509 SWITCH: { 1510 unless(defined($minage)) {@msgs = @max; last SWITCH}; 1511 unless(defined($maxage)) {@msgs = @min; last SWITCH}; 1512 my (%union, %inter); 1513 foreach my $m (@min, @max) {$union{$m}++ && $inter{$m}++} 1514 @inter = keys(%inter); 1515 @union = keys(%union); 1516 # normal case 1517 if ($minage <= $maxage) {@msgs = @inter; last SWITCH}; 1518 # just exclude messages between 1519 if ($minage > $maxage) {@msgs = @union; last SWITCH}; 1520 1521 } 1522 return(@msgs); 1523} 1524 1525sub stats { 1526 print "++++ Statistics ++++\n"; 1527 print "Time : $timediff sec\n"; 1528 print "Messages transferred : $mess_trans "; 1529 print "(could be $mess_skipped_dry without dry mode)" if ($dry); 1530 print "\n"; 1531 print "Messages skipped : $mess_skipped\n"; 1532 print "Total bytes transferred: $mess_size_total_trans\n"; 1533 print "Total bytes skipped : $mess_size_total_skipped\n"; 1534 print "Total bytes error : $mess_size_total_error\n"; 1535 print "Detected $error errors\n"; 1536 print "Please, rate imapsync at http://freshmeat.net/projects/imapsync/\n"; 1537 print "?Happy with this free, open source and gratis GPL software?\n", 1538 "Feel free to thank the author by giving him a book:\n", 1539 "http://www.amazon.com/gp/registry/wishlist/1C9UNDIH3P7R7/\n", 1540 "(or its paypal account gilles.lamiral\@laposte.net)\n"; 1541 1542 1543} 1544 1545 1546sub get_options 1547{ 1548 my $numopt = scalar(@ARGV); 1549 my $opt_ret = GetOptions( 1550 "debug!" => \$debug, 1551 "debugimap!" => \$debugimap, 1552 "host1=s" => \$host1, 1553 "host2=s" => \$host2, 1554 "port1=i" => \$port1, 1555 "port2=i" => \$port2, 1556 "user1=s" => \$user1, 1557 "user2=s" => \$user2, 1558 "password1=s" => \$password1, 1559 "password2=s" => \$password2, 1560 "passfile1=s" => \$passfile1, 1561 "passfile2=s" => \$passfile2, 1562 "authmd5!" => \$authmd5, 1563 "sep1=s" => \$sep1, 1564 "sep2=s" => \$sep2, 1565 "folder=s" => \@folder, 1566 "folderrec=s" => \@folderrec, 1567 "include=s" => \@include, 1568 "exclude=s" => \@exclude, 1569 "prefix1=s" => \$prefix1, 1570 "prefix2=s" => \$prefix2, 1571 "regextrans2=s" => \@regextrans2, 1572 "regexmess=s" => \@regexmess, 1573 "regexflag=s" => \@regexflag, 1574 "delete!" => \$delete, 1575 "delete2!" => \$delete2, 1576 "syncinternaldates!" => \$syncinternaldates, 1577 "syncacls!" => \$syncacls, 1578 "maxsize=i" => \$maxsize, 1579 "maxage=i" => \$maxage, 1580 "minage=i" => \$minage, 1581 "buffersize=i" => \$buffersize, 1582 "foldersizes!" => \$foldersizes, 1583 "dry!" => \$dry, 1584 "expunge!" => \$expunge, 1585 "expunge1!" => \$expunge1, 1586 "expunge2!" => \$expunge2, 1587 "subscribed!" => \$subscribed, 1588 "subscribe!" => \$subscribe, 1589 "justconnect!"=> \$justconnect, 1590 "justfolders!"=> \$justfolders, 1591 "justfoldersizes!" => \$justfoldersizes, 1592 "fast!" => \$fast, 1593 "version" => \$version, 1594 "help" => \$help, 1595 "timeout=i" => \$timeout, 1596 "skipheader=s" => \$skipheader, 1597 "useheader=s" => \@useheader, 1598 "skipsize!" => \$skipsize, 1599 "fastio1!" => \$fastio1, 1600 "fastio2!" => \$fastio2, 1601 "ssl1!" => \$ssl1, 1602 "ssl2!" => \$ssl2, 1603 "authmech1=s" => \$authmech1, 1604 "authmech2=s" => \$authmech2, 1605 "authuser1=s" => \$authuser1, 1606 "authuser2=s" => \$authuser2, 1607 "split1=i" => \$split1, 1608 "split2=i" => \$split2, 1609 "tests" => \$tests, 1610 ); 1611 1612 $debug and print "get options: [$opt_ret]\n"; 1613 1614 $test_builder = Test::More->builder; 1615 $test_builder->no_ending(1); 1616 1617 # just the version 1618 print "$VERSION\n" and exit if ($version) ; 1619 1620 if ($tests) { 1621 $test_builder->no_ending(0); 1622 tests(); 1623 exit; 1624 } 1625 1626 1627 # exit with --help option or no option at all 1628 usage() and exit if ($help or ! $numopt) ; 1629 1630 # don't go on if options are not all known. 1631 exit(EX_USAGE()) unless ($opt_ret) ; 1632 1633 1634} 1635 1636 1637sub parse_header_msg1 { 1638 my ($imap, $m_uid, $s_heads, $s_fir, $s, $s_hash) = @_; 1639 1640 my $head = $s_heads->{$m_uid}; 1641 my $headnum = scalar(keys(%$head)); 1642 $debug and print "Head NUM:", $headnum, "\n"; 1643 unless($headnum) { print "Warning : no header used or found \n"; } 1644 my $headstr; 1645 1646 foreach my $h (sort keys(%$head)){ 1647 foreach my $val (sort @{$head->{$h}}) { 1648 # no 8-bit data in headers ! 1649 $val =~ s/[\x80-\xff]/X/g; 1650 1651 # remove the first blanks (dbmail bug ?) 1652 # and uppercase header keywords 1653 # (dbmail and dovecot) 1654 $val =~ s/^\s*(.+)$/$1/; 1655 my $H = uc($h); 1656 # show stuff in debug mode 1657 $debug and print "${s}H $H:", $val, "\n"; 1658 if ($skipheader and $H =~ m/$skipheader/i) { 1659 $debug and print "Skipping header $h\n"; 1660 next; 1661 } 1662 $headstr .= "$H:". $val; 1663 } 1664 } 1665 #return unless ($headstr); 1666 unless ($headstr){ 1667 print "no header so taking everything\n"; 1668 $headstr = $imap->message_string($m_uid); 1669 } 1670 my $size = $s_fir->{$m_uid}->{"RFC822.SIZE"}; 1671 my $flags = $s_fir->{$m_uid}->{"FLAGS"}; 1672 my $idate = $s_fir->{$m_uid}->{"INTERNALDATE"}; 1673 $size = length($headstr) unless ($size); 1674 my $m_md5 = md5_base64($headstr); 1675 $debug and print "$s msg $m_uid:$m_md5:$size\n"; 1676 my $key; 1677 if ($skipsize) { 1678 $key = "$m_md5"; 1679 } 1680 else { 1681 $key = "$m_md5:$size"; 1682 } 1683 $s_hash->{"$key"}{'5'} = $m_md5; 1684 $s_hash->{"$key"}{'s'} = $size; 1685 $s_hash->{"$key"}{'D'} = $idate; 1686 $s_hash->{"$key"}{'F'} = $flags; 1687 $s_hash->{"$key"}{'m'} = $m_uid; 1688} 1689 1690 1691sub firstline { 1692 # extract the first line of a file (without \n) 1693 1694 my($file) = @_; 1695 my $line = ""; 1696 1697 open FILE, $file or die("error [$file]: $! "); 1698 chomp($line = <FILE>); 1699 close FILE; 1700 $line = ($line) ? $line : "error !EMPTY! [$file]"; 1701 return $line; 1702} 1703 1704 1705sub file_to_string { 1706 my($file) = @_; 1707 my @string; 1708 open FILE, $file or die("error [$file]: $! "); 1709 @string = <FILE>; 1710 close FILE; 1711 return join("", @string); 1712} 1713 1714 1715sub string_to_file { 1716 my($string, $file) = @_; 1717 sysopen(FILE, $file,O_WRONLY|O_TRUNC|O_CREAT, 0600) or die("$! $file"); 1718 print FILE $string; 1719 close FILE; 1720} 1721 1722 1723 1724sub usage { 1725 my $localhost_info = localhost_info(); 1726 print <<EOF; 1727 1728usage: $0 [options] 1729 1730Several options are mandatory. 1731 1732--host1 <string> : "from" imap server. Mandatory. 1733--port1 <int> : port to connect on host1. Default is 143. 1734--user1 <string> : user to login on host1. Mandatory. 1735--authuser1 <string> : user to auth with on host1 (admin user). 1736 Avoid using --authmech1 SOMETHING with --authuser1. 1737--password1 <string> : password for the user1. Dangerous, use --passfile1 1738--passfile1 <string> : password file for the user1. Contains the password. 1739--host2 <string> : "destination" imap server. Mandatory. 1740--port2 <int> : port to connect on host2. Default is 143. 1741--user2 <string> : user to login on host2. Mandatory. 1742--authuser2 <string> : user to auth with on host2 (admin user). 1743--password2 <string> : password for the user2. Dangerous, use --passfile2 1744--passfile2 <string> : password file for the user2. Contains the password. 1745--noauthmd5 : don't use MD5 authentification. 1746--authmech1 <string> : auth mechanism to use with host1: 1747 PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE. 1748--authmech2 <string> : auth mechanism to use with host2. See --authmech1 1749--ssl1 : use an SSL connection on host1. 1750--ssl2 : use an SSL connection on host2. 1751--folder <string> : sync this folder. 1752--folder <string> : and this one, etc. 1753--folderrec <string> : sync this folder recursively. 1754--folderrec <string> : and this one, etc. 1755--include <regex> : sync folders matching this regular expression 1756--include <regex> : or this one, etc. 1757 in case both --include --exclude options are 1758 use, include is done before. 1759--exclude <regex> : skips folders matching this regular expression 1760 Several folders to avoid: 1761 --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3. 1762--exclude <regex> : or this one, etc. 1763--prefix1 <string> : remove prefix to all destination folders 1764 (usually INBOX. for cyrus imap servers) 1765 you can use --prefix1 if your source imap server 1766 does not have NAMESPACE capability. 1767--prefix2 <string> : add prefix to all destination folders 1768 (usually INBOX. for cyrus imap servers) 1769 use --prefix2 if your target imap server does not 1770 have NAMESPACE capability. 1771--regextrans2 <regex> : Apply the whole regex to each destination folders. 1772--regextrans2 <regex> : and this one. etc. 1773 When you play with the --regextrans2 option, first 1774 add also the safe options --dry --justfolders 1775 Then, when happy, remove --dry, remove --justfolders 1776--regexmess <regex> : Apply the whole regex to each message before transfer. 1777 Example : 's/\\000/ /g' # to replace null by space. 1778--regexmess <regex> : and this one. 1779--regexmess <regex> : and this one, etc. 1780--regexflag <regex> : Apply the whole regex to each flags list. 1781 Example : 's/\"Junk"//g' # to remove "Junk" flag. 1782--regexflag <regex> : and this one, etc. 1783--sep1 <string> : separator in case namespace is not supported. 1784--sep2 <string> : idem. 1785--delete : delete messages on source imap server after 1786 a successful transfer. Useful in case you 1787 want to migrate from one server to another one. 1788 With imap, delete tags messages as deleted, they 1789 are not really deleted. See expunge. 1790--delete2 : delete messages on the destination imap server that 1791 are not on the source server. 1792--expunge : expunge messages on source account. 1793 expunge really deletes messages marked deleted. 1794 expunge is made at the beginning on the 1795 source server only. newly transferred messages 1796 are expunged if option --expunge is given. 1797 no expunge is done on destination account but 1798 it will change in future releases. 1799--expunge1 : expunge messages on source account. 1800--expunge2 : expunge messages on target account. 1801--syncinternaldates : sets the internal dates on host2 same as host1 1802--buffersize <int> : sets the size of a block of I/O. 1803--maxsize <int> : skip messages larger than <int> bytes 1804--maxage <int> : skip messages older than <int> days. 1805 final stats (skipped) don't count older messages 1806 see also --minage 1807--minage <int> : skip messages newer than <int> days. 1808 final stats (skipped) don't count newer messages 1809 You can do (+ are the messages selected): 1810 past|----maxage+++++++++++++++>now 1811 past|+++++++++++++++minage---->now 1812 past|----maxage+++++minage---->now (intersection) 1813 past|++++minage-----maxage++++>now (union) 1814--skipheader <regex> : Don't take into account header keyword 1815 matching <string> ex: --skipheader 'X.*' 1816--useheader <string> : Use this header to compare messages on both sides. 1817 Ex: Message-ID or Subject or Date. 1818--useheader <string> and this one, etc. 1819--skipsize : Don't take message size into account. 1820--dry : do nothing, just print what would be done. 1821--subscribed : transfers subscribed folders. 1822--subscribe : subscribe to the folders transferred on the 1823 "destination" server that are subscribed 1824 on the "source" server. 1825--(no)foldersizes : Calculate the size of each "From" folder in bytes 1826 and message counts. Meant to be used with 1827 --justfoldersizes. Turned on by default. 1828--justfoldersizes : exit after printed the folder sizes. 1829--syncacls : Synchronises acls (Access Control Lists). 1830--nosyncacls : Does not synchronise acls. This is the default. 1831--debug : debug mode. 1832--debugimap : imap debug mode. 1833--version : print software version. 1834--justconnect : just connect to both servers and print useful 1835 information. Need only --host1 and --host2 options. 1836--justfolders : just do things about folders (ignore messages). 1837--fast : be faster (just does not sync flags). 1838--split1 <int> : split the requests in several parts on source server. 1839 <int > is the number of messages handled per request. 1840 default is like --split1 1000 1841--split2 <int> : same thing on the "destination" server. 1842--fastio1 : use fastio with the "from" server. 1843--fastio2 : use fastio with the "destination" server. 1844--timeout <int> : imap connect timeout. 1845--help : print this. 1846 1847Example: to synchronise imap account "foo" on "imap.truc.org" 1848 to imap account "bar" on "imap.trac.org" 1849 1850$0 \\ 1851 --host1 imap.truc.org --user1 foo --passfile1 /etc/secret1 \\ 1852 --host2 imap.trac.org --user2 bar --passfile2 /etc/secret2 1853 1854$localhost_info 1855 Mail::IMAPClient version is $Mail::IMAPClient::VERSION 1856$rcs 1857 imapsync copyleft is the GNU General Public License. 1858 See http://www.gnu.org/copyleft/gpl.html 1859http://www.amazon.com/gp/registry/wishlist/1C9UNDIH3P7R7/ 1860EOF 1861} 1862 1863 1864sub tests { 1865 1866 SKIP: { 1867 skip "No test in normal run" if (not $tests); 1868 tests_folder_routines(); 1869 tests_compare_lists(); 1870 } 1871} 1872 1873 1874package Mail::IMAPClient; 1875 1876 1877sub Authuser { 1878 my $self = shift; 1879 1880 if (@_) { $self->{AUTHUSER} = shift } 1881 return $self->{AUTHUSER}; 1882} 1883 1884 1885sub Split { 1886 my $self = shift; 1887 1888 if (@_) { $self->{SPLIT} = shift } 1889 return $self->{SPLIT}; 1890} 1891 1892# From IMAPClient.pm 1893sub append_file2 { 1894 1895 my $self = shift; 1896 my $folder = $self->Massage(shift); 1897 my $file = shift; 1898 my $control = shift || undef; 1899 my $count = $self->Count($self->Count+1); 1900 my $flags = shift || undef; 1901 my $date = shift || undef; 1902 1903 if (defined($flags)) { 1904 $flags =~ s/^\s+//g; 1905 $flags =~ s/\s+$//g; 1906 } 1907 1908 if (defined($date)) { 1909 $date =~ s/^\s+//g; 1910 $date =~ s/\s+$//g; 1911 } 1912 1913 $flags = "($flags)" if $flags and $flags !~ /^\(.*\)$/ ; 1914 $date = qq/"$date"/ if $date and $date !~ /^"/ ; 1915 1916 1917 unless ( -f $file ) { 1918 $self->LastError("File $file not found.\n"); 1919 return undef; 1920 } 1921 1922 my $fh = IO::File->new($file) ; 1923 1924 unless ($fh) { 1925 $self->LastError("Unable to open $file: $!\n"); 1926 $@ = "Unable to open $file: $!" ; 1927 carp "unable to open $file: $!" if $^W; 1928 return undef; 1929 } 1930 1931 my $bare_nl_count = scalar grep { /^\x0a$|[^\x0d]\x0a$/} <$fh>; 1932 1933 seek($fh,0,0); 1934 1935 my $clear = $self->Clear; 1936 1937 $self->Clear($clear) 1938 if $self->Count >= $clear and $clear > 0; 1939 1940 my $length = ( -s $file ) + $bare_nl_count; 1941 1942 my $string = "$count APPEND $folder " . 1943 ( $flags ? "$flags " : "" ) . 1944 ( $date ? "$date " : "" ) . 1945 "{" . $length . "}\x0d\x0a" ; 1946 1947 $self->_record($count,[ $self->_next_index($count), "INPUT", "$string" ] ); 1948 1949 my $feedback = $self->_send_line("$string"); 1950 1951 unless ($feedback) { 1952 $self->LastError("Error sending '$string' to IMAP: $!\n"); 1953 $fh->close; 1954 return undef; 1955 } 1956 1957 my ($code, $output) = ("",""); 1958 1959 until ( $code ) { 1960 $output = $self->_read_line or $fh->close, return undef; 1961 foreach my $o (@$output) { 1962 $self->_record($count,$o); # $o is already an array ref 1963 ($code) = $o->[DATA] =~ /(^\+|^\d+\sNO|^\d+\sBAD)/i; 1964 if ($o->[DATA] =~ /^\*\s+BYE/) { 1965 carp $o->[DATA] if $^W; 1966 $self->State(Unconnected); 1967 $fh->close; 1968 return undef ; 1969 } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) { 1970 carp $o->[DATA] if $^W; 1971 $fh->close; 1972 return undef; 1973 } 1974 } 1975 } 1976 1977 { # Narrow scope 1978 # Slurp up headers: later we'll make this more efficient I guess 1979 local $/ = "\x0d\x0a\x0d\x0a"; 1980 my $text = <$fh>; 1981 $text =~ s/\x0d?\x0a/\x0d\x0a/g; 1982 $self->_record($count,[ $self->_next_index($count), "INPUT", "{From file $file}" ] ) ; 1983 $feedback = $self->_send_line($text); 1984 1985 unless ($feedback) { 1986 $self->LastError("Error sending append msg text to IMAP: $!\n"); 1987 $fh->close; 1988 return undef; 1989 } 1990 _debug $self, "control points to $$control\n" if ref($control) and $self->Debug; 1991 $/ = ref($control) ? "\x0a" : $control ? $control : "\x0a"; 1992 while (defined($text = <$fh>)) { 1993 $text =~ s/\x0d?\x0a/\x0d\x0a/g; 1994 $self->_record( $count, 1995 [ $self->_next_index($count), "INPUT", "{from $file}\x0d\x0a" ] 1996 ); 1997 $feedback = $self->_send_line($text,1); 1998 1999 unless ($feedback) { 2000 $self->LastError("Error sending append msg text to IMAP: $!\n"); 2001 $fh->close; 2002 return undef; 2003 } 2004 } 2005 $feedback = $self->_send_line("\x0d\x0a"); 2006 2007 unless ($feedback) { 2008 $self->LastError("Error sending append msg text to IMAP: $!\n"); 2009 $fh->close; 2010 return undef; 2011 } 2012 } 2013 2014 # Now for the crucial test: Did the append work or not? 2015 ($code, $output) = ("",""); 2016 2017 my $uid = undef; 2018 until ( $code ) { 2019 $output = $self->_read_line or return undef; 2020 foreach my $o (@$output) { 2021 $self->_record($count,$o); # $o is already an array ref 2022 $self->_debug("append_file: Deciding if " . $o->[DATA] . " has the code.\n") 2023 if $self->Debug; 2024 ($code) = $o->[DATA] =~ /^\d+\s(NO|BAD|OK)/i; 2025 # try to grab new msg's uid from o/p 2026 $o->[DATA] =~ m#UID\s+\d+\s+(\d+)\]# and $uid = $1; 2027 if ($o->[DATA] =~ /^\*\s+BYE/) { 2028 carp $o->[DATA] if $^W; 2029 $self->State(Unconnected); 2030 $fh->close; 2031 return undef ; 2032 } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) { 2033 carp $o->[DATA] if $^W; 2034 $fh->close; 2035 return undef; 2036 } 2037 } 2038 } 2039 $fh->close; 2040 2041 if ($code !~ /^OK/i) { 2042 return undef; 2043 } 2044 2045 2046 return defined($uid) ? $uid : $self; 2047} 2048 2049# From IMAPClient.pm 2050sub fetch_hash2 { 2051 # taken from original lib, 2052 # just added split code. 2053 my $self = shift; 2054 my $hash = ref($_[-1]) ? pop @_ : {}; 2055 my @words = @_; 2056 for (@words) { 2057 s/([\( ])FAST([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE$2/i ; 2058 s/([\( ])FULL([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE ENVELOPE BODY$2/i ; 2059 } 2060 my $msgref_all = scalar($self->messages); 2061 my $split = $self->Split() || scalar(@$msgref_all); 2062 while(my @msgs = splice(@$msgref_all, 0, $split)) { 2063 #print "SPLIT: @msgs\n"; 2064 my $msgref = \@msgs; 2065 my $output = scalar($self->fetch($msgref,"(" . join(" ",@_) . ")")) 2066 ; # unless grep(/\b(?:FAST|FULL)\b/i,@words); 2067 my $x; 2068 for ($x = 0; $x <= $#$output ; $x++) { 2069 my $entry = {}; 2070 my $l = $output->[$x]; 2071 if ($self->Uid) { 2072 my($uid) = $l =~ /\((?:.* )?UID (\d+).*\)/i; 2073 next unless $uid; 2074 if ( exists $hash->{$uid} ) { 2075 $entry = $hash->{$uid} ; 2076 } 2077 else { 2078 $hash->{$uid} ||= $entry; 2079 } 2080 } 2081 else { 2082 my($mid) = $l =~ /^\* (\d+) FETCH/i; 2083 next unless $mid; 2084 if ( exists $hash->{$mid} ) { 2085 $entry = $hash->{$mid} ; 2086 } 2087 else { 2088 $hash->{$mid} ||= $entry; 2089 } 2090 } 2091 2092 foreach my $w (@words) { 2093 if ( $l =~ /\Q$w\E\s*$/i ) { 2094 $entry->{$w} = $output->[$x+1]; 2095 $entry->{$w} =~ s/(?:\x0a?\x0d)+$//g; 2096 chomp $entry->{$w}; 2097 } 2098 else { 2099 $l =~ /\( # open paren followed by ... 2100 (?:.*\s)? # ...optional stuff and a space 2101 \Q$w\E\s # escaped fetch field<sp> 2102 (?:" # then: a dbl-quote 2103 (\\.| # then bslashed anychar(s) or ... 2104 [^"]+) # ... nonquote char(s) 2105 "| # then closing quote; or ... 2106 \( # ...an open paren 2107 (\\.| # then bslashed anychar or ... 2108 [^\)]+) # ... non-close-paren char 2109 \)| # then closing paren; or ... 2110 (\S+)) # unquoted string 2111 (?:\s.*)? # possibly followed by space-stuff 2112 \) # close paren 2113 /xi; 2114 $entry->{$w}=defined($1)?$1:defined($2)?$2:$3; 2115 } 2116 } 2117 } 2118} 2119 return wantarray ? %$hash : $hash; 2120} 2121 2122 2123# From IMAPClient.pm 2124 2125sub login2 { 2126 my $self = shift; 2127 return $self->authenticate2($self->Authmechanism,$self->Authcallback) 2128 if $self->{Authmechanism}; 2129 2130 my $id = $self->User; 2131 my $has_quotes = $id =~ /^".*"$/ ? 1 : 0; 2132 print "Yahoo: $is_yahoo"; 2133 if ($is_yahoo > 0) 2134 { 2135 print "Yahoo found, sending magic Yahoo command\n"; 2136 $self->_imap_command("ID (\"GUID\" \"1\")"); 2137 } 2138 my $string = "LOGIN " . ( $has_quotes ? $id : qq("$id") ) . 2139 " " . $self->Password . "\r\n"; 2140 $self->_imap_command($string) 2141 and $self->State(Authenticated); 2142 # $self->folders and $self->separator unless $self->NoAutoList; 2143 unless ( $self->IsAuthenticated) { 2144 my($carp) = $self->LastError; 2145 $carp =~ s/^[\S]+ ([^\x0d\x0a]*)\x0d?\x0a/$1/; 2146 carp $carp unless defined wantarray; 2147 return undef; 2148 }; 2149 return $self; 2150} 2151 2152# From IMAPClient.pm 2153 2154sub parse_headers2 { 2155 my($self,$msgspec_all,@fields) = @_; 2156 my(%fieldmap) = map { ( lc($_),$_ ) } @fields; 2157 my $msg; my $string; my $field; 2158 2159 unless(ref($msgspec_all) eq 'ARRAY') { 2160 print "parse_headers2 want an ARRAY ref\n"; 2161 exit 1; 2162 } 2163 2164 my $headers = {}; # hash from message ids to header hash 2165 my $split = $self->Split() || scalar(@$msgspec_all); 2166 while(my @msgs = splice(@$msgspec_all, 0, $split)) { 2167 $debug and print "SPLIT: @msgs\n"; 2168 my $msgspec = \@msgs; 2169 2170 # Make $msg a comma separated list, of messages we want 2171 $msg = $self->Range($msgspec); 2172 2173 if ($fields[0] =~ /^[Aa][Ll]{2}$/ ) { 2174 2175 $string = "$msg body" . 2176 # use ".peek" if Peek parameter is a) defined and true, 2177 # or b) undefined, but not if it's defined and untrue: 2178 2179 ( defined($self->Peek) ? 2180 ( $self->Peek ? ".peek" : "" ) : 2181 ".peek" 2182 ) . "[header]" ; 2183 2184 }else { 2185 $string = "$msg body" . 2186 # use ".peek" if Peek parameter is a) defined and true, or 2187 # b) undefined, but not if it's defined and untrue: 2188 2189 ( defined($self->Peek) ? 2190 ( $self->Peek ? ".peek" : "" ) : 2191 ".peek" 2192 ) . "[header.fields (" . join(" ",@fields) . ')]' ; 2193 } 2194 2195 my @raw=$self->fetch( $string ) or return undef; 2196 2197 2198 my $h = 0; # reference to hash of current msgid, or 0 between msgs 2199 2200 for my $header (map { split(/(?:\x0d\x0a)/,$_) } @raw) { 2201 local($^W) = undef; 2202 if ( $header =~ /^\*\s+\d+\s+FETCH\s+\(.*BODY\[HEADER(?:\]|\.FIELDS)/i) { 2203 if ($self->Uid) { 2204 if ( my($msgid) = $header =~ /UID\s+(\d+)/ ) { 2205 $h = {}; 2206 $headers->{$msgid} = $h; 2207 } 2208 else { 2209 $h = {}; 2210 } 2211 } 2212 else { 2213 if ( my($msgid) = $header =~ /^\*\s+(\d+)/ ) { 2214 #start of new message header: 2215 $h = {}; 2216 $headers->{$msgid} = $h; 2217 } 2218 } 2219 } 2220 next if $header =~ /^\s+$/; 2221 2222 # ( for vi 2223 if ($header =~ /^\)/) { # end of this message 2224 $h = 0; # set to be between messages 2225 next; 2226 } 2227 # check for '<optional_white_space>UID<white_space><UID_number><optional_white_space>)' 2228 # when parsing headers by UID. 2229 if ($self->Uid and my($msgid) = $header =~ /^\s*UID\s+(\d+)\s*\)/) { 2230 $headers->{$msgid} = $h; # store in results against this message 2231 $h = 0; # set to be between messages 2232 next; 2233 } 2234 2235 if ($h != 0) { # do we expect this to be a header? 2236 my $hdr = $header; 2237 chomp $hdr; 2238 $hdr =~ s/\r$//; 2239 if ($hdr =~ s/^(\S+):\s*//) { 2240 $field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ; 2241 push @{$h->{$field}} , $hdr ; 2242 } elsif ($hdr =~ s/^.*FETCH\s\(.*BODY\[HEADER\.FIELDS.*\)\]\s(\S+):\s*//) { 2243 $field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ; 2244 push @{$h->{$field}} , $hdr ; 2245 } elsif ( ref($h->{$field}) eq 'ARRAY') { 2246 2247 $hdr =~ s/^\s+/ /; 2248 $h->{$field}[-1] .= $hdr ; 2249 } 2250 } 2251 } 2252 my $candump = 0; 2253 if ($self->Debug) { 2254 eval { 2255 require Data::Dumper; 2256 Data::Dumper->import; 2257 }; 2258 $candump++ unless $@; 2259 } 2260 2261 } 2262 # if we asked for one message, just return its hash, 2263 # otherwise, return hash of numbers => header hash 2264 # if (ref($msgspec) eq 'ARRAY') { 2265 2266 return $headers; 2267 2268} 2269 2270 2271# From IMAPClient.pm 2272 2273sub authenticate2 { 2274 2275 my $self = shift; 2276 my $scheme = shift; 2277 my $response = shift; 2278 2279 $scheme ||= $self->Authmechanism; 2280 $response ||= $self->Authcallback; 2281 my $clear = $self->Clear; 2282 2283 $self->Clear($clear) 2284 if $self->Count >= $clear and $clear > 0; 2285 2286 my $count = $self->Count($self->Count+1); 2287 2288 2289 my $string = "$count AUTHENTICATE $scheme"; 2290 2291 $self->_record($count,[ $self->_next_index($self->Transaction), 2292 "INPUT", "$string\x0d\x0a"] ); 2293 2294 my $feedback = $self->_send_line("$string"); 2295 2296 unless ($feedback) { 2297 $self->LastError("Error sending '$string' to IMAP: $!\n"); 2298 return undef; 2299 } 2300 2301 my ($code, $output); 2302 2303 until ($code) { 2304 $output = $self->_read_line or return undef; 2305 foreach my $o (@$output) { 2306 $self->_record($count,$o); # $o is a ref 2307 ($code) = $o->[DATA] =~ /^\+(.*)$/ ; 2308 if ($o->[DATA] =~ /^\*\s+BYE/) { 2309 $self->State(Unconnected); 2310 return undef ; 2311 } 2312 } 2313 } 2314 2315 return undef if $code =~ /^BAD|^NO/ ; 2316 2317 if ('CRAM-MD5' eq $scheme && ! $response) { 2318 if ($Mail::IMAPClient::_CRAM_MD5_ERR) { 2319 $self->LastError($Mail::IMAPClient::_CRAM_MD5_ERR); 2320 carp $Mail::IMAPClient::_CRAM_MD5_ERR if $^W; 2321 } 2322 else { 2323 $response = \&_cram_md5_2; 2324 } 2325 } 2326 2327 2328 $feedback = $self->_send_line($response->($code, $self)); 2329 2330 unless ($feedback) { 2331 $self->LastError("Error sending append msg text to IMAP: $!\n"); 2332 return undef; 2333 } 2334 2335 $code = ""; # clear code 2336 until ($code) { 2337 $output = $self->_read_line or return undef; 2338 foreach my $o (@$output) { 2339 $self->_record($count,$o); # $o is a ref 2340 if ( ($code) = $o->[DATA] =~ /^\+ (.*)$/ ) { 2341 $feedback = $self->_send_line($response->($code,$self)); 2342 unless ($feedback) { 2343 $self->LastError("Error sending append msg text to IMAP: $!\n"); 2344 return undef; 2345 } 2346 $code = "" ; # Clear code; we're still not finished 2347 } else { 2348 $o->[DATA] =~ /^$count (OK|NO|BAD)/ and $code = $1; 2349 if ($o->[DATA] =~ /^\*\s+BYE/) { 2350 $self->State(Unconnected); 2351 return undef ; 2352 } 2353 } 2354 } 2355 } 2356 2357 $code =~ /^OK/ and $self->State(Authenticated) ; 2358 return $code =~ /^OK/ ? $self : undef ; 2359 2360} 2361 2362sub _cram_md5_2 { 2363 my ($code, $client) = @_; 2364 my $hmac = Digest::HMAC_MD5::hmac_md5_hex(MIME::Base64::decode($code), 2365 $client->Password()); 2366 return MIME::Base64::encode($client->User() . " $hmac", ""); 2367} 2368 2369 2370sub connect2 { 2371 my $self = shift; 2372 2373 $self->Port(143) 2374 if defined ($IO::Socket::INET::VERSION) 2375 and $IO::Socket::INET::VERSION eq '1.25' 2376 and !$self->Port; 2377 %$self = (%$self, @_); 2378 my $sock = IO::Socket::INET->new; 2379 my $dp = 'imap(143)'; 2380 #print "i01\n"; 2381 my $ret = $sock->configure({ 2382 PeerAddr => $self->Server , 2383 PeerPort => $self->Port||$dp , 2384 Proto => 'tcp' , 2385 Timeout => $self->Timeout||0 , 2386 Debug => $self->Debug , 2387 }); 2388 #print "i02\n"; 2389 unless ( defined($ret) ) { 2390 $self->LastError( "$@\n"); 2391 $@ = "$@"; 2392 carp "$@" 2393 unless defined wantarray; 2394 return undef; 2395 } 2396 #print "i03\n"; 2397 $self->Socket($sock); 2398 $self->State(Connected); 2399 2400 $sock->autoflush(1) ; 2401 2402 my ($code, $output); 2403 $output = ""; 2404 2405 until ( $code ) { 2406 2407 $output = $self->_read_line or return undef; 2408 for my $o (@$output) { 2409 $self->_debug("Connect: Received this from readline: " . 2410 join("/",@$o) . "\n"); 2411 $self->_record($self->Count,$o); # $o is a ref 2412 next unless $o->[TYPE] eq "OUTPUT"; 2413 ($code) = $o->[DATA] =~ /^\*\s+(OK|BAD|NO)/i ; 2414 } 2415 2416 } 2417 2418 if ($code =~ /BYE|NO /) { 2419 $self->State(Unconnected); 2420 return undef ; 2421 } 2422 2423 if ($self->User and $self->Password) { 2424 return $self->login ; 2425 } 2426 else { 2427 return $self; 2428 } 2429} 2430 2431