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