1#!/usr/local/bin/perl 2 3# $Header: /mhub4/sources/imap-tools/imapcopy.pl,v 1.47 2012/03/29 15:11:05 rick Exp $ 4 5####################################################################### 6# Program name imapcopy.pl # 7# Written by Rick Sanders # 8# # 9# Description # 10# # 11# imapcopy is a utility for copying a user's messages from one # 12# IMAP server to another. # 13# # 14# imapcopy is called like this: # 15# ./imapcopy -S host1/user1/password1 -D host2/user2/password2 # 16# # 17# Optional arguments: # 18# -d debug # 19# -I show IMAP protocol exchanges # 20# -L logfile # 21# -m mailbox list (copy only certain mailboxes,see usage notes) # 22# -r reset the \DELETE flag on copied messages # 23# -p <root mailbox> put copied mailboxes under a root mbx # 24# -M <file> mailbox mapping (eg, src:inbox -> dst:inbox_copied) # 25# -i initialize mailbox (remove existing msgs first) # 26# -U run in "update" mode 27# Run imapcopy.pl -h to see complete set of arguments. # 28####################################################################### 29 30use Socket; 31use FileHandle; 32use Fcntl; 33use Getopt::Std; 34use IO::Socket; 35 36################################################################# 37# Main program. # 38################################################################# 39 40 init(); 41 42 # Get list of all messages on the source host 43 # 44 connectToHost($sourceHost, \$src) or exit; 45 login($sourceUser,$sourcePwd, $sourceHost, $src, $srcMethod) or exit; 46 namespace( $src, \$srcPrefix, \$srcDelim, $opt_x ); 47 48 connectToHost( $destHost, \$dst ) or exit; 49 login( $destUser,$destPwd, $destHost, $dst, $dstMethod ) or exit; 50 namespace( $dst, \$dstPrefix, \$dstDelim, $opt_y ); 51 52 @mbxs = getMailboxList( $srcPrefix, $src ); 53 54 # Exclude certain mbxs if that's what the user wants 55 exclude_mbxs( \@mbxs ) if $excludeMbxs; 56 57 map_mbx_names( \%mbx_map, $srcDelim, $dstDelim ); 58 59 if ( $archive_mbx ) { 60 # Create an archive mbx on the source to receive copies of messsages 61 createMbx( $archive_mbx, $src ) unless mbxExists( $archive_mbx, $src); 62 } 63 64 $total=$mbxs_processed = 0; 65 my $delete_msg_list; 66 $num_mbxs = $#mbxs + 1; 67 Log("Number of mailboxes to process: $num_mbxs"); 68 foreach $srcmbx ( @mbxs ) { 69 ### encode( \$srcmbx ); 70 next if $srcmbx eq $archive_mbx; 71 $archived=0; 72 $mbxs_processed++; 73 if ( $verbose ) { 74 $line = "Processing $srcmbx " . '(' . $mbxs_processed . '/' . $num_mbxs . ')'; 75 Log("$line"); 76 } 77 $dstmbx = mailboxName( $srcmbx,$srcPrefix,$srcDelim,$dstPrefix,$dstDelim ); 78 $dstmbx =~ s/\s+$//g; 79 80 # Special for issue with Exchange IMAP which doesn't like 81 # trailing spaces in mailbox names. 82 $dstmbx =~ s/\s+\//\//g; 83 84 $LAST = "$dstmbx"; 85 createMbx( $dstmbx, $dst ) unless mbxExists( $dstmbx, $dst); 86 87 if ( $include_nosel_mbxs ) { 88 # If a mailbox was 'Noselect' on the src but the user wants 89 # it created as a regular folder on the dst then do so. They 90 # don't hold any messages so after creating them we don't need 91 # to do anything else. 92 next if $nosel_mbxs{"$srcmbx"}; 93 } 94 95 selectMbx( $dstmbx, $dst ); 96 97 if ( $update ) { 98 Log("Get msgids on the destination") if $debug; 99 getMsgIdList( $dstmbx, \%DST_MSGS, $dst ); 100 } 101 102 init_mbx( $dstmbx, $dst ) if $init_mbx; 103 104 $checkpoint = "$srcmbx|$sourceHost|$sourceUser|$sourcePwd|"; 105 $checkpoint .= "$destHost|$destUser|$destPwd"; 106 107 if ( $sent_after and $sent_before ) { 108 getDatedMsgList( $srcmbx, 'SINCE', $sent_after, \@msgs_since, $src ); 109 getDatedMsgList( $srcmbx, 'BEFORE', $sent_before, \@msgs_before, $src ); 110 date_in_range( \@msgs_since, \@msgs_before, \@msgs); 111 } elsif ( $sent_after ) { 112 getDatedMsgList( $srcmbx, 'SINCE', $sent_after, \@msgs, $src ); 113 } elsif ( $sent_before ) { 114 getDatedMsgList( $srcmbx, 'BEFORE', $sent_before, \@msgs, $src ); 115 } else { 116 getMsgList( $srcmbx, \@msgs, $src ); 117 } 118 119 my $msgcount = $#msgs + 1; 120 if ( $sent_after and $sent_before ) { 121 Log("There are $msgcount messages between those dates"); 122 } 123 Log(" Copying $msgcount messages in $srcmbx mailbox") if $verbose; 124 if ( $msgcount == 0 ) { 125 Log(" $srcmbx mailbox is empty"); 126 next; 127 } 128 129 $copied=0; 130 foreach $_ ( @msgs ) { 131 alarm $timeout; 132 ($msgnum,$date,$flags,$msgid) = split(/\|/, $_); 133 134 Log("msgnum=$msgnum,msgid=$msgid") if $debug; 135 136 if ( $update ) { 137 # Don't insert the message if it already exists 138 next if $DST_MSGS{"$msgid"}; 139 Log("$msgid does not exist on the destination") if $debug; 140 } 141 142 # Strip off TZ offset if it exists 143 $date =~ s/\((.+)\)$//; 144 $date =~ s/\s+$//g; 145 146 $LAST = "$dstmbx|$msgnum"; 147 next unless fetchMsg( $msgnum, \$message, $srcmbx, $src ); 148 149 # $message =~ /Message-Id: (.+)/i; 150 # Log("message has msgid = $1"); 151 alarm 0; 152 153 if ( $conn_timed_out ) { 154 Log("$sourceHost timed out"); 155 reconnect( $checkpoint, $src ); 156 $conn_timed_out = 0; 157 next; 158 } 159 next unless $message; 160 161 alarm $timeout; 162 163 $copied++ if insertMsg( $dst, $dstmbx, *message, $flags, $date ); 164 165 if ( $archive_mbx ) { 166 # Put a copy of the message in it too 167 if ( insertMsg( $src, $archive_mbx, *message, $flags, $date ) ) { 168 $archived++; 169 if ( $rem_src_msgs ) { 170 $delete_msg_list .= "$msgnum "; 171 } 172 } 173 } 174 175 if ( $copied/100 == int($copied/100)) { 176 Log(" Copied $copied messages so far") if $verbose; 177 } 178 179 alarm 0; 180 181 if ( $conn_timed_out ) { 182 Log("$destHost timed out"); 183 reconnect( $checkpoint, $dst ); 184 $conn_timed_out = 0; 185 next; 186 } 187 188 } 189 $total += $copied; 190 if ( $use_utf7 ) { 191 $dstmbx = Unicode::IMAPUtf7::imap_utf7_decode( $dstmbx ); 192 } 193 if ( $verbose ) { 194 $line = " Copied $copied messages to $dstmbx "; 195 $line .= '(' . $mbxs_processed . '/' . $num_mbxs . ')'; 196 Log( "$line "); 197 } else { 198 Log(" Copied $copied messages to $dstmbx"); 199 } 200 201 if ( $archive_mbx ) { 202 Log(" Copied $archived messages to $archive_mbx mailbox"); 203 if ( $rem_src_msgs ) { 204 # Remove the messages from the source mailbox 205 Log("Removing messages from $srcmbx on source"); 206 delete_msg_list( $delete_msg_list, $srcmbx, $src ); 207 expungeMbx( $srcmbx, $src ); 208 } 209 } 210 } 211 212 Log("Copied $total total messages"); 213 logout( $src ); 214 logout( $dst ); 215 216 exit; 217 218 219sub init { 220 221 $os = $ENV{'OS'}; 222 223 processArgs(); 224 225 # Open the logFile 226 # 227 if ( $logfile ) { 228 if ( !open(LOG, ">> $logfile")) { 229 print STDOUT "Can't open $logfile: $!\n"; 230 exit; 231 } 232 select(LOG); $| = 1; 233 } 234 Log("$0 starting"); 235 236 # Determine whether we have SSL support via openSSL and IO::Socket::SSL 237 $ssl_installed = 1; 238 eval 'use IO::Socket::SSL'; 239 if ( $@ ) { 240 $ssl_installed = 0; 241 } 242 243 # Set up signal handling 244 $SIG{'ALRM'} = 'signalHandler'; 245 $SIG{'HUP'} = 'signalHandler'; 246 $SIG{'INT'} = 'signalHandler'; 247 $SIG{'TERM'} = 'signalHandler'; 248 $SIG{'URG'} = 'signalHandler'; 249 250} 251 252# 253# sendCommand 254# 255# This subroutine formats and sends an IMAP protocol command to an 256# IMAP server on a specified connection. 257# 258 259sub sendCommand { 260 261my $fd = shift; 262my $cmd = shift; 263 264 print $fd "$cmd\r\n"; 265 266 Log (">> $cmd") if $showIMAP; 267} 268 269# 270# readResponse 271# 272# This subroutine reads and formats an IMAP protocol response from an 273# IMAP server on a specified connection. 274# 275 276sub readResponse { 277 278my $fd = shift; 279 280 $response = <$fd>; 281 chop $response; 282 $response =~ s/\r//g; 283 push (@response,$response); 284 Log ("<< $response") if $showIMAP; 285 286 if ( $response =~ /server unavailable|connection closed/i ) { 287 resume(); 288 } 289} 290 291# 292# Log 293# 294# This subroutine formats and writes a log message to STDERR. 295# 296 297sub Log { 298 299my $str = shift; 300 301 # If a logfile has been specified then write the output to it 302 # Otherwise write it to STDOUT 303 304 if ( $logfile ) { 305 ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime; 306 if ($year < 99) { $yr = 2000; } 307 else { $yr = 1900; } 308 $line = sprintf ("%.2d-%.2d-%d.%.2d:%.2d:%.2d %s\n", 309 $mon + 1, $mday, $year + $yr, $hour, $min, $sec,$str); 310 print LOG "$line"; 311 } 312 print STDOUT "$str\n" unless $quiet_mode; 313 314} 315 316 317sub createMbx { 318 319my $mbx = shift; 320my $conn = shift; 321 322 # Create the mailbox if necessary 323 324 sendCommand ($conn, "1 CREATE \"$mbx\""); 325 while ( 1 ) { 326 readResponse ($conn); 327 last if $response =~ /^1 OK/i; 328 last if $response =~ /already exists/i; 329 if ( $response =~ /^1 NO|^1 BAD|^\* BYE/ ) { 330 Log ("Error creating $mbx: $response"); 331 last; 332 } 333 if ( $response eq '' or $response =~ /^1 NO/ ) { 334 Log ("unexpected CREATE response: >$response<"); 335 Log("response is NULL"); 336 resume(); 337 last; 338 } 339 340 } 341 342} 343 344# insertMsg 345# 346# This routine inserts a message into a user's mailbox 347# 348sub insertMsg { 349 350local ($conn, $mbx, *message, $flags, $date) = @_; 351local ($lenx); 352 353 $lenx = length($message); 354 355 Log(" Inserting message") if $debug; 356 my $mb = $lenx/1000000; 357 358 if ( $max_size and $mb > $max_size ) { 359 commafy( \$lenx ); 360 Log(" Skipping message because its size ($lenx) exceeds the $max_size MB limit"); 361 return; 362 } 363 364 $totalBytes = $totalBytes + $lenx; 365 $totalMsgs++; 366 367 $flags = flags( $flags ); 368 369 fixup_date( \$date ); 370 371 sendCommand ($conn, "1 APPEND \"$mbx\" ($flags) \"$date\" \{$lenx\}"); 372 readResponse ($conn); 373 if ( $response !~ /^\+/ ) { 374 Log ("1 unexpected APPEND response: >$response<"); 375 if ( $response eq '' or $response =~ /^1 NO/ ) { 376 Log("response is NULL"); 377 resume(); 378 next; 379 } 380 # next; 381 push(@errors,"Error appending message to $mbx for $user"); 382 return 0; 383 } 384 385 print $conn "$message\r\n"; 386 387 undef @response; 388 while ( 1 ) { 389 readResponse ($conn); 390 if ( $response =~ /^1 OK/i ) { 391 last; 392 } 393 elsif ( $response !~ /^\*/ ) { 394 Log ("unexpected APPEND response: $response"); 395 # next; 396 return 0; 397 } 398 } 399 400 return 1; 401} 402 403# Make a connection to a IMAP host 404 405sub connectToHost { 406 407my $host = shift; 408my $conn = shift; 409 410 Log("Connecting to $host") if $debug; 411 412 ($host,$port) = split(/:/, $host); 413 $port = 143 unless $port; 414 415 # We know whether to use SSL for ports 143 and 993. For any 416 # other ones we'll have to figure it out. 417 $mode = sslmode( $host, $port ); 418 419 if ( $mode eq 'SSL' ) { 420 unless( $ssl_installed == 1 ) { 421 warn("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 422 Log("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 423 exit; 424 } 425 Log("Attempting an SSL connection") if $debug; 426 $$conn = IO::Socket::SSL->new( 427 Proto => "tcp", 428 SSL_verify_mode => 0x00, 429 PeerAddr => $host, 430 PeerPort => $port, 431 ); 432 433 unless ( $$conn ) { 434 $error = IO::Socket::SSL::errstr(); 435 Log("Error connecting to $host: $error"); 436 exit; 437 } 438 } else { 439 # Non-SSL connection 440 Log("Attempting a non-SSL connection") if $debug; 441 $$conn = IO::Socket::INET->new( 442 Proto => "tcp", 443 PeerAddr => $host, 444 PeerPort => $port, 445 ); 446 447 unless ( $$conn ) { 448 Log("Error connecting to $host:$port: $@"); 449 warn "Error connecting to $host:$port: $@"; 450 exit; 451 } 452 } 453 Log("Connected to $host on port $port"); 454 455} 456 457sub sslmode { 458 459my $host = shift; 460my $port = shift; 461my $mode; 462 463 # Determine whether to make an SSL connection 464 # to the host. Return 'SSL' if so. 465 466 if ( $port == 143 ) { 467 # Standard non-SSL port 468 return ''; 469 } elsif ( $port == 993 ) { 470 # Standard SSL port 471 return 'SSL'; 472 } 473 474 unless ( $ssl_installed ) { 475 # We don't have SSL installed on this machine 476 return ''; 477 } 478 479 # For any other port we need to determine whether it supports SSL 480 481 my $conn = IO::Socket::SSL->new( 482 Proto => "tcp", 483 SSL_verify_mode => 0x00, 484 PeerAddr => $host, 485 PeerPort => $port, 486 ); 487 488 if ( $conn ) { 489 close( $conn ); 490 $mode = 'SSL'; 491 } else { 492 $mode = ''; 493 } 494 495 return $mode; 496} 497 498# trim 499# 500# remove leading and trailing spaces from a string 501sub trim { 502 503local (*string) = @_; 504 505 $string =~ s/^\s+//; 506 $string =~ s/\s+$//; 507 508 return; 509} 510 511 512# login 513# 514# login in at the source host with the user's name and password 515# 516sub login { 517 518my $user = shift; 519my $pwd = shift; 520my $host = shift; 521my $conn = shift; 522my $method = shift; 523 524 Log("Authenticating to $host as $user"); 525 if ( uc( $method ) eq 'CRAM-MD5' ) { 526 # A CRAM-MD5 login is requested 527 Log("login method $method"); 528 my $rc = login_cram_md5( $user, $pwd, $conn ); 529 return $rc; 530 } 531 532 # Otherwise do a PLAIN login 533 534 sendCommand ($conn, "1 LOGIN $user \"$pwd\""); 535 while (1) { 536 readResponse ( $conn ); 537 last if $response =~ /^1 OK/i; 538 if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 539 Log ("unexpected LOGIN response: $response"); 540 return 0; 541 } 542 } 543 Log("Logged in as $user") if $debug; 544 545 return 1; 546} 547 548 549sub login_cram_md5 { 550 551my $user = shift; 552my $pwd = shift; 553my $conn = shift; 554 555 sendCommand ($conn, "1 AUTHENTICATE CRAM-MD5"); 556 while (1) { 557 readResponse ( $conn ); 558 last if $response =~ /^\+/; 559 if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 560 Log ("unexpected LOGIN response: $response"); 561 return 0; 562 } 563 } 564 565 my ($challenge) = $response =~ /^\+ (.+)/; 566 567 Log("challenge $challenge") if $debug; 568 $response = cram_md5( $challenge, $user, $pwd ); 569 Log("response $response") if $debug; 570 571 sendCommand ($conn, $response); 572 while (1) { 573 readResponse ( $conn ); 574 last if $response =~ /^1 OK/i; 575 if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 576 Log ("unexpected LOGIN response: $response"); 577 return 0; 578 } 579 } 580 Log("Logged in as $user") if $debug; 581 582 return 1; 583} 584 585# logout 586# 587# log out from the host 588# 589sub logout { 590 591my $conn = shift; 592 593 undef @response; 594 sendCommand ($conn, "1 LOGOUT"); 595 while ( 1 ) { 596 readResponse ($conn); 597 if ( $response =~ /^1 OK/i ) { 598 last; 599 } 600 elsif ( $response !~ /^\*/ ) { 601 Log ("unexpected LOGOUT response: $response"); 602 last; 603 } 604 } 605 close $conn; 606 return; 607} 608 609# getMailboxList 610# 611# get a list of the user's mailboxes from the source host 612# 613sub getMailboxList { 614 615my $prefix = shift; 616my $conn = shift; 617my @mbxs; 618 619 # Get a list of the user's mailboxes 620 # 621 622 Log("Get list of user's mailboxes",2) if $debugMode; 623 624 if ( $mbxList ) { 625 foreach $mbx ( split(/,/, $mbxList) ) { 626 $mbx = $prefix . $mbx if $prefix; 627 if ( $opt_R ) { 628 # Get all submailboxes under the ones specified 629 $mbx .= '*'; 630 @mailboxes = listMailboxes( $mbx, $conn); 631 push( @mbxs, @mailboxes ); 632 } else { 633 push( @mbxs, $mbx ); 634 } 635 } 636 } else { 637 # Get all mailboxes 638 @mbxs = listMailboxes( '*', $conn); 639 } 640 641 return @mbxs; 642} 643 644# exclude_mbxs 645# 646# Exclude certain mailboxes from the list if the user 647# has provided an exclude list with the -e argument 648 649sub exclude_mbxs { 650 651my $mbxs = shift; 652my @new_list; 653my %exclude; 654 655 foreach my $exclude ( split(/,/, $excludeMbxs ) ) { 656 $exclude{"$exclude"} = 1; 657 } 658 foreach my $mbx ( @$mbxs ) { 659 next if $exclude{"$mbx"}; 660 push( @new_list, $mbx ); 661 } 662 663 @$mbxs = @new_list; 664 665} 666 667# listMailboxes 668# 669# Get a list of the user's mailboxes 670# 671sub listMailboxes { 672 673my $mbx = shift; 674my $conn = shift; 675 676 sendCommand ($conn, "1 LIST \"\" \"$mbx\""); 677 undef @response; 678 while ( 1 ) { 679 &readResponse ($conn); 680 if ( $response =~ /^1 OK/i ) { 681 last; 682 } 683 elsif ( $response !~ /^\*/ ) { 684 &Log ("unexpected response: $response"); 685 return 0; 686 } 687 } 688 689 @mbxs = (); 690 for $i (0 .. $#response) { 691 $response[$i] =~ s/\s+/ /; 692 if ( $response[$i] =~ /"$/ ) { 693 $response[$i] =~ /\* LIST \((.*)\) "(.+)" "(.+)"/i; 694 $mbx = $3; 695 } elsif ( $response[$i] =~ /\* LIST \((.*)\) NIL (.+)/i ) { 696 $mbx = $2; 697 } else { 698 $response[$i] =~ /\* LIST \((.*)\) "(.+)" (.+)/i; 699 $mbx = $3; 700 } 701 $mbx =~ s/^\s+//; $mbx =~ s/\s+$//; 702 703 if ($response[$i] =~ /NOSELECT/i) { 704 if ( $include_nosel_mbxs ) { 705 $nosel_mbxs{"$mbx"} = 1; 706 } else { 707 Log("$mbx is set NOSELECT, skipping it") if $debug; 708 next; 709 } 710 } 711 if ($mbx =~ /^\./) { 712 # Skip mailboxes starting with a dot 713 next; 714 } 715 push ( @mbxs, $mbx ) if $mbx ne ''; 716 } 717 718 return @mbxs; 719} 720 721# getMsgList 722# 723# Get a list of the user's messages in the indicated mailbox on 724# the source host 725# 726sub getMsgList { 727 728my $mailbox = shift; 729my $msgs = shift; 730my $conn = shift; 731my $mode = shift; 732my $seen; 733my $empty; 734my $msgnum; 735my $from; 736my $flags; 737my $msgid; 738 739 @$msgs = (); 740 $mode = 'EXAMINE' unless $mode; 741 sendCommand ($conn, "1 $mode \"$mailbox\""); 742 undef @response; 743 $empty=0; 744 while ( 1 ) { 745 readResponse ( $conn ); 746 if ( $response =~ / 0 EXISTS/i ) { $empty=1; } 747 if ( $response =~ /^1 OK/i ) { 748 last; 749 } 750 elsif ( $response !~ /^\*/ ) { 751 Log ("unexpected response: $response"); 752 return 0; 753 } 754 } 755 756 return 1 if $empty; 757 758 my $start = 1; 759 my $end = '*'; 760 $start = $start_fetch if $start_fetch; 761 $end = $end_fetch if $end_fetch; 762 763 sendCommand ( $conn, "1 FETCH $start:$end (uid flags internaldate body[header.fields (From Date Message-Id)])"); 764 765 @response = (); 766 while ( 1 ) { 767 readResponse ( $conn ); 768 769 if ( $response =~ /^1 OK/i ) { 770 last; 771 } 772 last if $response =~ /^1 NO|^1 BAD|^\* BYE/; 773 } 774 775 $flags = ''; 776 for $i (0 .. $#response) { 777 last if $response[$i] =~ /^1 OK FETCH complete/i; 778 779 if ($response[$i] =~ /FLAGS/) { 780 # Get the list of flags 781 $response[$i] =~ /FLAGS \(([^\)]*)/; 782 $flags = $1; 783 $flags =~ s/\\Recent//; 784 } 785 786 if ( $response[$i] =~ /INTERNALDATE/) { 787 $response[$i] =~ /INTERNALDATE (.+) BODY/i; 788 # $response[$i] =~ /INTERNALDATE "(.+)" BODY/; 789 $date = $1; 790 791 $date =~ /"(.+)"/; 792 $date = $1; 793 $date =~ s/"//g; 794 } 795 796 if ( $response[$i] =~ /^Message-Id:/i ) { 797 $response[$i] =~ /^Message-Id: (.+)/i; 798 $msgid = $1; 799 trim(*msgid); 800 if ( $msgid eq '' ) { 801 # Line-wrap, get it from the next line 802 $msgid = $response[$i+1]; 803 trim(*msgid); 804 } 805 } 806 807 # if ( $response[$i] =~ /\* (.+) [^FETCH]/ ) { 808 if ( $response[$i] =~ /\* (.+) FETCH/ ) { 809 ($msgnum) = split(/\s+/, $1); 810 } 811 812 if ( $msgnum and $date and $msgid ) { 813 # if ( $msgnum and $date ) { 814 push (@$msgs,"$msgnum|$date|$flags|$msgid"); 815 $msgnum = $date = $msgid = ''; 816 } 817 } 818 819 return 1; 820 821} 822 823# getDatedMsgList 824# 825# Get a list of the user's messages in a mailbox on 826# the host which were sent after the specified date 827# 828 829sub getDatedMsgList { 830 831my $mailbox = shift; 832my $operator = shift; 833my $cutoff_date = shift; 834my $msgs = shift; 835my $conn = shift; 836my ($seen, $empty, @list,$msgid); 837 838 # Get a list of messages sent after the specified date 839 840 Log("Searching for messages $operator $cutoff_date"); 841 842 @list = (); 843 @$msgs = (); 844 845 sendCommand ($conn, "1 EXAMINE \"$mailbox\""); 846 while ( 1 ) { 847 readResponse ($conn); 848 if ( $response =~ / EXISTS/i) { 849 $response =~ /\* ([^EXISTS]*)/; 850 # Log(" There are $1 messages in $mailbox"); 851 } elsif ( $response =~ /^1 OK/i ) { 852 last; 853 } elsif ( $response =~ /^1 NO/i ) { 854 Log ("unexpected response: $response"); 855 return 0; 856 } elsif ( $response !~ /^\*/ ) { 857 Log ("unexpected response: $response"); 858 return 0; 859 } 860 } 861 862 my ($date,$ts) = split(/\s+/, $cutoff_date); 863 864 # 865 # Get list of messages sent before/after the reference date 866 # 867 Log("Get messages sent $operator $date") if $debug; 868 $nums = ""; 869 sendCommand ($conn, "1 SEARCH $operator \"$date\""); 870 while ( 1 ) { 871 readResponse ($conn); 872 if ( $response =~ /^1 OK/i ) { 873 last; 874 } 875 elsif ( $response =~ /^\*\s+SEARCH/i ) { 876 ($nums) = ($response =~ /^\*\s+SEARCH\s+(.*)/i); 877 } 878 elsif ( $response !~ /^\*/ ) { 879 Log ("unexpected SEARCH response: $response"); 880 return; 881 } 882 } 883 Log("$nums") if $debug; 884 if ( $nums eq "" ) { 885 Log (" $mailbox has no messages sent before $date") if $debug; 886 return; 887 } 888 my @number = split(/\s+/, $nums); 889 $n = $#number + 1; 890 891 $nums =~ s/\s+/ /g; 892 @msgList = (); 893 @msgList = split(/ /, $nums); 894 895 if ($#msgList == -1) { 896 # No msgs in this mailbox 897 return 1; 898 } 899 900@$msgs = (); 901for $num (@msgList) { 902 903 sendCommand ( $conn, "1 FETCH $num (uid flags internaldate body[header.fields (Message-Id Date)])"); 904 905 undef @response; 906 while ( 1 ) { 907 readResponse ( $conn ); 908 if ( $response =~ /^1 OK/i ) { 909 last; 910 } 911 last if $response =~ /^1 NO|^1 BAD|^\* BYE/; 912 } 913 914 $flags = ''; 915 my $msgid; 916 foreach $_ ( @response ) { 917 last if /^1 OK FETCH complete/i; 918 if ( /FLAGS/ ) { 919 # Get the list of flags 920 /FLAGS \(([^\)]*)/; 921 $flags = $1; 922 $flags =~ s/\\Recent//; 923 } 924 925 if ( /Message-Id:\s*(.+)/i ) { 926 $msgid = $1; 927 } 928 929 if ( /INTERNALDATE/) { 930 /INTERNALDATE (.+) BODY/i; 931 $date = $1; 932 $date =~ /"(.+)"/; 933 $date = $1; 934 $date =~ s/"//g; 935 #### next if check_cutoff_date( $date, $cutoff_date ); 936 } 937 938 if ( /\* (.+) FETCH/ ) { 939 ($msgnum) = split(/\s+/, $1); 940 } 941 942 if ( $msgnum and $date and $msgid ) { 943 push (@$msgs,"$msgnum|$date|$flags|$msgid"); 944 $msgnum=$msgid=$date=$flags=''; 945 } 946 } 947 } 948 949 foreach $_ ( @$msgs ) { 950 Log("getDated found $_") if $debug; 951 } 952 953 return 1; 954} 955 956sub date_in_range { 957 958my $list1 = shift; 959my $list2 = shift; 960my $newlist = shift; 961my %MSGNUMS; 962 963 # Return a list of msgnums common to both lists passed 964 # to us. 965 966 @$newlist = (); 967 968 foreach $_ ( @$list1 ) { 969 my ($msgnum) = split(/\|/, $_); 970 $MSGNUMS{$msgnum} = $_; 971 } 972 973 foreach $_ ( @$list2 ) { 974 my ($msgnum) = split(/\|/, $_); 975 push( @$newlist, $_ ) if $MSGNUMS{$msgnum}; 976 } 977 978} 979 980sub mbxExists { 981 982my $mbx = shift; 983my $conn = shift; 984my $status = 1; 985 986 # Determine whether a mailbox exists 987 sendCommand ($conn, "1 EXAMINE \"$mbx\""); 988 while (1) { 989 readResponse ($conn); 990 last if $response =~ /^1 OK/i; 991 if ( $response =~ /^1 NO|^1 BAD|^\* BYE/ ) { 992 $status = 0; 993 last; 994 } 995 } 996 997 return $status; 998} 999 1000sub fetchMsg { 1001 1002my $msgnum = shift; 1003my $message = shift; 1004my $mbx = shift; 1005my $conn = shift; 1006 1007 Log(" Fetching msg $msgnum...") if $debug; 1008 1009 $$message = ''; 1010 sendCommand( $conn, "1 FETCH $msgnum (rfc822)"); 1011 while (1) { 1012 readResponse ($conn); 1013 last if $response =~ /^1 NO|^1 BAD|^\* BYE/; 1014 1015if ( $response eq '' ) { 1016 Log("RESP2 >$response<"); 1017 resume(); 1018 return 0; 1019} 1020 if ( $response =~ /^1 OK/i ) { 1021 $size = length($$message); 1022 last; 1023 } 1024 elsif ($response =~ /message number out of range/i) { 1025 Log ("Error fetching uid $uid: out of range",2); 1026 $stat=0; 1027 last; 1028 } 1029 elsif ($response =~ /Bogus sequence in FETCH/i) { 1030 Log ("Error fetching uid $uid: Bogus sequence in FETCH",2); 1031 $stat=0; 1032 last; 1033 } 1034 elsif ( $response =~ /message could not be processed/i ) { 1035 Log("Message could not be processed, skipping it ($user,msgnum $msgnum,$destMbx)"); 1036 push(@errors,"Message could not be processed, skipping it ($user,msgnum $msgnum,$destMbx)"); 1037 $stat=0; 1038 last; 1039 } 1040 elsif 1041 ($response =~ /^\*\s+$msgnum\s+FETCH\s+\(.*RFC822\s+\{[0-9]+\}/i) { 1042 ($len) = ($response =~ /^\*\s+$msgnum\s+FETCH\s+\(.*RFC822\s+\{([0-9]+)\}/i); 1043 $cc = 0; 1044 $$message = ""; 1045 while ( $cc < $len ) { 1046 $n = 0; 1047 $n = read ($conn, $segment, $len - $cc); 1048 if ( $n == 0 ) { 1049 Log ("unable to read $len bytes"); 1050 resume(); 1051 return 0; 1052 } 1053 $$message .= $segment; 1054 $cc += $n; 1055 } 1056 } 1057 } 1058 1059 return 1; 1060} 1061 1062 1063sub usage { 1064 1065 print STDOUT "usage:\n"; 1066 print STDOUT " imapcopy -S sourceHost/sourceUser/sourcePassword [/CRAM-MD5]\n"; 1067 print STDOUT " -D destHost/destUser/destPassword [/CRAM-MD5]\n"; 1068 print STDOUT " -d debug\n"; 1069 print STDOUT " -I show IMAP protocol exchanges\n"; 1070 print STDOUT " -L logfile\n"; 1071 print STDOUT " -m mailbox list (eg \"Inbox, Drafts, Notes\". Default is all mailboxes)\n"; 1072 print STDOUT " -R include submailboxes when used with -m\n\n"; 1073 print STDOUT " -e exclude mailbox list\n"; 1074 print STDOUT " -r remove msgs from source mbx after copying\n"; 1075 print STDOUT " -p <mailbox> put copied mailboxes under a root mailbox\n"; 1076 print STDOUT " -A <mailbox> copy to local mailbox from scrmbx\n"; 1077 print STDOUT " -x <mbx delimiter [mbx prefix]> source (eg, -x '. INBOX.'\n"; 1078 print STDOUT " -y <mbx delimiter [mbx prefix]> destination\n"; 1079 print STDOUT " -i initialize mailbox (remove existing messages first\n"; 1080 print STDOUT " -M <file> mailbox map file. Maps src mbxs to dst mbxs. "; 1081 print STDOUT "Each line in the file should be 'src mbx:dst mbx'\n"; 1082 print STDOUT " -q quiet mode (still writes to the logfile)\n"; 1083 print STDOUT " -t <timeout in seconds>\n"; 1084 print STDOUT " -T copy custom flags (eg, \$Label1,\$MDNSent,etc)\n"; 1085 print STDOUT " -a <DD-MMM-YYYY> copy only messages after this date\n"; 1086 print STDOUT " -b <DD-MMM-YYYY> copy only messages before this date\n"; 1087 print STDOUT " -X <megabytes> Skip any message exceeding this size\n"; 1088 print STDOUT " -U update mode, don't copy messages that already exist\n"; 1089 print STDOUT " -B <msgnum> Starting point for message fetch\n"; 1090 print STDOUT " -E <msgnum> Ending point for message fetch\n"; 1091 exit; 1092 1093} 1094 1095sub processArgs { 1096 1097 if ( !getopts( "dS:D:L:m:hIp:M:rqx:y:e:Rt:Tia:b:X:vP:A:UB:E:" ) ) { 1098 usage(); 1099 } 1100 if ( $opt_S =~ /\\/ ) { 1101 ($sourceHost, $sourceUser, $sourcePwd,$srcMethod) = split(/\\/, $opt_S); 1102 } else { 1103 ($sourceHost, $sourceUser, $sourcePwd,$srcMethod) = split(/\//, $opt_S); 1104 } 1105 if ( $opt_D =~ /\\/ ) { 1106 ($destHost, $destUser, $destPwd,$dstMethod) = split(/\\/, $opt_D); 1107 } else { 1108 ($destHost, $destUser, $destPwd,$dstMethod) = split(/\//, $opt_D); 1109 } 1110 1111 $mbxList = $opt_m; 1112 $logfile = $opt_L; 1113 $root_mbx = $opt_p; 1114 $timeout = $opt_t; 1115 $tags = $opt_T; 1116 $debug = 1 if $opt_d; 1117 $verbose = 1 if $opt_v; 1118 $showIMAP = 1 if $opt_I; 1119 $submbxs = 1 if $opt_R; 1120 $init_mbx = 1 if $opt_i; 1121 $quiet_mode = 1 if $opt_q; 1122 $update = 1 if $opt_U; 1123 $include_nosel_mbxs = 1 if $opt_s; 1124 $rem_src_msgs = 1 if $opt_r; 1125 $mbx_map_fn = $opt_M; 1126 $excludeMbxs = $opt_e; 1127 $sent_after = $opt_a; 1128 $sent_before = $opt_b; 1129 $max_size = $opt_X; 1130 $public_mbxs = $opt_P; 1131 $archive_mbx = $opt_A; 1132 $start_fetch = $opt_B; 1133 $end_fetch = $opt_E; 1134 $timeout = 300 unless $timeout; 1135 1136 Log("Running in update mode") if $update; 1137 1138 validate_date( $sent_after ) if $sent_after; 1139 validate_date( $sent_before ) if $sent_before; 1140 usage() if $opt_h; 1141 1142} 1143 1144sub selectMbx { 1145 1146my $mbx = shift; 1147my $conn = shift; 1148 1149 # Some IMAP clients such as Outlook and Netscape) do not automatically list 1150 # all mailboxes. The user must manually subscribe to them. This routine 1151 # does that for the user by marking the mailbox as 'subscribed'. 1152 1153 sendCommand( $conn, "1 SUBSCRIBE \"$mbx\""); 1154 while ( 1 ) { 1155 readResponse( $conn ); 1156 if ( $response =~ /^1 OK/i ) { 1157 Log("Mailbox $mbx has been subscribed") if $debug; 1158 last; 1159 } elsif ( $response =~ /^1 NO|^1 BAD|\^* BYE/i ) { 1160 Log("Unexpected response to subscribe $mbx command: $response"); 1161 last; 1162 } 1163 } 1164 1165 # Now select the mailbox 1166 sendCommand( $conn, "1 SELECT \"$mbx\""); 1167 while ( 1 ) { 1168 readResponse( $conn ); 1169 if ( $response =~ /^1 OK/i ) { 1170 last; 1171 } elsif ( $response =~ /^1 NO|^1 BAD|^\* BYE/i ) { 1172 Log("Unexpected response to SELECT $mbx command: $response"); 1173 last; 1174 } 1175 } 1176 1177} 1178 1179sub namespace { 1180 1181my $conn = shift; 1182my $prefix = shift; 1183my $delimiter = shift; 1184my $mbx_delim = shift; 1185 1186 # Query the server with NAMESPACE so we can determine its 1187 # mailbox prefix (if any) and hierachy delimiter. 1188 1189 if ( $mbx_delim ) { 1190 # The user has supplied a mbx delimiter and optionally a prefix. 1191 Log("Using user-supplied mailbox hierarchy delimiter $mbx_delim"); 1192 ($$delimiter,$$prefix) = split(/\s+/, $mbx_delim); 1193 return; 1194 } 1195 1196 @response = (); 1197 sendCommand( $conn, "1 NAMESPACE"); 1198 while ( 1 ) { 1199 readResponse( $conn ); 1200 if ( $response =~ /^1 OK/i ) { 1201 last; 1202 } elsif ( $response =~ /^1 NO|^1 BAD|^\* BYE/i ) { 1203 Log("Unexpected response to NAMESPACE command: $response"); 1204 last; 1205 } 1206 } 1207 1208 foreach $_ ( @response ) { 1209 if ( /NAMESPACE/i ) { 1210 my $i = index( $_, '((' ); 1211 my $j = index( $_, '))' ); 1212 my $val = substr($_,$i+2,$j-$i-3); 1213 ($val) = split(/\)/, $val); 1214 ($$prefix,$$delimiter) = split( / /, $val ); 1215 $$prefix =~ s/"//g; 1216 $$delimiter =~ s/"//g; 1217 1218 # Experimental 1219 if ( $public_mbxs ) { 1220 # Figure out the public mailbox settings 1221 /\(\((.+)\)\)\s+\(\((.+)\s+\(\((.+)\)\)/; 1222 $public = $3; 1223 $public =~ /"(.+)"\s+"(.+)"/; 1224 $src_public_prefix = $1 if $conn eq $src; 1225 $src_public_delim = $2 if $conn eq $src; 1226 $dst_public_prefix = $1 if $conn eq $dst; 1227 $dst_public_delim = $2 if $conn eq $dst; 1228 } 1229 last; 1230 } 1231 last if /^1 NO|^1 BAD|^\* BYE/; 1232 } 1233 1234 unless ( $$delimiter ) { 1235 # NAMESPACE command is not supported by the server 1236 # so we will have to figure it out another way. 1237 $delim = getDelimiter( $conn ); 1238 $$delimiter = $delim; 1239 $$prefix = ''; 1240 } 1241 1242 if ( $debug ) { 1243 Log("prefix >$$prefix<"); 1244 Log("delim >$$delimiter<"); 1245 } 1246} 1247 1248sub mailboxName { 1249 1250my $srcmbx = shift; 1251my $srcPrefix = shift; 1252my $srcDelim = shift; 1253my $dstPrefix = shift; 1254my $dstDelim = shift; 1255my $dstmbx; 1256my $substChar = '_'; 1257 1258 if ( $public_mbxs ) { 1259 my ($public_src,$public_dst) = split(/:/, $public_mbxs ); 1260 # If the mailbox starts with the public mailbox prefix then 1261 # map it to the public mailbox destination prefix 1262 1263 if ( $srcmbx =~ /^$public_src/ ) { 1264 Log("src: $srcmbx is a public mailbox") if $debug; 1265 $dstmbx = $srcmbx; 1266 $dstmbx =~ s/$public_src/$public_dst/; 1267 Log("dst: $dstmbx") if $debug; 1268 return $dstmbx; 1269 } 1270 } 1271 1272 # Change the mailbox name if the user has supplied mapping rules. 1273 1274 if ( $mbx_map{"$srcmbx"} ) { 1275 $srcmbx = $mbx_map{"$srcmbx"} 1276 } 1277 1278 # Adjust the mailbox name if the source and destination server 1279 # have different mailbox prefixes or hierarchy delimiters. 1280 1281 if ( ($srcmbx =~ /[$dstDelim]/) and ($dstDelim ne $srcDelim) ) { 1282 # The mailbox name has a character that is used on the destination 1283 # as a mailbox hierarchy delimiter. We have to replace it. 1284 $srcmbx =~ s^[$dstDelim]^$substChar^g; 1285 } 1286 1287 if ( $debug ) { 1288 Log("src mbx $srcmbx"); 1289 Log("src prefix $srcPrefix"); 1290 Log("src delim $srcDelim"); 1291 Log("dst prefix $dstPrefix"); 1292 Log("dst delim $dstDelim"); 1293 } 1294 1295 $srcmbx =~ s/^$srcPrefix//; 1296 $srcmbx =~ s/\\$srcDelim/\//g; 1297 1298 if ( ($srcPrefix eq $dstPrefix) and ($srcDelim eq $dstDelim) ) { 1299 # No adjustments necessary 1300 # $dstmbx = $srcmbx; 1301 if ( lc( $srcmbx ) eq 'inbox' ) { 1302 $dstmbx = $srcmbx; 1303 } else { 1304 $dstmbx = $srcPrefix . $srcmbx; 1305 } 1306 if ( $root_mbx ) { 1307 # Put folders under a 'root' folder on the dst 1308 $dstmbx =~ s/^$dstPrefix//; 1309 $dstDelim =~ s/\./\\./g; 1310 $dstmbx =~ s/^$dstDelim//; 1311 $dstmbx = $dstPrefix . $root_mbx . $dstDelim . $dstmbx; 1312 if ( uc($srcmbx) eq 'INBOX' ) { 1313 # Special case for the INBOX 1314 $dstmbx =~ s/INBOX$//i; 1315 $dstmbx =~ s/$dstDelim$//; 1316 } 1317 $dstmbx =~ s/\\//g; 1318 } 1319 return $dstmbx; 1320 } 1321 1322 $srcmbx =~ s#^$srcPrefix##; 1323 $dstmbx = $srcmbx; 1324 1325 if ( $srcDelim ne $dstDelim ) { 1326 # Need to substitute the dst's hierarchy delimiter for the src's one 1327 $srcDelim = '\\' . $srcDelim if $srcDelim eq '.'; 1328 $dstDelim = "\\" . $dstDelim if $dstDelim eq '.'; 1329 $dstmbx =~ s#$srcDelim#$dstDelim#g; 1330 $dstmbx =~ s/\\//g; 1331 } 1332 if ( $srcPrefix ne $dstPrefix ) { 1333 # Replace the source prefix with the dest prefix 1334 $dstmbx =~ s#^$srcPrefix## if $srcPrefix; 1335 if ( $dstPrefix ) { 1336 $dstmbx = "$dstPrefix$dstmbx" unless uc($srcmbx) eq 'INBOX'; 1337 } 1338 $dstDelim = "\\$dstDelim" if $dstDelim eq '.'; 1339 $dstmbx =~ s#^$dstDelim##; 1340 } 1341 1342 if ( $root_mbx ) { 1343 # Put folders under a 'root' folder on the dst 1344 $dstDelim =~ s/\./\\./g; 1345 $dstmbx =~ s/^$dstPrefix//; 1346 $dstmbx =~ s/^$dstDelim//; 1347 $dstmbx = $dstPrefix . $root_mbx . $dstDelim . $dstmbx; 1348 if ( uc($srcmbx) eq 'INBOX' ) { 1349 # Special case for the INBOX 1350 $dstmbx =~ s/INBOX$//i; 1351 $dstmbx =~ s/$dstDelim$//; 1352 } 1353 $dstmbx =~ s/\\//g; 1354 } 1355 1356 return $dstmbx; 1357} 1358 1359sub flags { 1360 1361my $flags = shift; 1362my @newflags; 1363my $newflags; 1364 1365 # Make sure the flags list contains standard 1366 # IMAP flags and optionally custom tags 1367 1368 return unless $flags; 1369 1370 $flags =~ s/\\Recent//i; 1371 foreach $_ ( split(/\s+/, $flags) ) { 1372 push( @newflags, $_ ) if substr($_,0,1) eq '\\'; 1373 if ( $opt_T ) { 1374 # Include user-defined flags 1375 push( @newflags, $_ ) if substr($_,0,1) eq '$'; 1376 } 1377 } 1378 1379 $newflags = join( ' ', @newflags ); 1380 1381 $newflags =~ s/\\Deleted//ig if $opt_r; 1382 $newflags =~ s/^\s+|\s+$//g; 1383 1384 return $newflags; 1385} 1386 1387sub map_mbx_names { 1388 1389my $mbx_map = shift; 1390my $srcDelim = shift; 1391my $dstDelim = shift; 1392 1393 # The -M <file> argument causes imapcopy to read the 1394 # contents of a file with mappings between source and 1395 # destination mailbox names. This permits the user to 1396 # to change the name of a mailbox when copying messages. 1397 # 1398 # The lines in the file should be formatted as: 1399 # <source mailbox name>: <destination mailbox name> 1400 # For example: 1401 # Drafts/2008/Save: Draft_Messages/2008/Save 1402 # Action Items: Inbox 1403 # 1404 # Note that if the names contain non-ASCII characters such 1405 # as accents or diacritical marks then the Perl module 1406 # Unicode::IMAPUtf7 module must be installed. 1407 1408 return unless $mbx_map_fn; 1409 1410 unless ( open(MAP, "<$mbx_map_fn") ) { 1411 Log("Error opening mbx map file $mbx_map_fn: $!"); 1412 exit; 1413 } 1414 $use_utf7 = 0; 1415 while( <MAP> ) { 1416 chomp; 1417 s/[\r\n]$//; # In case we're on Windows 1418 s/^\s+//; 1419 next if /^#/; 1420 next unless $_; 1421 ($srcmbx,$dstmbx) = split(/\s*:\s*/, $_); 1422 1423 # Unless the mailbox name is entirely ASCII we'll have to use 1424 # the Modified UTF-7 character set. 1425 $use_utf7 = 1 unless isAscii( $srcmbx ); 1426 $use_utf7 = 1 unless isAscii( $dstmbx ); 1427 1428 $srcmbx =~ s/\//$srcDelim/g; 1429 $dstmbx =~ s/\//$dstDelim/g; 1430 1431 $$mbx_map{"$srcmbx"} = $dstmbx; 1432 1433 } 1434 close MAP; 1435 1436 if ( $use_utf7 ) { 1437 eval 'use Unicode::IMAPUtf7'; 1438 if ( $@ ) { 1439 Log("At least one mailbox map contains non-ASCII characters. This means you"); 1440 Log("have to install the Perl Unicode::IMAPUtf7 module in order to map mailbox "); 1441 Log("names between the source and destination servers."); 1442 print "At least one mailbox map contains non-ASCII characters. This means you\n"; 1443 print "have to install the Perl Unicode::IMAPUtf7 module in order to map mailbox\n"; 1444 print "names between the source and destination servers.\n"; 1445 exit; 1446 } 1447 } 1448 1449 my %temp; 1450 foreach $srcmbx ( keys %$mbx_map ) { 1451 $dstmbx = $$mbx_map{"$srcmbx"}; 1452 Log("Mapping src:$srcmbx to dst:$dstmbx"); 1453 if ( $use_utf7 ){ 1454 # Encode the name in Modified UTF-7 charset 1455 $srcmbx = Unicode::IMAPUtf7::imap_utf7_encode( $srcmbx ); 1456 $dstmbx = Unicode::IMAPUtf7::imap_utf7_encode( $dstmbx ); 1457 } 1458 $temp{"$srcmbx"} = $dstmbx; 1459 } 1460 %$mbx_map = %temp; 1461 %temp = (); 1462 1463} 1464 1465sub isAscii { 1466 1467my $str = shift; 1468my $ascii = 1; 1469 1470 # Determine whether a string contains non-ASCII characters 1471 1472 my $test = $str; 1473 $test=~s/\P{IsASCII}/?/g; 1474 $ascii = 0 unless $test eq $str; 1475 1476 return $ascii; 1477 1478} 1479 1480sub getDelimiter { 1481 1482my $conn = shift; 1483my $delimiter; 1484 1485 # Issue a 'LIST "" ""' command to find out what the 1486 # mailbox hierarchy delimiter is. 1487 1488 sendCommand ($conn, '1 LIST "" ""'); 1489 @response = ''; 1490 while ( 1 ) { 1491 readResponse ($conn); 1492 if ( $response =~ /^1 OK/i ) { 1493 last; 1494 } 1495 elsif ( $response !~ /^\*/ ) { 1496 Log ("unexpected response: $response"); 1497 return 0; 1498 } 1499 } 1500 1501 for $i (0 .. $#response) { 1502 $response[$i] =~ s/\s+/ /; 1503 if ( $response[$i] =~ /\* LIST \((.*)\) "(.*)" "(.*)"/i ) { 1504 $delimiter = $2; 1505 } 1506 } 1507 1508 return $delimiter; 1509} 1510 1511# Reconnect to the servers after a timeout error. 1512# 1513sub reconnect { 1514 1515my $checkpoint = shift; 1516my $conn = shift; 1517 1518 Log("Attempting to reconnect"); 1519 1520 my ($mbx,$shost,$suser,$spwd,$dhost,$duser,$dpwd) = split(/\|/, $checkpoint); 1521 1522 close $src; 1523 close $dst; 1524 1525 connectToHost($shost,\$src); 1526 login($suser,$spwd,$shost,$src); 1527 1528 connectToHost($dhost,\$dst); 1529 login($duser,$dpwd,$dhost,$dst); 1530 1531 selectMbx( $mbx, $src ); 1532 createMbx( $mbx, $dst ); # Just in case 1533 1534} 1535 1536# Handle signals 1537 1538sub signalHandler { 1539 1540my $sig = shift; 1541 1542 if ( $sig eq 'ALRM' ) { 1543 Log("Caught a SIG$sig signal, timeout error"); 1544 $conn_timed_out = 1; 1545 } else { 1546 Log("Caught a SIG$sig signal, shutting down"); 1547 exit; 1548 } 1549 Log("Resuming"); 1550} 1551 1552sub fixup_date { 1553 1554my $date = shift; 1555 1556 # Make sure the hrs part of the date is 2 digits. At least 1557 # one IMAP server expects this. 1558 1559 $$date =~ s/^\s+//; 1560 $$date =~ /(.+) (.+):(.+):(.+) (.+)/; 1561 my $hrs = $2; 1562 1563 return if length( $hrs ) == 2; 1564 1565 my $newhrs = '0' . $hrs if length( $hrs ) == 1; 1566 $$date =~ s/ $hrs/ $newhrs/; 1567 1568} 1569 1570sub init_mbx { 1571 1572my $mbx = shift; 1573my $conn = shift; 1574my @msgs; 1575 1576 # Remove all messages from a mailbox 1577 1578 Log("Initializing mailbox $mbx"); 1579 getMsgList( $mbx, \@msgs, $conn, 'SELECT' ); 1580 my $msgcount = $#msgs + 1; 1581 Log("$mbx has $msgcount messages"); 1582 1583 return if $msgcount == 0; # No messages to delete 1584 1585 foreach my $msgnum ( @msgs ) { 1586 ($msgnum) = split(/\|/, $msgnum); 1587 delete_msg( $msgnum, $conn ); 1588 } 1589 expungeMbx( $mbx, $conn ); 1590 1591} 1592 1593sub delete_msg_list { 1594 1595my $msgnums = shift; 1596my $mbx = shift; 1597my $conn = shift; 1598my $rc; 1599 1600 # Mark a set of messages for deletion 1601 1602 selectMbx( $mbx, $conn ); 1603 1604 foreach my $msgnum ( split(/\s+/, $msgnums ) ) { 1605 sendCommand ( $conn, "1 STORE $msgnum +FLAGS (\\Deleted)"); 1606 while (1) { 1607 readResponse ($conn); 1608 if ( $response =~ /^1 OK/i ) { 1609 $rc = 1; 1610 Log(" Marked msg number $msgnum for delete") if $debug; 1611 last; 1612 } 1613 1614 if ( $response =~ /^1 BAD|^1 NO/i ) { 1615 Log("Error setting \Deleted flag for msg $msgnum: $response"); 1616 $rc = 0; 1617 last; 1618 } 1619 } 1620 } 1621 1622 return $rc; 1623 1624} 1625 1626sub expungeMbx { 1627 1628my $mbx = shift; 1629my $conn = shift; 1630 1631 Log("Expunging mailbox $mbx"); 1632 1633 sendCommand ($conn, "1 SELECT \"$mbx\""); 1634 while (1) { 1635 readResponse ($conn); 1636 last if ( $response =~ /1 OK/i ); 1637 } 1638 1639 sendCommand ( $conn, "1 EXPUNGE"); 1640 $expunged=0; 1641 while (1) { 1642 readResponse ($conn); 1643 $expunged++ if $response =~ /\* (.+) Expunge/i; 1644 last if $response =~ /^1 OK/; 1645 1646 if ( $response =~ /^1 BAD|^1 NO/i ) { 1647 Log("Error purging messages: $response"); 1648 last; 1649 } 1650 } 1651 1652 $totalExpunged += $expunged; 1653 1654 Log("$expunged messages expunged"); 1655 1656} 1657 1658sub cram_md5 { 1659 1660my $challenge = shift; 1661my $user = shift; 1662my $password = shift; 1663 1664eval 'use Digest::HMAC_MD5 qw(hmac_md5_hex)'; 1665use MIME::Base64 qw(decode_base64 encode_base64); 1666 1667 # Adapated from script by Paul Makepeace <http://paulm.com>, 2002-10-12 1668 # Takes user, key, and base-64 encoded challenge and returns base-64 1669 # encoded CRAM. See, 1670 # IMAP/POP AUTHorize Extension for Simple Challenge/Response: 1671 # RFC 2195 http://www.faqs.org/rfcs/rfc2195.html 1672 # SMTP Service Extension for Authentication: 1673 # RFC 2554 http://www.faqs.org/rfcs/rfc2554.html 1674 # Args: tim tanstaaftanstaaf PDE4OTYuNjk3MTcwOTUyQHBvc3RvZmZpY2UucmVzdG9uLm1jaS5uZXQ+ 1675 # should yield: dGltIGI5MTNhNjAyYzdlZGE3YTQ5NWI0ZTZlNzMzNGQzODkw 1676 1677 my $challenge_data = decode_base64($challenge); 1678 my $hmac_digest = hmac_md5_hex($challenge_data, $password); 1679 my $response = encode_base64("$user $hmac_digest"); 1680 chomp $response; 1681 1682 if ( $debug ) { 1683 Log("Challenge: $challenge_data"); 1684 Log("HMAC digest: $hmac_digest"); 1685 Log("CRAM Base64: $response"); 1686 } 1687 1688 return $response; 1689} 1690 1691sub validate_date { 1692 1693my $date = shift; 1694my $invalid; 1695 1696 # Make sure the "after" date is in DD-MMM-YYYY format 1697 1698 my ($day,$month,$year) = split(/-/, $date); 1699 $invalid = 1 unless ( $day > 0 and $day < 32 ); 1700 $invalid = 1 unless $month =~ /Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec/i; 1701 $invalid = 1 unless $year > 1900 and $year < 2999; 1702 if ( $invalid ) { 1703 Log("The 'Sent after' date $date must be in DD-MMM-YYYY format"); 1704 exit; 1705 } 1706} 1707 1708sub commafy { 1709 1710my $number = shift; 1711 1712 $_ = $$number; 1713 1 while s/^([-+]?\d+)(\d{3})/$1,$2/; 1714 1715 $$number = $_; 1716 1717} 1718 1719sub delete_msg { 1720 1721my $msgnum = shift; 1722my $conn = shift; 1723my $rc; 1724 1725 sendCommand ( $conn, "1 STORE $msgnum +FLAGS (\\Deleted)"); 1726 while (1) { 1727 readResponse ($conn); 1728 if ( $response =~ /^1 OK/i ) { 1729 $rc = 1; 1730 Log(" Marked msg number $msgnum for delete") if $debug; 1731 last; 1732 } 1733 1734 if ( $response =~ /^1 BAD|^1 NO/i ) { 1735 Log("Error setting \Deleted flag for msg $msgnum: $response"); 1736 $rc = 0; 1737 last; 1738 } 1739 } 1740 1741 return $rc; 1742 1743 1744 1745} 1746 1747 1748sub resume { 1749 1750 # Disconnect, re-connect, and log back in. 1751 1752 Log("Fatal error, lost connection to either the source or destination"); 1753 # Log("checkpoint $checkpoint"); 1754 Log("LAST $LAST"); 1755 my ($mbx,$msgnum) = split(/\|/, $LAST); 1756 Log("mbx $mbx"); 1757 Log("Disconnect from the source and destination servers"); 1758 1759 close $src; 1760 close $dst; 1761 1762 Log("Sleeping 15 seconds before reconnecting"); 1763 sleep 15; 1764 1765 Log("Reconnect to source server and log back in"); 1766 connectToHost($sourceHost, \$src) or exit; 1767 login($sourceUser,$sourcePwd, $sourceHost, $src, $srcMethod) or exit; 1768 selectMbx( $mbx, $src ); 1769 1770 Log("Reconnect to destination server and log back in"); 1771 connectToHost( $destHost, \$dst ) or exit; 1772 login( $destUser,$destPwd, $destHost, $dst, $dstMethod ) or exit; 1773 Log("Resuming"); 1774 1775 # Just in case we were creating a mailbox when the connection 1776 # was lost check and recreate it if necessary 1777 1778Log("does $mbx exist?"); 1779 createMbx( $mbx, $dst ) unless mbxExists( $mbx, $dst ); 1780 1781 return; 1782 1783} 1784 1785 1786# getMsgIdList 1787# 1788# Get a list of the user's messages in a mailbox 1789# 1790sub getMsgIdList { 1791 1792my $mailbox = shift; 1793my $msgids = shift; 1794my $conn = shift; 1795my $empty; 1796my $msgnum; 1797my $from; 1798my $msgid; 1799 1800 %$msgids = (); 1801 sendCommand ($conn, "1 EXAMINE \"$mailbox\""); 1802 undef @response; 1803 $empty=0; 1804 while ( 1 ) { 1805 readResponse ( $conn ); 1806 if ( $response =~ / 0 EXISTS/i ) { $empty=1; } 1807 if ( $response =~ /^1 OK/i ) { 1808 # print STDERR "response $response\n"; 1809 last; 1810 } 1811 elsif ( $response !~ /^\*/ ) { 1812 Log ("unexpected response: $response"); 1813 # print STDERR "Error: $response\n"; 1814 return 0; 1815 } 1816 } 1817 1818 if ( $empty ) { 1819 return; 1820 } 1821 1822 Log("Fetch the header info") if $debug; 1823 1824 sendCommand ( $conn, "1 FETCH 1:* (body[header.fields (Message-Id)])"); 1825 undef @response; 1826 while ( 1 ) { 1827 readResponse ( $conn ); 1828 return if $conn_timed_out; 1829 if ( $response =~ /^1 OK/i ) { 1830 last; 1831 } elsif ( $response =~ /could not be processed/i ) { 1832 Log("Error: response from server: $response"); 1833 return; 1834 } elsif ( $response =~ /^1 NO|^1 BAD/i ) { 1835 return; 1836 } 1837 } 1838 1839 $flags = ''; 1840 for $i (0 .. $#response) { 1841 $_ = $response[$i]; 1842 1843 last if /OK FETCH complete/; 1844 1845 if ($response[$i] =~ /Message-ID:/i) { 1846 $response[$i] =~ /Message-Id: (.+)/i; 1847 $msgid = $1; 1848 trim(*msgid); 1849 if ( $msgid eq '' ) { 1850 # Line-wrap, get it from the next line 1851 $msgid = $response[$i+1]; 1852 trim(*msgid); 1853 } 1854 $$msgids{"$msgid"} = 1; 1855 } 1856 } 1857 1858} 1859 1860sub encode_ampersand { 1861 1862my $mbx = shift; 1863 1864 # The IMAP RFC requires mailbox names with '&' be 1865 # encoded as '&-' 1866 1867 # The problem with this routine is a mailbox name may be 1868 # encoded in Mod UTF7 which uses the '&' character for its 1869 # own purposes, eg r&AOk-pertoire_XXX. We have to leave it 1870 # alone. Anyway, this code was inserted because of an IMAP 1871 # server which did not do its job so the usefulness of this 1872 # conversion is limited. 1873 1874 if ( $$mbx =~ /\&/ ) { 1875 if ( $$mbx !~ /\&-/ ) { 1876 # Need to encode the '&' as '&-' 1877 $$mbx =~ s/\&/\&-/g; 1878 Log("Encoded $$mbx"); 1879 } 1880 } 1881 1882} 1883