1#!/usr/local/bin/perl
2
3# $Header: /mhub4/sources/imap-tools/migrateIMAP-win.pl,v 1.8 2010/06/15 15:03:27 rick Exp $
4
5#######################################################################
6#   Description                                                       #
7#                                                                     #
8#   migrateIMAP is a utility for copying messages for a number        #
9#   on users from one IMAP server to another.                         #
10#                                                                     #
11#   imapcopy is called like this:                                     #
12#      ./imapcopy -S host1 -D host2 -i <user list>                    #
13#                                                                     #
14#   The user list file should contain entries like this:              #
15#       sourceUser1:password:destinationUser1:password                #
16#       sourceUser2:password:destinationUser2:password                #
17#       etc                                                           #
18#   Optional arguments:                                               #
19#	-d debug                                                      #
20#       -L logfile                                                    #
21#######################################################################
22
23use Socket;
24use FileHandle;
25use Fcntl;
26use Getopt::Std;
27use IO::Socket;
28
29#################################################################
30#            Main program.                                      #
31#################################################################
32
33&init();
34
35&getUserList( \@users );
36foreach $user ( @users ) {
37   ($sourceUser,$sourcePwd,$destUser,$destPwd) = split(/ /, $user);
38   &Log("Migrating $sourceUser on $sourceHost to $destUser on $destHost");
39
40   #  Get list of all messages on the source host
41   #
42   next unless &connectToHost($sourceHost,\$src);
43   next unless &login($sourceHost,$sourceUser,$sourcePwd,$src);
44   namespace( $src, \$srcPrefix, \$srcDelim );
45
46   next unless &connectToHost( $destHost, \$dst );
47   next unless &login( $destHost,$destUser,$destPwd, $dst );
48   namespace( $dst, \$dstPrefix, \$dstDelim );
49
50   @mbxs = &getMailboxList($sourceUser, $src);
51   foreach $srcmbx ( @mbxs ) {
52        $dstmbx = mailboxName( $srcmbx,$srcPrefix,$srcDelim,$dstPrefix,$dstDelim );
53        &createMbx( $dstmbx, $dst );
54        &selectMbx( $dstmbx, $dst );
55        &Log("   Copying messages in $dstmbx mailbox");
56	&getMsgList( $srcmbx, \@msgs, $src );
57        if ( $#msgs == -1 ) {
58           &Log("   $srcmbx mailbox is empty");
59           next;
60        }
61
62        $copied=0;
63        foreach $_ ( @msgs ) {
64           ($msgnum,$date,$flags) = split(/\|/, $_);
65           $message = &fetchMsg( $msgnum, $srcmbx, $src );
66           $copied++ if insertMsg( $dstmbx, *message, $flags, $date, $dst );
67        }
68        $total += $copied;
69        &Log("   Copied $copied messages to $dstmbx");
70   }
71
72   &logout( $src );
73   &logout( $dst );
74   $usersmigrated++;
75}
76
77&Log("$usersmigrated users migrated, $total total messages copied");
78exit;
79
80
81sub init {
82
83   $version = 'V2.0.2';
84   $os = $ENV{'OS'};
85
86   &processArgs;
87
88   if ($timeout eq '') { $timeout = 60; }
89
90   #  Open the logFile
91   #
92   if ( $logfile ) {
93      if ( !open(LOG, ">> $logfile")) {
94         print STDOUT "Can't open $logfile: $!\n";
95      }
96      select(LOG); $| = 1;
97   }
98   &Log("$0 starting\n");
99
100   #  Determine whether we have SSL support via openSSL and IO::Socket::SSL
101   $ssl_installed = 1;
102   eval 'use IO::Socket::SSL';
103   if ( $@ ) {
104      $ssl_installed = 0;
105   }
106}
107
108sub getUserList {
109
110my $users = shift;
111
112   unless ( open(F, "<$userList") ) {
113      Log("Error opening $userList: $!");
114      exit;
115   }
116
117   while ( <F> ) {
118      next if /#/;
119      chomp;
120      $sourceUser=$sourcePwd=$destUser=$destPwd='';
121      s/\s+/ /g;
122      next unless /(.+)[\s+|:](.+)[\s+|:](.+)[\s+|:](.+)/;
123      $sourceUser = $1;
124      $sourcePwd  = $2;
125      $destUser   = $3;
126      $destPwd    = $4;
127      $destUser = $sourceUser unless $destUser;
128      $destPwd  = $sourcePwd unless $destPwd;
129      push( @$users, "$sourceUser $sourcePwd $destUser $destPwd" );
130   }
131   close F;
132
133}
134
135#
136#  sendCommand
137#
138#  This subroutine formats and sends an IMAP protocol command to an
139#  IMAP server on a specified connection.
140#
141
142sub sendCommand {
143
144my $fd = shift;
145my $cmd = shift;
146
147    print $fd "$cmd\r\n";
148
149    &Log (">> $cmd") if $showIMAP;
150}
151
152#
153#  readResponse
154#
155#  This subroutine reads and formats an IMAP protocol response from an
156#  IMAP server on a specified connection.
157#
158
159sub readResponse {
160
161my $fd = shift;
162
163    $response = <$fd>;
164    chop $response;
165    $response =~ s/\r//g;
166    push (@response,$response);
167    &Log ("<< $response") if $showIMAP;1
168}
169
170#
171#  Log
172#
173#  This subroutine formats and writes a log message to STDERR.
174#
175
176sub Log {
177
178my $str = shift;
179
180   #  If a logile has been specified then write the output to it
181   #  Otherwise write it to STDOUT
182
183   if ( $logfile ) {
184      ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
185      if ($year < 99) { $yr = 2000; }
186      else { $yr = 1900; }
187      $line = sprintf ("%.2d-%.2d-%d.%.2d:%.2d:%.2d %s %s\n",
188		     $mon + 1, $mday, $year + $yr, $hour, $min, $sec,$$,$str);
189      print LOG "$line";
190   } else {
191      print STDOUT "$str\n";
192   }
193
194}
195
196
197sub createMbx {
198
199my $mbx  = shift;
200my $conn = shift;
201
202   #  Create the mailbox if necessary
203
204   &sendCommand ($conn, "1 CREATE \"$mbx\"");
205   while ( 1 ) {
206      &readResponse ($conn);
207      last if $response =~ /^$conn OK/i;
208      if ( $response !~ /^\*/ ) {
209         if (!($response =~ /already exists|reserved mailbox name/i)) {
210            # &Log ("WARNING: $response");
211         }
212         last;
213       }
214   }
215
216}
217
218#  insertMsg
219#
220#  This routine inserts a message into a user's mailbox
221#
222sub insertMsg {
223
224local ($mbx, *message, $flags, $date, $conn) = @_;
225local ($lenx);
226
227   &Log("   Inserting message") if $debug;
228   $lenx = length($message);
229   $totalBytes = $totalBytes + $lenx;
230   $totalMsgs++;
231
232   $flags =~ s/\\Recent//i;
233
234   &sendCommand ($conn, "1 APPEND \"$mbx\" ($flags) \"$date\" \{$lenx\}");
235   &readResponse ($conn);
236   if ( $response !~ /^\+/ ) {
237       &Log ("unexpected APPEND response: $response");
238       # next;
239       push(@errors,"Error appending message to $mbx for $user");
240       return 0;
241   }
242
243   print $conn "$message\r\n";
244
245   undef @response;
246   while ( 1 ) {
247       &readResponse ($conn);
248       if ( $response =~ /^1 OK/i ) {
249	   last;
250       }
251       elsif ( $response !~ /^\*/ ) {
252	   &Log ("unexpected APPEND response: $response");
253	   # next;
254	   return 0;
255       }
256   }
257
258   return 1;
259}
260
261#  Make a connection to a IMAP host
262
263sub connectToHost {
264
265my $host = shift;
266my $conn = shift;
267
268   &Log("Connecting to $host") if $debug;
269
270   ($host,$port) = split(/:/, $host);
271   $port = 143 unless $port;
272
273   # We know whether to use SSL for ports 143 and 993.  For any
274   # other ones we'll have to figure it out.
275   $mode = sslmode( $host, $port );
276
277   if ( $mode eq 'SSL' ) {
278      unless( $ssl_installed == 1 ) {
279         warn("You must have openSSL and IO::Socket::SSL installed to use an SSL connection");
280         Log("You must have openSSL and IO::Socket::SSL installed to use an SSL connection");
281         exit;
282      }
283      Log("Attempting an SSL connection") if $debug;
284      $$conn = IO::Socket::SSL->new(
285         Proto           => "tcp",
286         SSL_verify_mode => 0x00,
287         PeerAddr        => $host,
288         PeerPort        => $port,
289      );
290
291      unless ( $$conn ) {
292        $error = IO::Socket::SSL::errstr();
293        Log("Error connecting to $host: $error");
294        exit;
295      }
296   } else {
297      #  Non-SSL connection
298      Log("Attempting a non-SSL connection") if $debug;
299      $$conn = IO::Socket::INET->new(
300         Proto           => "tcp",
301         PeerAddr        => $host,
302         PeerPort        => $port,
303      );
304
305      unless ( $$conn ) {
306        Log("Error connecting to $host:$port: $@");
307        warn "Error connecting to $host:$port: $@";
308        exit;
309      }
310   }
311   Log("Connected to $host on port $port");
312
313}
314
315sub sslmode {
316
317my $host = shift;
318my $port = shift;
319my $mode;
320
321   #  Determine whether to make an SSL connection
322   #  to the host.  Return 'SSL' if so.
323
324   if ( $port == 143 ) {
325      #  Standard non-SSL port
326      return '';
327   } elsif ( $port == 993 ) {
328      #  Standard SSL port
329      return 'SSL';
330   }
331
332   unless ( $ssl_installed ) {
333      #  We don't have SSL installed on this machine
334      return '';
335   }
336
337   #  For any other port we need to determine whether it supports SSL
338
339   my $conn = IO::Socket::SSL->new(
340         Proto           => "tcp",
341         SSL_verify_mode => 0x00,
342         PeerAddr        => $host,
343         PeerPort        => $port,
344    );
345
346    if ( $conn ) {
347       close( $conn );
348       $mode = 'SSL';
349    } else {
350       $mode = '';
351    }
352
353   return $mode;
354}
355
356
357#  trim
358#
359#  remove leading and trailing spaces from a string
360sub trim {
361
362local (*string) = @_;
363
364   $string =~ s/^\s+//;
365   $string =~ s/\s+$//;
366
367   return;
368}
369
370
371#  login
372#
373#  login in at the host with the user's name and password
374#
375sub login {
376
377my $host = shift;
378my $user = shift;
379my $pwd  = shift;
380my $conn = shift;
381
382   &sendCommand ($conn, "1 LOGIN $user $pwd");
383   while (1) {
384	&readResponse ( $conn );
385	last if $response =~ /^1 OK/i;
386	if ($response =~ /NO|BAD/i) {
387           &Log ("Failed to login at $host as $user.  Check username & password");
388           return 0;
389	}
390   }
391   &Log("Logged in as $user") if $debug;
392
393   return 1;
394}
395
396
397#  logout
398#
399#  log out from the host
400#
401sub logout {
402
403my $conn = shift;
404
405   undef @response;
406   &sendCommand ($conn, "1 LOGOUT");
407   while ( 1 ) {
408	&readResponse ($conn);
409	if ( $response =~ /^1 OK/i ) {
410		last;
411	}
412	elsif ( $response !~ /^\*/ ) {
413		&Log ("unexpected LOGOUT response: $response");
414		last;
415	}
416   }
417   close $conn;
418   return;
419}
420
421
422#  getMailboxList
423#
424#  get a list of the user's mailboxes from the source host
425#
426sub getMailboxList {
427
428my $user = shift;
429my $conn = shift;
430my @mbxs;
431my @mailboxes;
432
433   #  Get a list of the user's mailboxes
434   #
435  if ( $mbxList ) {
436      #  The user has supplied a list of mailboxes so only processes
437      #  the ones in that list
438      @mbxs = split(/,/, $mbxList);
439      foreach $mbx ( @mbxs ) {
440         &trim( *mbx );
441         push( @mailboxes, $mbx );
442      }
443      return @mailboxes;
444   }
445
446   if ($debugMode) { &Log("Get list of user's mailboxes",2); }
447
448   &sendCommand ($conn, "1 LIST \"\" *");
449   undef @response;
450   while ( 1 ) {
451	&readResponse ($conn);
452	if ( $response =~ /^1 OK/i ) {
453		last;
454	}
455	elsif ( $response !~ /^\*/ ) {
456		&Log ("unexpected response: $response");
457		return 0;
458	}
459   }
460
461   undef @mbxs;
462   for $i (0 .. $#response) {
463	# print STDERR "$response[$i]\n";
464
465        if ( $response[$i] =~ /"$/ ) {
466           $response[$i] =~ /\* LIST \((.*)\) "(.+)" "(.+)"/i;
467           $mbx = $3;
468        } else {
469           $response[$i] =~ /\* LIST \((.*)\) "(.+)" (.+)/i;
470           $mbx = $3;
471        }
472	$mbx =~ s/^\s+//;  $mbx =~ s/\s+$//;
473	$mbx =~ s/"//g;
474
475	if ($response[$i] =~ /NOSELECT/i) {
476		if ($debugMode) { &Log("$mbx is set NOSELECT,skip it",2); }
477		next;
478	}
479	if (($mbx =~ /^\#/) && ($user ne 'anonymous')) {
480		#  Skip public mbxs unless we are migrating them
481		next;
482	}
483	if ($mbx =~ /^\./) {
484		# Skip mailboxes starting with a dot
485		next;
486	}
487	push ( @mbxs, $mbx ) if $mbx ne '';
488   }
489
490   if ( $mbxList ) {
491      #  The user has supplied a list of mailboxes so only processes
492      #  those
493      @mbxs = split(/,/, $mbxList);
494   }
495
496   return @mbxs;
497}
498
499#  getMsgList
500#
501#  Get a list of the user's messages in the indicated mailbox on
502#  the source host
503#
504sub getMsgList {
505
506my $mailbox = shift;
507my $msgs    = shift;
508my $conn    = shift;
509my $seen;
510my $empty;
511my $msgnum;
512my $from;
513my $flags;
514
515   &trim( *mailbox );
516   &sendCommand ($conn, "1 EXAMINE \"$mailbox\"");
517   undef @response;
518   $empty=0;
519   while ( 1 ) {
520	&readResponse ( $conn );
521	if ( $response =~ / 0 EXISTS/i ) { $empty=1; }
522	if ( $response =~ /^1 OK/i ) {
523		# print STDERR "response $response\n";
524		last;
525	}
526	elsif ( $response !~ /^\*/ ) {
527		&Log ("unexpected response: $response");
528		# print STDERR "Error: $response\n";
529		return 0;
530	}
531   }
532
533   &sendCommand ( $conn, "1 FETCH 1:* (uid flags internaldate body[header.fields (From Date)])");
534   undef @response;
535   while ( 1 ) {
536	&readResponse ( $conn );
537	if ( $response =~ /^1 OK/i ) {
538		# print STDERR "response $response\n";
539		last;
540	}
541        last if $response =~ /^1 NO|^1 BAD/;
542   }
543
544   @msgs  = ();
545   $flags = '';
546   for $i (0 .. $#response) {
547	$seen=0;
548	$_ = $response[$i];
549
550	last if /OK FETCH complete/;
551
552        if ($response[$i] =~ /FLAGS/) {
553           #  Get the list of flags
554           $response[$i] =~ /FLAGS \(([^\)]*)/;
555           $flags = $1;
556           $flags =~ s/\\Recent//;
557        }
558
559        if ( $response[$i] =~ /INTERNALDATE/) {
560           if ( $response[$i] =~ /"/ ) {
561              $response[$i] =~ /INTERNALDATE "(.+)" BODY/i;
562              $date = $1;
563           } else {
564              $response[$i] =~ /INTERNALDATE (.+) BODY/i;
565              $date = $1;
566           }
567           $date =~ s/"//g;
568        }
569
570        if ( $response[$i] =~ /\* (.+) FETCH/ ) {
571           ($msgnum) = split(/\s+/, $1);
572        }
573
574        if ( $msgnum && $date ) {
575	   push (@$msgs,"$msgnum|$date|$flags");
576           $msgnum = $date = '';
577        }
578   }
579
580}
581
582
583sub fetchMsg {
584
585my $msgnum = shift;
586my $mbx    = shift;
587my $conn   = shift;
588my $message;
589
590   &Log("   Fetching msg $msgnum...") if $debug;
591   &sendCommand ($conn, "1 EXAMINE \"$mbx\"");
592   while (1) {
593        &readResponse ($conn);
594	last if ( $response =~ /^1 OK/i );
595   }
596
597   &sendCommand( $conn, "1 FETCH $msgnum (rfc822)");
598   while (1) {
599	&readResponse ($conn);
600	if ( $response =~ /^1 OK/i ) {
601		$size = length($message);
602		last;
603	}
604	elsif ($response =~ /message number out of range/i) {
605		&Log ("Error fetching uid $uid: out of range",2);
606		$stat=0;
607		last;
608	}
609	elsif ($response =~ /Bogus sequence in FETCH/i) {
610		&Log ("Error fetching uid $uid: Bogus sequence in FETCH",2);
611		$stat=0;
612		last;
613	}
614	elsif ( $response =~ /message could not be processed/i ) {
615		&Log("Message could not be processed, skipping it ($user,msgnum $msgnum,$destMbx)");
616		push(@errors,"Message could not be processed, skipping it ($user,msgnum $msgnum,$destMbx)");
617		$stat=0;
618		last;
619	}
620	elsif
621	   ($response =~ /^\*\s+$msgnum\s+FETCH\s+\(.*RFC822\s+\{[0-9]+\}/i) {
622		($len) = ($response =~ /^\*\s+$msgnum\s+FETCH\s+\(.*RFC822\s+\{([0-9]+)\}/i);
623		$cc = 0;
624		$message = "";
625		while ( $cc < $len ) {
626			$n = 0;
627			$n = read ($conn, $segment, $len - $cc);
628			if ( $n == 0 ) {
629				&Log ("unable to read $len bytes");
630				return 0;
631			}
632			$message .= $segment;
633			$cc += $n;
634		}
635	}
636   }
637
638   return $message;
639
640}
641
642
643sub usage {
644
645   print STDOUT "usage:\n";
646   print STDOUT " imapcopy -S sourceHost/sourceUser/sourcePassword\n";
647   print STDOUT "          -D destHost/destUser/destPassword\n";
648   print STDOUT "          -d debug\n";
649   print STDOUT "          -L logfile\n";
650   print STDOUT "          -m mailbox list (eg \"Inbox, Drafts, Notes\". Default is all mailboxes)\n";
651   exit;
652
653}
654
655sub processArgs {
656
657   if ( !getopts( "dS:D:L:i:hIm:" ) ) {
658      &usage();
659   }
660
661   $sourceHost = $opt_S;
662   $destHost = $opt_D;
663   $userList = $opt_i;
664   $logfile = $opt_L;
665   $mbxList = $opt_m;
666   $debug = 1 if $opt_d;
667   $showIMAP = 1 if $opt_I;
668
669   &usage() if $opt_h;
670
671}
672
673sub selectMbx {
674
675my $mbx = shift;
676my $conn = shift;
677
678   #  Some IMAP clients such as Outlook and Netscape) do not automatically list
679   #  all mailboxes.  The user must manually subscribe to them.  This routine
680   #  does that for the user by marking the mailbox as 'subscribed'.
681
682   sendCommand( $conn, "1 SUBSCRIBE \"$mbx\"");
683   while ( 1 ) {
684      readResponse( $conn );
685      if ( $response =~ /^1 OK/i ) {
686         Log("Mailbox $mbx has been subscribed") if $debug;
687         last;
688      } elsif ( $response =~ /NO|BAD/i ) {
689         Log("Unexpected response to subscribe $mbx command: $response");
690         last;
691      }
692   }
693
694   #  Now select the mailbox
695   sendCommand( $conn, "1 SELECT \"$mbx\"");
696   while ( 1 ) {
697      readResponse( $conn );
698      if ( $response =~ /^1 OK/i ) {
699         last;
700      } elsif ( $response =~ /^1 NO|^1 BAD/i ) {
701         Log("Unexpected response to SELECT $mbx command: $response");
702         last;
703      }
704   }
705
706}
707
708sub namespace {
709
710my $conn      = shift;
711my $prefix    = shift;
712my $delimiter = shift;
713
714   #  Query the server with NAMESPACE so we can determine its
715   #  mailbox prefix (if any) and hierachy delimiter.
716
717   @response = ();
718   sendCommand( $conn, "1 NAMESPACE");
719   while ( 1 ) {
720      readResponse( $conn );
721      if ( $response =~ /^1 OK/i ) {
722         last;
723      } elsif ( $response =~ /NO|BAD/i ) {
724         Log("Unexpected response to NAMESPACE command: $response");
725         last;
726      }
727   }
728
729   foreach $_ ( @response ) {
730      if ( /NAMESPACE/i ) {
731         my $i = index( $_, '((' );
732         my $j = index( $_, '))' );
733         my $val = substr($_,$i+2,$j-$i-3);
734         ($$prefix,$$delimiter) = split( / /, $val );
735         $$prefix    =~ s/"//g;
736         $$delimiter =~ s/"//g;
737         last;
738      }
739      last if /^NO|^BAD/;
740   }
741
742   if ( $debug ) {
743      Log("prefix  $$prefix");
744      Log("delim   $$delimiter");
745   }
746
747}
748
749sub mailboxName {
750
751my $srcmbx    = shift;
752my $srcPrefix = shift;
753my $srcDelim  = shift;
754my $dstPrefix = shift;
755my $dstDelim  = shift;
756my $dstmbx;
757
758   #  Adjust the mailbox name if the source and destination server
759   #  have different mailbox prefixes or hierarchy delimiters.
760
761   if ( $srcmbx =~ /[$dstDelim]/ ) {
762      #  The mailbox name has a character that is used on the destination
763      #  as a mailbox hierarchy delimiter.  We have to replace it.
764      $srcmbx =~ s^[$dstDelim]^$substChar^g;
765   }
766
767   if ( $debug ) {
768      Log("src mbx      $srcmbx");
769      Log("src prefix   $srcPrefix");
770      Log("src delim    $srcDelim");
771      Log("dst prefix   $dstPrefix");
772      Log("dst delim    $dstDelim");
773   }
774
775   $srcmbx =~ s#^$srcPrefix##;
776   $dstmbx = $srcmbx;
777
778   if ( $srcDelim ne $dstDelim ) {
779       #  Need to substitute the dst's hierarchy delimiter for the src's one
780       $srcDelim = '\\' . $srcDelim if $srcDelim eq '.';
781       $dstDelim = "\\" . $dstDelim if $dstDelim eq '.';
782       $dstmbx =~ s#$srcDelim#$dstDelim#g;
783       $dstmbx =~ s/\\//g;
784   }
785   if ( $srcPrefix ne $dstPrefix ) {
786       #  Replace the source prefix with the dest prefix
787       $dstmbx =~ s#^$srcPrefix## if $srcPrefix;
788       if ( $dstPrefix ) {
789          $dstmbx = "$dstPrefix$dstmbx" unless uc($srcmbx) eq 'INBOX';
790       }
791       $dstmbx =~ s#^$dstDelim##;
792   }
793
794   return $dstmbx;
795}
796
797