#!/usr/bin/perl

# $Header: /mhub4/sources/imap-tools/migrateIMAP.pl,v 1.20 2012/03/15 12:32:23 rick Exp $

#*************************************************************************
#                                                                        *
#   Program name    migrateIMAP                                          *
#   Written by      Rick Sanders                                         *
#   Date            6 May 2008                                           * 
#                                                                        * 
#   Description                                                          *
#                                                                        *
#   This script is used to migrate the e-mail on one IMAP Server         *
#   another.  Each users's messages are copied from the "source"         *
#   server to the "destination" server using the IMAP protocol. You      *
#   supply a file with the user's names & passwords.  For example:       *
#                                                                        *
#   ./migrateIMAP.pl -S source -D destination -i <users file>            *
#                                                                        *
#   Use the -h argument to see the complete list of arguments.           *
#*************************************************************************
use IMAP::Utils;

init();

#  Get the list of usernames and passwords

@users = getUserList( $userlist );

$i=$totalUsers=$children=0;
for ($index = 0; $index <= $#users; $index++) {
  $userinfo = $users[$index];
  ($user) = split(/\s*:\s*/, $userinfo);

  #  Start the migration.  Unless maxChildren has been set to 1
  #  fork off child processes to do the migration in parallel.
 
  if ($maxChildren == 1) {
	migrate ($userinfo);
  } else {
  	Log("There are $children running") if $debug;
  	if ( $children < $maxChildren ) {
   	   Log("   Forking to migrate $user");
     	   if ( $pid = fork ) {	# Parent
	      Log ("   Parent $$ forked $pid");
     	   } elsif (defined $pid) {	# Child
	      Log ("  Child process $$ processing $sourceUser");
              migrate($userinfo);
              Log("   $user is done");
              exit 0;
     	   } else {
              Log("Error forking child to migrate $user");
              next;
     	   }
     	   $children++;
     	   $children{$pid} = $user;
  	} 

  	Log ("I'm PID $$") if $debug;
  	while ( $children >= $maxChildren ) {
     	   Log(" $$ - Max children running.  Waiting...");
     	   $foundPid = wait;	# Wait for a child to terminate
	   if ($? != 0) {
	      Log ("ERROR: PID $foundPid exited with status $?");
	   }
	   delete $children{$foundPid};
     	   $children--;
  	}
  	Log("OK to launch another user migration") if $debug;
  }

}

if ($maxChildren > 1) {
   Log("All children have been launched, waiting for them to finish");
   foreach $pid ( keys(%children) ) {
      $user = $children{$pid};
      Log("Waiting on process $pid ($user) to finish");
      waitpid($pid, 0);
      if ($? != 0) {
         Log ("ERROR: PID $pid exited with status $?");
      }
   }
}

summarize();
$elapsed = sprintf("%.2f", (time()-$start)/3600);
Log("Elapsed time  $elapsed hours");
Log("Migration completed");
exit;

sub migrate {
  
my $user = shift;

  ($sourceUser,$sourcePwd,$destUser,$destPwd) = split(/\s*:\s*/, $user); 

   Log("Starting migration of $sourceUser");
   print STDOUT "   Migrating $sourceUser\n";
   unless ( $sourcePwd ) {
     Log("Password not found for $sourceUser, messages will not be migrated");
     return;
   }

   $conn_timed_out=0;
   return unless connectToHost($sourceHost, \$src);
   return unless login($sourceUser,$sourcePwd, $src);

   unless ( connectToHost( $destHost, \$dst ) ) {
      logout( $src );
      return;
   }
   unless ( login( $destUser,$destPwd, $dst ) ) {
      logout( $src );
      return;
   }
   namespace( $src, \$srcPrefix, \$srcDelim, $opt_x );
   namespace( $dst, \$dstPrefix, \$dstDelim, $opt_y );
    
   $totalUsers++;
   @mbxs = getMailboxList($sourceUser, $src);

   $longest_name = mailbox_names( \@mbxs );

   map_mbx_names( \%mbx_map, $srcDelim, $dstDelim );

   $total = 0;
   foreach $mbx ( @mbxs ) {
      $dstmbx = mailboxName( $mbx,$srcPrefix,$srcDelim,$dstPrefix,$dstDelim );
      $checkpoint = "$mbx|$sourceHost|$sourceUser|$sourcePwd|";
      $checkpoint .= "$destHost|$destUser|$destPwd";
   
      createMbx( $dstmbx, $dst ) unless mbxExists( $dstmbx, $dst);

      get_supported_flags( $dstmbx, $dst, \%SUPPORTED_FLAGS );

      if ( $sent_after and $sent_before ) {
         getDatedMsgList( $mbx, 'SINCE',  $sent_after,  \@msgs_since, $src );
         getDatedMsgList( $mbx, 'BEFORE', $sent_before, \@msgs_before, $src );
         date_in_range( \@msgs_since, \@msgs_before, \@msgs);
      } elsif ( $sent_after  ) {
         getDatedMsgList( $mbx, 'SINCE',  $sent_after,  \@msgs, $src );
      } elsif ( $sent_before  ) {
         getDatedMsgList( $mbx, 'BEFORE', $sent_before, \@msgs, $src );
      } else {
         getMsgList( $mbx, \@msgs, $src );
      }
 
      if ( $debug ) {
         $n = $#msgs + 1;
         Log("    $mbx has $n messages");
         foreach $m ( @msgs ) { Log("$m"); }
      }

      if ( $#msgs == -1 ) {
         #  Create an empty mailbox
         $line = pack("A$longest_name A13 A18", $mbx, '', "(0 messages)");
         Log("    Copied $line");
         next;
      }

      if ( $update ) {

         #  Get a list of messages on the dest.  Use the message id
         #  as the key unless the user has specified MD5 hashes
         #  so we can avoid copying ones already on the dest

         %DST_MSGS = ();
         if ( $md5_hash ) {
            Log("Using md5 hash of msg body as the key") if $debug;
            getMsgList( $mbx, \@dstmsgs, $dst );
            foreach $msg ( @dstmsgs ) {
               ($msgnum,$msgid,$subject,$date) = split(/\|/, $msg);
               fetch_msg_body( $msgnum, $dst, \$message );
               $key = hash( \$message );
               Log("   msgnum:$msgnum hash $key") if $debug;
               $DST_MSGS{"$key"} = 1;
            }
         } else {
            getMsgIdList( $dstmbx, \%DST_MSGS, $dst );
         }
         foreach $key ( keys %DST_MSGS ) {
            Log("   dest $key") if $debug;
         }
      }

      $added=0;
      selectMbx( $dstmbx, $dst, 'SELECT' );
      foreach $_ ( @msgs ) {
         ($msgnum,$date,$flags,$msgid) = split(/\|/, $_);
         $flags = validate_flags( $flags, \%SUPPORTED_FLAGS );
 
         if ( $update ) {
            #  If we are in 'update' mode then don't copy 
            #  a message if it already exists on the dest
            if ( $md5_hash ) {
               #  Use the md5 hash
               fetch_msg_body( $msgnum, $src, \$message );
               $key = hash( \$message );
               next if $DST_MSGS{"$key"};
            } else {
               #  Use the msgid
               next if $DST_MSGS{"$msgid"};
            }
         }

         alarm $timeout;
         fetchMsg( $msgnum, $src, \$message);
         alarm 0;
         if ( $conn_timed_out ) {
            Log("$srcHost timed out");
            reconnect( $checkpoint, $src );
            $conn_timed_out = 0;
            next;
         }
         alarm $timeout;
         insertMsg( $dst, $dstmbx, *message, $flags, $date );
         alarm 0;
         if ( $conn_timed_out ) {
            Log("$destHost timed out");
            reconnect( $checkpoint, $dst );
            $conn_timed_out = 0;
            next;
         }
         $added++;

      }
      $total += $added;
      $line = pack("A$longest_name A13 A18", $mbx, '', "($added messages)");
      Log("    Copied $line");
   }

   #  Update the summary file with the totals for this user
   open(SUM, ">>/tmp/migrateIMAP.sum");
   print SUM "$total|$totalBytes\n";
   close SUM;
   $totalBytes = formatBytes( $totalBytes );
   Log("    Copied $total messages $totalBytes");
   logout( $src );
   logout( $dst );

}

sub init {

   use Getopt::Std;
   use Fcntl;
   use Socket;
   use IO::Socket;
   use sigtrap;
   use FileHandle;
   require "ctime.pl";

   $version = "1.0.3";
   if ( $ENV{OS} =~ /Windows/i ) {
      print "\nThis version of migrateIMAP does not support Windows since\n";
      print "it uses fork() to run multiple simultaneous migration processes\n";
      print "for better performance.  Please use iu-migrate-win\n";
      print "instead.\n\n";
      exit;
   }
   $start = time();

   #  Set up signal handling
   $SIG{'ALRM'} = 'signalHandler';
   $SIG{'HUP'}  = 'signalHandler';
   $SIG{'INT'}  = 'signalHandler';
   $SIG{'TERM'} = 'signalHandler';
   $SIG{'URG'}  = 'signalHandler';

   getopts('S:D:L:i:b:t:n:M:m:hIdux:y:a:b:UHr:');

   usage() if $opt_h;
   unless ($opt_S and $opt_D ) {
     usage();
   }
   $sourceHost = $opt_S;
   $destHost   = $opt_D;
   $userlist   = $opt_i;
   $logfile    = $opt_L;
   $maxChildren = $opt_n;
   $usage      = $opt_h;
   $timeout    = $opt_t;
   $unseen     = $opt_u;
   $sent_after = $opt_a;
   $sent_before = $opt_b;
   $mbx_map_fn = $opt_M;
   $mbxList    = $opt_m;
   $range      = $opt_r;
   $showIMAP=1 if $opt_I;
   $debug=1    if $opt_d;
   $update=1   if $opt_U;
   $md5_hash=1 if $opt_H;

   $timeout = 300 unless $timeout;
   $maxChildren = 2 unless $maxChildren;

   IMAP::Utils::init();
   $logfile = "migrateIMAP.log" unless $logfile;
   if ( -e $logfile ) {
      #  Rename the existing logfile
      $line = `head -n 1 $logfile`;
      $ts = substr($line,0,16);
      rename($logfile, "$logfile.$ts");
   }
   open (LOG, ">>$logfile");
   select LOG;
   $| = 1;
   unlink '/tmp/migrateIMAP.sum' if -e '/tmp/migrateIMAP.sum';
   Log("$0 starting");

   if ( $update ) {
      if ( $md5_hash ) {
         Log("Running in update/md5_hash mode");
      } else {
         Log("Running in update mode");
      }
   }

   Log("Renamed old logfile to $logfile.$ts") if $ts;

   #  Validate the arguments and call usage() if necessary

   $date = ctime(time);
   chomp($date);

}

sub usage {

   print "\nUsage:  iu-migrate -S sourceHost -D destinationHost\n\n";
   print "Optional arguments:\n\n";
   print " -i <file of usernames>\n";
   print " -n <number of simultaneous migration processes to run>\n";
   print " -L <logfile, default is migrateIMAP.log>\n";
   print " -t <timeout in seconds>\n";
   print " -u <migrate only Unseen messages>\n";
   print " -M <file> mailbox map file. Maps src mbxs to dst mbxs.\n";
   print " -m  <mbx1,mbx2,..,mbxn> List of mailboxes to migrate.\n";
   print " -d debug mode\n";
   print " -I record IMAP protocol exchanges\n";
   print " -x <mbx delimiter [mbx prefix]>  source (eg, -x '. INBOX.'\n";
   print " -y <mbx delimiter [mbx prefix]>  destination\n";
   print " -a <DD-MMM-YYYY> copy only messages after this date\n";
   print " -b <DD-MMM-YYYY> copy only messages before this date\n";
   print " -U update mode, don't copy messages that already exist at the destination\n";
   print " -H use an MD5 hash of the message body to determine uniqueness\n";
   print " -T copy custom flags (eg, \$Label1,\$MDNSent,etc)\n";
   exit;

}

#  getDatedMsgList
#
#  Get a list of the user's messages in a mailbox on
#  the host which were sent after the specified date
#
sub getDatedMsgList {

my $mailbox = shift;
my $operator = shift;
my $cutoff_date = shift;
my $msgs    = shift;
my $conn    = shift;
my ($seen, $empty, @list,$msgid);

    #  Get a list of messages sent after the specified date

    Log("Searching for messages $operator $cutoff_date");

    @list  = ();
    @$msgs = ();

    sendCommand ($conn, "1 EXAMINE \"$mailbox\"");
    while ( 1 ) {
        $response = readResponse ($conn);
        if ( $response =~ / EXISTS/i) {
            $response =~ /\* ([^EXISTS]*)/;
            # Log("     There are $1 messages in $mailbox");
        } elsif ( $response =~ /^1 OK/i ) {
            last;
        } elsif ( $response =~ /^1 NO/i ) {
            Log ("unexpected response: $response");
            return 0;
        } elsif ( $response !~ /^\*/ ) {
            Log ("unexpected response: $response");
            return 0;
        }
    }

    my ($date,$ts) = split(/\s+/, $cutoff_date);

    #
    #  Get list of messages sent before/after the reference date
    #
    Log("Get messages sent $operator $date") if $debug;
    $nums = "";
    sendCommand ($conn, "1 SEARCH $operator \"$date\"");
    while ( 1 ) {
	$response = readResponse ($conn);
	if ( $response =~ /^1 OK/i ) {
	    last;
	}
	elsif ( $response =~ /^\*\s+SEARCH/i ) {
	    ($nums) = ($response =~ /^\*\s+SEARCH\s+(.*)/i);
	}
	elsif ( $response !~ /^\*/ ) {
	    Log ("unexpected SEARCH response: $response");
	    return;
	}
    }
    Log("$nums") if $debug;
    if ( $nums eq "" ) {
	Log ("     $mailbox has no messages sent before $date") if $debug;
	return;
    }
    my @number = split(/\s+/, $nums);
    $n = $#number + 1;

    $nums =~ s/\s+/ /g;
    @msgList = ();
    @msgList = split(/ /, $nums);

    if ($#msgList == -1) {
	#  No msgs in this mailbox
	return 1;
    }

@$msgs  = ();
for $num (@msgList) {

     sendCommand ( $conn, "1 FETCH $num (uid flags internaldate body[header.fields (Message-Id Date)])");
     
     undef @response;
     while ( 1 ) {
	$response = readResponse   ( $conn );
	if   ( $response =~ /^1 OK/i ) {
		last;
	}   
        last if $response =~ /^1 NO|^1 BAD|^\* BYE/;
     }

     $flags = '';
     my $msgid;
     foreach $_ ( @response ) {
	last   if /^1 OK FETCH complete/i;
          if ( /FLAGS/ ) {
             #  Get the list of flags
             /FLAGS \(([^\)]*)/;
             $flags = $1;
             $flags =~ s/\\Recent//;
          }
   
          if ( /Message-Id:\s*(.+)/i ) {
             $msgid = $1;
          }

          if ( /INTERNALDATE/) {
             /INTERNALDATE (.+) BODY/i;
             $date = $1;
             $date =~ /"(.+)"/;
             $date = $1;
             $date =~ s/"//g;
             ####  next if check_cutoff_date( $date, $cutoff_date );
          }

          if ( /\* (.+) FETCH/ ) {
             ($msgnum) = split(/\s+/, $1);
          }

          if ( $msgnum and $date and $msgid ) {
             push (@$msgs,"$msgnum|$date|$flags|$msgid");
             $msgnum=$msgid=$date=$flags='';
          }
      }
   }

   foreach $_ ( @$msgs ) {
      Log("getDated found $_") if $debug;
   }

   return 1;
}

#  getMsgList
#
#  Get a list of the user's messages in the indicated mailbox on
#  the source host
#
sub getMsgList {

my $mailbox = shift;
my $msgs    = shift;
my $conn    = shift;
my $seen;
my $empty;
my $msgnum;
my $from;
my $flags;

   @$msgs  = ();
   trim( *mailbox );
   sendCommand ($conn, "1 EXAMINE \"$mailbox\"");
   undef @response;
   $empty=0;
   while ( 1 ) {
	$response = readResponse ( $conn );
	if ( $response =~ / 0 EXISTS/i ) { $empty=1; }
	if ( $response =~ /^1 OK/i ) {
		# print STDERR "response $response\n";
		last;
	} elsif ( $response !~ /^\*/ ) {
		Log ("unexpected response: $response");
		# print STDERR "Error: $response\n";
		return 0;
	}
   }

   return if $empty;

   Log("Fetch the header info") if $debug;

   if ( $range ) {
      $fetch_range = $range;
   } else {
      $fetch_range = '1:*';
   }

   sendCommand ( $conn, "1 FETCH $fetch_range (uid flags internaldate body[header.fields (From Date Message-Id)])");
   undef @response;
   while ( 1 ) {
	$response = readResponse ( $conn );
	return if $conn_timed_out;
	if ( $response =~ /^1 OK/i ) {
	   last;
	} elsif ( $response =~ /could not be processed/i ) {
           Log("Error:  response from server: $response");
           return;
        } elsif ( $response =~ /^1 NO|^1 BAD/i ) {
           return;
        }
   }

   read_response( \@response, $msgs );

}

sub formatBytes {

my $bytes = shift;

   #  Format the number nicely

   if ( length($bytes) >= 10 ) {
      $bytes = $bytes/1000000000;
      $tag = 'GB';
   } elsif ( length($bytes) >= 7 ) {
      $bytes = $bytes/1000000;
      $tag = 'MB';
   } else {
      $bytes = $bytes/1000;
      $tag = 'KB';
   }

   # commafy
   $_ = $bytes;
   1 while s/^([-+]?\d+)(\d{3})/$1,$2/;
   $bytes = sprintf("%.2f", $_) . " $tag";

   return $bytes;
}

sub getUserList {

my $fn = shift;

   @users = ();
   unless ( -e $fn ) {
     Log("Fatal error reading $fn: $!");
     exit;
   }
   open(L, "<$fn") or die $!;
   while ( <L> ) {
      chomp;
      s/^\s+//;
      next if /^#/;
      push( @users, $_ );
   }
   close L;

   return @users;

}


#  Reconnect to a server after a timeout error.
#
sub reconnect {

my $checkpoint = shift;
my $conn = shift;

   Log("This is reconnect, conn is $conn") if $debug;
   logout( $conn );
   close $conn;
   sleep 5;
   ($mbx,$shost,$suser,$spwd,$dhost,$duser,$dpwd) = split(/\|/, $checkpoint);
   if ( $conn eq $src ) {
      $host = $shost;
      $user = $suser;
      $pwd  = $spwd;
   } else { 
      $host = $dhost;
      $user = $duser;
      $pwd  = $dpwd;
   }
   connectToHost($host,$conn);
   login($user,$pwd,$conn);
   selectMbx( $mbx, $conn, 'SELECT');
   createMbx( $mbx, $dst );   # Just in case
   Log("leaving reconnect");
}

#  Handle signals

sub signalHandler {

my $sig = shift;

   if ( $sig eq 'ALRM' ) {
      Log("Caught a SIG$sig signal, timeout error");
      $conn_timed_out = 1;
   } else {
      Log("Caught a SIG$sig signal, shutting down");
      exit;
   }
}

#  Get the total message count and bytes and write
#  it to the log.  

sub summarize {

   #  Each child appends its totals to /tmp/migrateEmail.sum so
   #  we read the lines and add up the grand totals.

   $totalUsers=$totalMsgs=$totalBytes=0;
   open(SUM, "</tmp/migrateIMAP.sum");
   while ( <SUM> ) {
      chomp;
      ($msgs,$bytes) = split(/\|/, $_);
      $totalUsers++;
      $totalMsgs  += $msgs;
      $totalBytes += $bytes;
   }

   $_ = $totalMsgs;
   1 while s/^([-+]?\d+)(\d{3})/$1,$2/;  #  Commafy the message total
   $totalMsgs = $_;
   $totalBytes = formatBytes( $totalBytes );

   Log("Summary of migration");
   Log("Migrated $totalUsers users, $totalMsgs messages, $totalBytes.");

}

sub namespace {

my $conn      = shift;
my $prefix    = shift;
my $delimiter = shift;
my $mbx_delim = shift;

   #  Query the server with NAMESPACE so we can determine its
   #  mailbox prefix (if any) and hierachy delimiter.

   if ( $mbx_delim ) {
      #  The user has supplied a mbx delimiter and optionally a prefix.
      Log("Using user-supplied mailbox hierarchy delimiter $mbx_delim") if $debug;
      ($$delimiter,$$prefix) = split(/\s+/, $mbx_delim);
      return;
   }

   @response = ();
   sendCommand( $conn, "1 NAMESPACE");
   while ( 1 ) {
      $response = readResponse( $conn );
      if ( $response =~ /^1 OK/i ) {
         last;
      } elsif ( $response =~ /^1 NO|^1 BAD/i ) {
         Log("Unexpected response to NAMESPACE command: $response");
      }
   }

   foreach $_ ( @response ) {
      if ( /NAMESPACE/i ) {
         my $i = index( $_, '((' );
         my $j = index( $_, '))' );
         my $val = substr($_,$i+2,$j-$i-3);
         ($val) = split(/\)/, $val);
         ($$prefix,$$delimiter) = split( / /, $val );
         $$prefix    =~ s/"//g;
         $$delimiter =~ s/"//g;
         last;
      }
      last if /^1 NO|^1 BAD/;
   }
 
   if ( $debug ) {
      Log("prefix  $$prefix");
      Log("delim   $$delimiter");
   }

}
sub mailboxName {

my $srcmbx    = shift;
my $srcPrefix = shift;
my $srcDelim  = shift;
my $dstPrefix = shift;
my $dstDelim  = shift;
my $dstmbx;

   #  Adjust the mailbox name if the source and destination server
   #  have different mailbox prefixes or hierarchy delimiters.

   if ( $srcmbx =~ /[$dstDelim]/ and $srcDelim ne $dstDelim ) {
      #  The mailbox name has a character that is used on the destination
      #  as a mailbox hierarchy delimiter.  We have to replace it.
      $srcmbx =~ s^[$dstDelim]^$substChar^g;
   }

   if ( $debug ) {
      Log("src mbx      $srcmbx");
      Log("src prefix   $srcPrefix");
      Log("src delim    $srcDelim");
      Log("dst prefix   $dstPrefix");
      Log("dst delim    $dstDelim");
   }

   #  Change the mailbox name if the user has supplied mapping rules.
   if ( $mbx_map{"$srcmbx"} ) {
      $srcmbx = $mbx_map{"$srcmbx"}
   }

   if ( ($srcPrefix eq $dstPrefix) and ($srcDelim eq $dstDelim) ) {
      #  No adjustments necessary
      $dstmbx = $srcmbx;
      if ( $root_mbx ) {
         #  Put folders under a 'root' folder on the dst
         $dstmbx =~ s/^$dstPrefix//;
         $dstDelim =~ s/\./\\./g;
         $dstmbx =~ s/^$dstDelim//;
         $dstmbx = $dstPrefix . $root_mbx . $dstDelim . $dstmbx;
         if ( uc($srcmbx) eq 'INBOX' ) {
            #  Special case for the INBOX
            $dstmbx =~ s/INBOX$//i;
            $dstmbx =~ s/$dstDelim$//;
         }
         $dstmbx =~ s/\\//g;
      }
      return $dstmbx;
   }

   $srcmbx =~ s#^$srcPrefix##;
   $dstmbx = $srcmbx;

   if ( $srcDelim ne $dstDelim ) {
       #  Need to substitute the dst's hierarchy delimiter for the src's one
       $srcDelim = '\\' . $srcDelim if $srcDelim eq '.';
       $dstDelim = "\\" . $dstDelim if $dstDelim eq '.';
       $dstmbx =~ s#$srcDelim#$dstDelim#g;
       $dstmbx =~ s/\\//g;
   }
   if ( $srcPrefix ne $dstPrefix ) {
       #  Replace the source prefix with the dest prefix
       $dstmbx =~ s#^$srcPrefix## if $srcPrefix;
       if ( $dstPrefix ) {
          $dstmbx = "$dstPrefix$dstmbx" unless uc($srcmbx) eq 'INBOX';
       }
       $dstDelim = "\\$dstDelim" if $dstDelim eq '.';
       $dstmbx =~ s#^$dstDelim##;
   } 
      
   if ( $root_mbx ) {
      #  Put folders under a 'root' folder on the dst
      $dstDelim =~ s/\./\\./g;
      $dstmbx =~ s/^$dstPrefix//;
      $dstmbx =~ s/^$dstDelim//;
      $dstmbx = $dstPrefix . $root_mbx . $dstDelim . $dstmbx;
      if ( uc($srcmbx) eq 'INBOX' ) {
         #  Special case for the INBOX
         $dstmbx =~ s/INBOX$//i;
         $dstmbx =~ s/$dstDelim$//;
      }
      $dstmbx =~ s/\\//g;
   }

   return $dstmbx;
}

sub map_mbx_names {

my $mbx_map = shift;
my $srcDelim = shift;
my $dstDelim = shift;

   #  The -M <file> argument causes migrateIMAP to read the
   #  contents of a file with mappings between source and
   #  destination mailbox names. This permits the user to
   #  to change the name of a mailbox when copying messages.
   #
   #  The lines in the file should be formatted as:
   #       <source mailbox name>: <destination mailbox name>
   #  For example:
   #       Drafts/2008/Save:  Draft_Messages/2008/Save
   #       Action Items: Inbox
   #
   #  Note that if the names contain non-ASCII characters such
   #  as accents or diacritical marks then the Perl module
   #  Unicode::IMAPUtf7 module must be installed.

   return unless $mbx_map_fn;

   unless ( open(MAP, "<$mbx_map_fn") ) {
      Log("Error opening mbx map file $mbx_map_fn: $!");
      exit;
   }
   $use_utf7 = 0;
   while( <MAP> ) {
      chomp;
      s/^\s+//;
      next if /^#/;
      next unless $_;
      ($srcmbx,$dstmbx) = split(/\s*:\s*/, $_);

      #  Unless the mailbox name is entirely ASCII we'll have to use
      #  the Modified UTF-7 character set.
      $use_utf7 = 1 unless isAscii( $srcmbx );
      $use_utf7 = 1 unless isAscii( $dstmbx );

      $srcmbx =~ s/\//$srcDelim/g;
      $dstmbx =~ s/\//$dstDelim/g;

      $$mbx_map{"$srcmbx"} = $dstmbx;

   }
   close MAP;

   if ( $use_utf7 ) {
      eval 'use Unicode::IMAPUtf7';
      if ( $@ ) {
         Log("At least one mailbox map contains non-ASCII characters.  This means you");
         Log("have to install the Perl Unicode::IMAPUtf7 module in order to map mailbox ");
         Log("names between the source and destination servers.");
         print "At least one mailbox map contains non-ASCII characters.  This means you\n";
         print "have to install the Perl Unicode::IMAPUtf7 module in order to map mailbox\n";
         print "names between the source and destination servers.\n";
         exit;
      }
   }

   my %temp;
   foreach $srcmbx ( keys %$mbx_map ) {
      $dstmbx = $$mbx_map{"$srcmbx"};
      Log("Mapping src:$srcmbx to dst:$dstmbx");
      if ( $use_utf7 ){
         #  Encode the name in Modified UTF-7 charset
         $srcmbx = Unicode::IMAPUtf7::imap_utf7_encode( $srcmbx );
         $dstmbx = Unicode::IMAPUtf7::imap_utf7_encode( $dstmbx );
      }
      $temp{"$srcmbx"} = $dstmbx;
   }
   %$mbx_map = %temp;
   %temp = ();

}

sub read_response {

my $response = shift;
my $msgs     = shift;
my ($msgid,$date,$flags,$msgnum);

   #  Read the response to our FETCH command and grab
   #  the items we want (msgnum,date,flags, and msgid).

   @$msgs = ();
   for $i (0 .. $#$response) {
        $seen=0;
        $_ = $response[$i];

        if ($response[$i] =~ /FLAGS/) {
           #  Get the list of flags
           $response[$i] =~ /FLAGS \(([^\)]*)/;
           $flags = $1;
           $flags =~ s/\\Recent//;
        }

        if ( $response[$i] =~ /INTERNALDATE/) {
           $response[$i] =~ /INTERNALDATE (.+) BODY/i;
           $date = $1;
           $date =~ /"(.+)"/;
           $date = $1;
           $date =~ s/"//g;
        }

        if ( $response[$i] =~ /^Message-Id: (.+)/i ) {
           $msgid = $1;
        }

        if ( $response[$i] =~ /\* (.+) FETCH/ ) {
           ($msgnum) = split(/\s+/, $1);
        }

        if ( $_ eq '' ) {
           if ( $unseen ) {
              push (@$msgs,"$msgnum|$date|$flags|$msgid") unless $flags =~ /Seen/i;
           } else {
              push (@$msgs,"$msgnum|$date|$flags|$msgid");
           }
           $msgnum=$date=$flags=$msgid;
        }
   }

}

sub get_supported_flags {

my $mbx   = shift;
my $conn  = shift;
my $FLAGS = shift;

   #  Determine which flags are supported by the mailbox

   sendCommand ($conn, "1 EXAMINE \"$mbx\"");
   undef @response;
   $empty=0;
   while ( 1 ) {
        $response = readResponse ( $conn );
        if ( $response =~ /^1 OK/i ) {
                last;
        } elsif ( $response !~ /^\*/ ) {
                Log ("unexpected response: $response");
                last;
        } elsif ( $response =~ /^\* FLAGS \((.+)\)/i ) {
                %$FLAGS = ();
                foreach my $flag ( split(/\s+/, $1) ) {
                   $$FLAGS{$flag} = 1;
                }
        }
   }

}

sub validate_flags {

my $flags = shift;
my $valid_flags = shift;
my $newflags;

    # Remove any flags not supported by the destination mailbox

    foreach my $flag ( split(/\s+/, $flags ) ) {
        next unless $$valid_flags{$flag};
        $newflags .= "$flag ";
    }
    chop $newflags;

    return $newflags;

}

sub fetch_msg_body {

my $msgnum = shift;
my $conn   = shift;
my $message = shift;

   #  Fetch the body of the message less the headers

   Log("   Fetching msg $msgnum...") if $debug;

   sendCommand( $conn, "1 FETCH $msgnum (rfc822)");
   while (1) {
	$response = readResponse ($conn);
	if ( $response =~ /^1 OK/i ) {
		$size = length($message);
		last;
	} 
        elsif ( $response =~ /^1 NO|^1 BAD/i ) {
                Log("Error fetching msgnum $msgnum: $response");
                last;
        }
	elsif ($response =~ /message number out of range/i) {
		Log ("Error fetching uid $uid: out of range",2);
		$stat=0;
		last;
	}
	elsif ($response =~ /Bogus sequence in FETCH/i) {
		Log ("Error fetching uid $uid: Bogus sequence in FETCH",2);
		$stat=0;
		last;
	}
	elsif ( $response =~ /message could not be processed/i ) {
		Log("Message could not be processed, skipping it ($user,msgnum $msgnum,$destMbx)");
		push(@errors,"Message could not be processed, skipping it ($user,msgnum $msgnum,$destMbx)");
		$stat=0;
		last;
	}
	elsif 
	   ($response =~ /^\*\s+$msgnum\s+FETCH\s+\(.*RFC822\s+\{[0-9]+\}/i) {
		($len) = ($response =~ /^\*\s+$msgnum\s+FETCH\s+\(.*RFC822\s+\{([0-9]+)\}/i);
		$cc = 0;
		$$message = "";
		while ( $cc < $len ) {
			$n = 0;
			$n = read ($conn, $segment, $len - $cc);
			if ( $n == 0 ) {
				Log ("unable to read $len bytes");
				return 0;
			}
			$$message .= $segment;
			$cc += $n;
		}
	}
   }

}

sub date_in_range {

my $list1 = shift;
my $list2 = shift;
my $newlist = shift;
my %MSGNUMS;

   #  Return a list of msgnums common to both lists passed
   #  to us.

   @$newlist = ();

   foreach $_ ( @$list1 ) {
      my ($msgnum) = split(/\|/, $_);
      $MSGNUMS{$msgnum} = $_;
   }

   foreach $_ ( @$list2 ) {
      my ($msgnum) = split(/\|/, $_);
      push( @$newlist, $_ ) if $MSGNUMS{$msgnum};
   }
      
}

sub mailbox_names {

my $mbxs = shift;

   #  Figure out what the longest mbx name is so we
   #  can nicely format the running totals

   my $longest;
   foreach $_ ( @$mbxs ) {
      my $length = length( $_ );
      $longest = $length if $length > $longest;
   }

   $longest += 2;
   return $longest;

}

sub flags {

my $flags = shift;
my @newflags;
my $newflags;

   #  Make sure the flags list contains standard
   #  IMAP flags and optionally custom tags

print STDERR "flags $flags\n";

   return unless $flags;

   $flags =~ s/\\Recent//i;
   foreach $_ ( split(/\s+/, $flags) ) {
      push( @newflags, $_ ) if substr($_,0,1) eq '\\';
      if ( $opt_T ) {
         #  Include user-defined flags
         push( @newflags, $_ ) if substr($_,0,1) eq '$';
      }
   }

   $newflags = join( ' ', @newflags );

   $newflags =~ s/\\Deleted//ig if $opt_r;
   $newflags =~ s/^\s+|\s+$//g;

print STDERR "newflags $newflags\n";

   return $newflags;
}

