1#!/usr/local/bin/perl
2
3# $Header: /mhub4/sources/imap-tools/maildir_to_imap.pl,v 1.5 2012/02/29 01:19:37 rick Exp $
4
5##########################################################################
6#   Program name    maildir_to_imap.pl                                   #
7#   Written by      Rick Sanders                                         #
8#                                                                        #
9#   Description                                                          #
10#                                                                        #
11#   maildir_to_imap is used to copy the messages in a maildir to a       #
12#   user's IMAP mailbox.  maildir_to_imap is executed like this:         #
13#                                                                        #
14#   ./maildir_to_imap.pl -i <user list> -D <imapserver[:port]>           #
15#                                                                        #
16#   The user list is a file with one or more entries containing the      #
17#   location of the user's maildir and his IMAP username and password.   #
18#                                                                        #
19#   For example:                                                         #
20#         /mhub4/maildirs/rwilson@abc.net,rich.wilson,welcome            #
21#         /mhub4/maildirs/jane.eyre@abc.net,jane.eyre,mypass             #
22#                                                                        #
23#   See usage() for a list of arguments                                  #
24##########################################################################
25
26init();
27$debug = 1;
28get_user_list( \@users );
29migrate_user_list( \@users );
30
31exit;
32
33
34sub migrate_user_list {
35
36my $users = shift;
37
38  #  Migrate a set of users
39
40  foreach $userinfo ( @$users ) {
41     $usercount++;
42     ($user) = split(/\s*,\s*/, $userinfo);
43     Log("migrate $user");
44
45     #  Start the migration.  Unless maxChildren has been set to 1
46     #  fork off child processes to do the migration in parallel.
47
48     if ($maxChildren == 1) {
49	migrate ($userinfo, $imaphost);
50     } else {
51  	Log("There are $children running") if $debug;
52  	if ( $children < $maxChildren ) {
53   	   Log("   Forking to migrate $user") if $debug;
54     	   if ( $pid = fork ) {	# Parent
55	      Log ("   Parent $$ forked $pid") if $debug;
56     	   } elsif (defined $pid) {	# Child
57	      Log ("  Child process $$ processing $sourceUser") if $debug;
58              migrate($userinfo, $imaphost);
59              Log("   $user is done");
60              exit 0;
61     	   } else {
62              Log("Error forking child to migrate $user");
63              next;
64     	   }
65     	   $children++;
66     	   $children{$pid} = $user;
67  	}
68
69  	Log ("I'm PID $$") if $debug;
70  	while ( $children >= $maxChildren ) {
71     	   Log(" $$ - Max children running.  Waiting...") if $debug;
72     	   $foundPid = wait;	# Wait for a child to terminate
73	   if ($? != 0) {
74	      Log ("ERROR: PID $foundPid exited with status $?");
75	   }
76	   delete $children{$foundPid};
77     	   $children--;
78  	}
79  	Log("OK to launch another user migration") if $debug;
80  }
81
82}
83}
84
85sub xxxx {
86
87   if ($maxChildren > 1) {
88      Log("All children have been launched, waiting for them to finish");
89      foreach $pid ( keys(%children) ) {
90         $user = $children{$pid};
91         Log("Waiting on process $pid ($user) to finish");
92         waitpid($pid, 0);
93         if ($? != 0) {
94            Log ("ERROR: PID $pid exited with status $?");
95         }
96      }
97   }
98}
99
100
101sub    sum {
102summarize();
103$elapsed = sprintf("%.2f", (time()-$start)/3600);
104Log("Elapsed time  $elapsed hours");
105Log("Migration completed");
106exit;
107}
108
109sub migrate {
110
111my $userinfo = shift;
112my $imaphost = shift;
113
114   my ($user,$pwd,$userpath) = split(/,/, $userinfo);
115
116   return unless connectToHost($imaphost, \$dst);
117   return unless login($user,$pwd, $dst);
118
119   get_maildir_folders( $userpath, \%folders );
120
121   my $messages;
122   foreach $maildir_folder ( keys %folders ) {
123      print STDERR "maildir_folder $maildir_folder\n";
124      $maildir_folder =~ s/\&/&-/;   # Encode the '&' char
125      $maildir_folder =~ s/\s+$//;
126      $folder_path = $folders{"$maildir_folder"};
127      createMbx( $maildir_folder, $dst ) unless mbxExists( $maildir_folder, $dst );
128
129      get_maildir_msgs( $folder_path, \@msgs );
130      my $msgcount = $#msgs + 1;
131      Log("     $maildir_folder ($msgcount msgs) $folder_path");
132
133      next if !@msgs;
134
135      $inserted=0;
136      foreach $msgfn ( @msgs ) {
137         $inserted++ if insert_msg( $msgfn, $maildir_folder, $dst );
138      }
139      Log("     Inserted $inserted messages into $maildir_folder\n");
140   }
141
142   $conn_timed_out=0;
143
144}
145
146sub init {
147
148use Getopt::Std;
149use Fcntl;
150use Socket;
151use IO::Socket;
152use sigtrap;
153use FileHandle;
154require "ctime.pl";
155
156   $start = time();
157
158   #  Set up signal handling
159   $SIG{'ALRM'} = 'signalHandler';
160   $SIG{'HUP'}  = 'signalHandler';
161   $SIG{'INT'}  = 'signalHandler';
162   $SIG{'TERM'} = 'signalHandler';
163   $SIG{'URG'}  = 'signalHandler';
164
165   getopts('H:i:L:n:ht:M:SLdD:Um:I');
166
167   # usage() if $opt_h;
168   #  usage();
169
170   $userlist     = $opt_i;
171   $logfile      = $opt_L;
172   $maxChildren  = $opt_n;
173   $usage        = $opt_h;
174   $timeout      = $opt_t;
175   $imaphost     = $opt_H;
176   $imaphost     = $opt_D;
177   $mbxList      = $opt_m;
178   $debug=1      if $opt_d;
179   $showIMAP=1   if $opt_I;
180
181   $timeout = 45 unless $timeout;
182   $maxChildren = 1 unless $maxChildren;
183   $hostname = `hostname`;
184
185   $logfile = "maildir_to_imap.log" unless $logfile;
186   open (LOG, ">>$logfile");
187   select LOG;
188   $| = 1;
189   Log("$0 starting");
190
191   $date = ctime(time);
192   chomp($date);
193
194   #  Determine whether we have SSL support via openSSL and IO::Socket::SSL
195   $ssl_installed = 1;
196   eval 'use IO::Socket::SSL';
197   if ( $@ ) {
198      $ssl_installed = 0;
199   }
200
201}
202
203sub usage {
204
205   print "\nUsage:  maildir_to_imap.pl -i <users> -D imapHost\n\n";
206   print "Optional arguments:\n\n";
207   print " -i <file of usernames>\n";
208   print " -n <number of simultaneous migration processes to run>\n";
209   print " -m <list of mailboxes> eg Inbox,Drafts,Sent\n";
210   print " -L <logfile, default is maildir_to_imap.log>\n";
211   print " -t <timeout in seconds>\n";
212   print " -d debug mode\n";
213   print " -I record IMAP protocol exchanges\n\n";
214   exit;
215
216}
217
218
219sub Log {
220
221my $line = shift;
222
223   if ( LOG ) {
224      my @f = localtime( time );
225      my $timestamp = sprintf( "%02d-%02d-%04d.%02d:%02d:%02d",
226			 (1 + $f[ 4 ]), $f[ 3 ], (1900 + $f[ 5 ]),
227			 @f[ 2,1,0 ] );
228      printf LOG "%s %s: %s\n", $timestamp, $$, $line;
229   }
230   #  print STDERR "$line\n";
231}
232
233#  Make a connection to an IMAP host
234
235sub format_bytes {
236
237my $bytes = shift;
238
239   #  Format the number nicely
240
241   if ( length($bytes) >= 10 ) {
242      $bytes = $bytes/1000000000;
243      $tag = 'GB';
244   } elsif ( length($bytes) >= 7 ) {
245      $bytes = $bytes/1000000;
246      $tag = 'MB';
247   } else {
248      $bytes = $bytes/1000;
249      $tag = 'KB';
250   }
251
252   # commafy
253   $_ = $bytes;
254   1 while s/^([-+]?\d+)(\d{3})/$1,$2/;
255   $bytes = sprintf("%.2f", $_) . " $tag";
256
257   return $bytes;
258}
259
260
261sub commafy {
262
263my $number = shift;
264
265   $_ = $number;
266   1 while s/^([-+]?\d+)(\d{3})/$1,$2/;
267   $number = $_;
268
269   return $number;
270}
271
272#  Reconnect to a server after a timeout error.
273#
274sub reconnect {
275
276my $checkpoint = shift;
277my $conn = shift;
278
279   Log("This is reconnect, conn is $conn") if $debug;
280   logout( $conn );
281   close $conn;
282   sleep 5;
283   ($mbx,$shost,$suser,$spwd,$dhost,$duser,$dpwd) = split(/\|/, $checkpoint);
284   if ( $conn eq $src ) {
285      $host = $shost;
286      $user = $suser;
287      $pwd  = $spwd;
288   } else {
289      $host = $dhost;
290      $user = $duser;
291      $pwd  = $dpwd;
292   }
293   connectToHost($host,$conn);
294   login($user,$pwd,$conn);
295   selectMbx( $mbx, $conn );
296   createMbx( $mbx, $dst );   # Just in case
297   Log("leaving reconnect");
298}
299
300#  Handle signals
301
302sub signalHandler {
303
304my $sig = shift;
305
306   if ( $sig eq 'ALRM' ) {
307      Log("Caught a SIG$sig signal, timeout error");
308      $conn_timed_out = 1;
309   } else {
310      Log("Caught a SIG$sig signal, shutting down");
311      exit;
312   }
313}
314
315#  Get the total message count and bytes and write
316#  it to the log.
317
318sub summarize {
319
320   #  Each child appends its totals to /tmp/migrateEmail.sum so
321   #  we read the lines and add up the grand totals.
322
323   $totalUsers=$totalMsgs=$totalBytes=0;
324   open(SUM, "</tmp/migrateIMAP.sum");
325   while ( <SUM> ) {
326      chomp;
327      ($msgs,$bytes) = split(/\|/, $_);
328      $totalUsers++;
329      $totalMsgs  += $msgs;
330      $totalBytes += $bytes;
331   }
332
333   $_ = $totalMsgs;
334   1 while s/^([-+]?\d+)(\d{3})/$1,$2/;  #  Commafy the message total
335   $totalMsgs = $_;
336   $totalBytes = formatBytes( $totalBytes );
337
338   Log("Summary of migration");
339   Log("Migrated $totalUsers users, $totalMsgs messages, $totalBytes.");
340
341}
342
343sub isAscii {
344
345my $str = shift;
346my $ascii = 1;
347
348   #  Determine whether a string contains non-ASCII characters
349
350   my $test = $str;
351   $test=~s/\P{IsASCII}/?/g;
352   $ascii = 0 unless $test eq $str;
353
354   return $ascii;
355
356}
357
358sub fix_ts {
359
360my $date = shift;
361
362   #  Make sure the hrs part of the date is 2 digits.  At least
363   #  one IMAP server expects this.
364
365   $$date =~ s/^\s+//;
366   $$date =~ /(.+) (.+):(.+):(.+) (.+)/;
367   my $hrs = $2;
368
369   return if length( $hrs ) == 2;
370
371   my $newhrs = '0' . $hrs if length( $hrs ) == 1;
372   $$date =~ s/ $hrs/ $newhrs/;
373
374}
375
376sub stats {
377
378   print "\n";
379   print "Users migrated   $users\n";
380   print "Total messages   $total_msgs\n";
381   print "Total bytes      $total_bytes\n";
382
383   $elapsed = time() - $start;
384   $minutes = $elapsed/60;
385   print "Elapsed time     $minutes minutes\n";
386
387}
388
389#
390#  Log
391#
392#  This subroutine formats and writes a log message to STDERR.
393#
394
395sub Log {
396
397my $str = shift;
398
399   #  If a logfile has been specified then write the output to it
400   #  Otherwise write it to STDOUT
401
402   if ( $logfile ) {
403      ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
404      if ($year < 99) { $yr = 2000; }
405      else { $yr = 1900; }
406      $line = sprintf ("%.2d-%.2d-%d.%.2d:%.2d:%.2d %s\n",
407		     $mon + 1, $mday, $year + $yr, $hour, $min, $sec,$str);
408      print LOG "$line";
409   }
410   print STDOUT "$str\n" unless $quiet_mode;
411
412}
413
414
415sub usage {
416
417   print STDOUT "usage:\n";
418   exit;
419
420}
421
422sub processArgs {
423
424   if ( !getopts( "" ) ) {
425      usage();
426   }
427}
428
429
430sub isAscii {
431
432my $str = shift;
433my $ascii = 1;
434
435   #  Determine whether a string contains non-ASCII characters
436
437   my $test = $str;
438   $test=~s/\P{IsASCII}/?/g;
439   $ascii = 0 unless $test eq $str;
440
441   return $ascii;
442
443}
444
445#  Handle signals
446
447sub signalHandler {
448
449my $sig = shift;
450
451   if ( $sig eq 'ALRM' ) {
452      Log("Caught a SIG$sig signal, timeout error");
453      $conn_timed_out = 1;
454   } else {
455      Log("Caught a SIG$sig signal, shutting down");
456      exit;
457   }
458   Log("Resuming");
459}
460
461sub insert_msg {
462
463my $msgfn   = shift;
464my $folder  = shift;
465my $dst     = shift;
466
467   #  Put a message in the user's folder
468
469#  Log("insert $msgfn into $folder") if $debug;
470
471   my $flag = 'Unseen';
472   if ( $msgfn =~ /,/ ) {
473      $flag = '\\Seen' if $msgfn =~ /,S$/;
474   }
475
476   if ( !open(MESSAGE, "<$msgfn")) {
477      Log( "    Can't open message fn $msgfn: $!" );
478      return 0;
479   }
480   my ($date,$message,$msgid);
481   while( <MESSAGE> ) {
482       chomp;
483       # print STDERR "message line $_\n";
484       if ( /^Date: (.+)/ and !$date ) {
485          $date = $1;
486       }
487       if ( /^Message-Id: (.+)/i and !$msgid ) {
488          $msgid = $1;
489          Log("msgid $msgid") if $debug;
490       }
491       $message .= "$_\r\n";
492   }
493   close MESSAGE;
494
495   fix_date( \$date );
496
497   $status = insert_imap_msg( $dst, $folder, \$message, $flag, $date );
498
499   return $status;
500
501}
502
503sub entry_exists {
504
505my $mail  = shift;
506my $ldap  = shift;
507my $pwd   = shift;
508my $dn;
509my $i;
510
511   my $attrs = [ 'mailpassword' ];
512   my $base = 'o=site';
513   my $filter = "mail=$mail";
514
515   my $result = $ldap->search(
516            base   => $base,
517            filter => $filter,
518            scope  => "subtree",
519            attrs  => $attrs
520   );
521
522   if ( $result->code ) {
523      my $error = $result->code;
524      my $errtxt = ldap_error_name( $result->code );
525      Log("Error searching for $filter: $errtxt");
526      exit;
527   }
528
529   my @entries = $result->entries;
530   my $i = $#entries + 1;
531
532   $entry = $entries[0];
533   $$pwd = $entry->get_value( 'mailpassword' );
534
535   return $i;
536}
537
538sub get_user_list {
539
540my $users    = shift;
541
542   #  Build a list of the users and their maildirs
543
544   open(F, "<$userlist") or die "Can't open user list $userlist: $!";
545   while( <F> ) {
546      chomp;
547      s/^\s+//;
548      next if /^#/;
549      next unless $_;
550      my( $maildir,$user,$pwd) = split(/,/, $_);
551      push( @$users, "$user,$pwd,$maildir" );
552   }
553   close F;
554
555}
556
557#  Make a connection to an IMAP host
558
559sub connectToHost {
560
561my $host = shift;
562my $conn = shift;
563
564   Log("Connecting to $host");
565
566   ($host,$port) = split(/:/, $host);
567   $port = 143 unless $port;
568
569   # We know whether to use SSL for ports 143 and 993.  For any
570   # other ones we'll have to figure it out.
571   $mode = sslmode( $host, $port );
572
573   if ( $mode eq 'SSL' ) {
574      unless( $ssl_installed == 1 ) {
575         warn("You must have openSSL and IO::Socket::SSL installed to use an SSL connection");
576         Log("You must have openSSL and IO::Socket::SSL installed to use an SSL connection");
577         exit;
578      }
579      Log("Attempting an SSL connection") if $debug;
580      $$conn = IO::Socket::SSL->new(
581         Proto           => "tcp",
582         SSL_verify_mode => 0x00,
583         PeerAddr        => $host,
584         PeerPort        => $port,
585      );
586
587      unless ( $$conn ) {
588        $error = IO::Socket::SSL::errstr();
589        Log("Error connecting to $host: $error");
590        warn("Error connecting to $host: $error");
591        exit;
592      }
593   } else {
594      #  Non-SSL connection
595      Log("Attempting a non-SSL connection") if $debug;
596      $$conn = IO::Socket::INET->new(
597         Proto           => "tcp",
598         PeerAddr        => $host,
599         PeerPort        => $port,
600      );
601
602      unless ( $$conn ) {
603        Log("Error connecting to $host:$port: $@");
604        warn "Error connecting to $host:$port: $@";
605        exit;
606      }
607   }
608
609}
610
611sub sslmode {
612
613my $host = shift;
614my $port = shift;
615my $mode;
616
617   #  Determine whether to make an SSL connection
618   #  to the host.  Return 'SSL' if so.
619
620   if ( $port == 143 ) {
621      #  Standard non-SSL port
622      return '';
623   } elsif ( $port == 993 ) {
624      #  Standard SSL port
625      return 'SSL';
626   }
627
628   unless ( $ssl_installed ) {
629      #  We don't have SSL installed on this machine
630      return '';
631   }
632
633   #  For any other port we need to determine whether it supports SSL
634
635   my $conn = IO::Socket::SSL->new(
636         Proto           => "tcp",
637         SSL_verify_mode => 0x00,
638         PeerAddr        => $host,
639         PeerPort        => $port,
640    );
641
642    if ( $conn ) {
643       close( $conn );
644       $mode = 'SSL';
645    } else {
646       $mode = '';
647    }
648
649   return $mode;
650}
651
652#  login
653#
654#  login in at the IMAP host with the user's name and password
655#
656sub login {
657
658my $user = shift;
659my $pwd  = shift;
660my $conn = shift;
661
662   sendCommand ($conn, "1 LOGIN $user $pwd");
663   while (1) {
664	readResponse ( $conn );
665	if ($response =~ /^1 OK/i) {
666		last;
667	}
668	elsif ($response =~ /^1 NO|^1 BAD/) {
669		Log ("$user login failed: unexpected LOGIN response: $response");
670		return 0;
671	}
672   }
673   Log("Logged in as $user") if $debug;
674
675   return 1;
676}
677
678#
679#  readResponse
680#
681#  This subroutine reads and formats an IMAP protocol response from an
682#  IMAP server on a specified connection.
683#
684
685sub readResponse {
686
687my $fd = shift;
688
689   exit unless defined $fd;
690   $response = <$fd>;
691   chop $response;
692   $response =~ s/\r//g;
693   push (@response,$response);
694   Log ("<< *** Connection timeout ***") if $conn_timed_out;
695   Log ("<< $response") if $showIMAP;
696}
697
698#  sendCommand
699#
700#  This subroutine formats and sends an IMAP protocol command to an
701#  IMAP server on a specified connection.
702#
703sub sendCommand {
704
705local($fd) = shift @_;
706local($cmd) = shift @_;
707
708    print $fd "$cmd\r\n";
709    Log (">> $cmd") if $showIMAP;
710}
711
712#
713#  log out from the host
714#
715sub logout {
716
717my $conn = shift;
718
719   undef @response;
720   sendCommand ($conn, "1 LOGOUT");
721   while ( 1 ) {
722        readResponse ($conn);
723        next if $response =~ /APPEND complete/i;   # Ignore strays
724        if ( $response =~ /^1 OK/i ) {
725           last;
726        } elsif ( $response !~ /^\*/ ) {
727           Log("unexpected logout response $response");
728           last;
729        }
730   }
731   close $conn;
732   return;
733}
734
735sub selectMbx {
736
737my $mbx  = shift;
738my $conn = shift;
739
740   sendCommand( $conn, "1 SUBSCRIBE \"$mbx\"");
741   while ( 1 ) {
742      readResponse( $conn );
743      if ( $response =~ /^1 OK/i ) {
744         Log("Mailbox $mbx has been subscribed") if $debug;
745         last;
746      } elsif ( $response =~ /^1 NO|^1 BAD|\^* BYE/i ) {
747         Log("Unexpected response to subscribe $mbx command: $response");
748         last;
749      }
750   }
751   sendCommand ($conn, "1 SELECT \"$mbx\"");
752   undef @response;
753   $empty=0;
754   while ( 1 ) {
755        readResponse ( $conn );
756        if ( $response =~ /^1 OK/i ) {
757           # print STDERR "response $response\n";
758           last;
759        }
760        elsif ( $response !~ /^\*/ ) {
761           Log ("unexpected response: $response");
762          return 0;
763        }
764   }
765
766}
767
768sub createMbx {
769
770my $mbx = shift;
771my $conn = shift;
772
773   #  Create a mailbox
774
775
776   sendCommand ($conn, "1 CREATE \"$mbx\"");
777   while ( 1 ) {
778      readResponse ($conn);
779      last if $response =~ /^1 OK|already exists /i;
780      if ( $response !~ /^\*/ ) {
781         if (!($response =~ /already exists|reserved mailbox name/i)) {
782            # Log ("WARNING: $response");
783         }
784         last;
785      }
786   }
787}
788
789sub getMailboxList {
790
791my $user = shift;
792my $conn = shift;
793my @mbxs;
794my @mailboxes;
795
796   #  Get a list of the user's mailboxes
797   #
798  if ( $mbxList ) {
799      #  The user has supplied a list of mailboxes so only processes
800      #  the ones in that list
801      @mbxs = split(/,/, $mbxList);
802      foreach $mbx ( @mbxs ) {
803         trim( *mbx );
804         push( @mailboxes, $mbx );
805      }
806      return @mailboxes;
807   }
808
809   if ($debug) { Log("Get list of user's mailboxes",2); }
810
811   sendCommand ($conn, "1 LIST \"\" *");
812   undef @response;
813   while ( 1 ) {
814	readResponse ($conn);
815	if ( $response =~ /^1 OK/i ) {
816		last;
817	}
818	elsif ( $response !~ /^\*/ ) {
819		Log ("unexpected response: $response");
820		return 0;
821	}
822   }
823
824   undef @mbxs;
825
826   for $i (0 .. $#response) {
827        $response[$i] =~ s/\s+/ /;
828        if ( $response[$i] =~ /"$/ ) {
829           $response[$i] =~ /\* LIST \((.*)\) "(.+)" "(.+)"/i;
830           $mbx = $3;
831        } else {
832           $response[$i] =~ /\* LIST \((.*)\) "(.+)" (.+)/i;
833           $mbx = $3;
834        }
835	$mbx =~ s/^\s+//;  $mbx =~ s/\s+$//;
836
837	if ($response[$i] =~ /NOSELECT/i) {
838		if ($debug) { Log("$mbx is set NOSELECT,skip it",2); }
839		next;
840	}
841	if (($mbx =~ /^\#/) && ($user ne 'anonymous')) {
842		#  Skip public mbxs unless we are migrating them
843		next;
844	}
845	if ($mbx =~ /^\./) {
846		# Skip mailboxes starting with a dot
847		next;
848	}
849	push ( @mbxs, $mbx ) if $mbx ne '';
850   }
851
852   if ( $mbxList ) {
853      #  The user has supplied a list of mailboxes so only processes
854      #  those
855      @mbxs = split(/,/, $mbxList);
856   }
857
858   return @mbxs;
859}
860
861#  getMsgList
862#
863#  Get a list of the user's messages in the indicated mailbox on
864#  the source host
865#
866sub getMsgList {
867
868my $mailbox = shift;
869my $msgs    = shift;
870my $conn    = shift;
871my $seen;
872my $empty;
873my $msgnum;
874my $from;
875my $flags;
876
877   @$msgs  = ();
878   trim( *mailbox );
879   sendCommand ($conn, "1 EXAMINE \"$mailbox\"");
880   undef @response;
881   $empty=0;
882   while ( 1 ) {
883	readResponse ( $conn );
884	if ( $response =~ / 0 EXISTS/i ) { $empty=1; }
885	if ( $response =~ /^1 OK/i ) {
886		# print STDERR "response $response\n";
887		last;
888	}
889	elsif ( $response !~ /^\*/ ) {
890		Log ("unexpected response: $response");
891		# print STDERR "Error: $response\n";
892		return 0;
893	}
894   }
895
896   if ( $empty ) {
897      Log("$mailbox is empty");
898      return;
899   }
900
901   Log("Fetch the header info") if $debug;
902
903   sendCommand ( $conn, "1 FETCH 1:* (uid flags internaldate body[header.fields (From Date)])");
904   undef @response;
905   while ( 1 ) {
906	readResponse ( $conn );
907	return if $conn_timed_out;
908	if ( $response =~ /^1 OK/i ) {
909	   last;
910	} elsif ( $response =~ /could not be processed/i ) {
911           Log("Error:  response from server: $response");
912           return;
913        } elsif ( $response =~ /^1 NO|^1 BAD/i ) {
914           return;
915        }
916   }
917
918   $flags = '';
919   for $i (0 .. $#response) {
920	$seen=0;
921	$_ = $response[$i];
922
923	last if /OK FETCH complete/;
924
925        if ($response[$i] =~ /FLAGS/) {
926           #  Get the list of flags
927           $response[$i] =~ /FLAGS \(([^\)]*)/;
928           $flags = $1;
929           $flags =~ s/\\Recent//;
930        }
931
932        if ( $response[$i] =~ /INTERNALDATE/) {
933           $response[$i] =~ /INTERNALDATE (.+) BODY/;
934           # $response[$i] =~ /INTERNALDATE "(.+)" BODY/;
935           $date = $1;
936
937           $date =~ /"(.+)"/;
938           $date = $1;
939           $date =~ s/"//g;
940        }
941
942        if ( $response[$i] =~ /\* (.+) FETCH/ ) {
943           ($msgnum) = split(/\s+/, $1);
944        }
945
946        if ( $msgnum && $date ) {
947           if ( $unseen ) {
948	      push (@$msgs,"$msgnum|$date|$flags") unless $flags =~ /Seen/i;
949           } else {
950	      push (@$msgs,"$msgnum|$date|$flags");
951           }
952           $msgnum = $date = '';
953        }
954   }
955
956}
957
958#  insert_imap_msg
959#
960#  This routine inserts an RFC822 message into a user's folder
961#
962sub insert_imap_msg {
963
964my $conn    = shift;
965my $mbx     = shift;
966my $message = shift;
967my $flags   = shift;
968my $date    = shift;
969my ($lsn,$lenx);
970
971   $lenx = length($$message);
972   Log("   Inserting message") if $debug;
973   Log("message size $lenx bytes");
974
975   $date =~ s/\((.+)\)//;
976   $date =~ s/\s+$//g;
977
978   $totalBytes = $totalBytes + $lenx;
979   $totalMsgs++;
980
981   #  Create the mailbox unless we have already done so
982   if ($destMbxs{"$mbx"} eq '') {
983      createMbx( $mbx, $conn );
984   }
985   $destMbxs{"$mbx"} = '1';
986
987   $flags =~ s/\\Recent//i;
988   $flags =~ s/Unseen//i;
989
990   if ( $date ) {
991      sendCommand ($conn, "1 APPEND \"$mbx\" ($flags) \"$date\" \{$lenx\}");
992   } else {
993      sendCommand ($conn, "1 APPEND \"$mbx\" ($flags) \{$lenx\}");
994   }
995
996   readResponse ($conn);
997   if ($conn_timed_out) {
998       Log ("unexpected response timeout appending message");
999       push(@errors,"Error appending message to $mbx for $user");
1000       return 0;
1001   }
1002
1003   if ( $response !~ /^\+/ ) {
1004       Log ("unexpected APPEND response: >$response<");
1005       # next;
1006       push(@errors,"Error appending message to $mbx for $user");
1007       return 0;
1008   }
1009
1010   print $conn "$$message\r\n";
1011
1012   undef @response;
1013   while ( 1 ) {
1014       readResponse ($conn);
1015       if ( $response =~ /^1 OK/i ) {
1016	   last;
1017       }
1018       elsif ( $response !~ /^\*/ ) {
1019	   Log ("Unexpected APPEND response: >$response<");
1020	   # next;
1021	   return 0;
1022       }
1023   }
1024
1025   return 1;
1026}
1027
1028sub mbxExists {
1029
1030my $mbx  = shift;
1031my $conn = shift;
1032my $status = 1;
1033
1034   #  Determine whether a mailbox exists
1035   sendCommand ($conn, "1 SELECT \"$mbx\"");
1036   while (1) {
1037        readResponse ($conn);
1038        last if $response =~ /^1 OK/i;
1039        if ( $response =~ /^1 NO|^1 BAD|^\* BYE/ ) {
1040           $status = 0;
1041           last;
1042        }
1043   }
1044
1045   return $status;
1046}
1047
1048sub get_maildir_folders {
1049
1050my $userpath = shift;
1051my $folders  = shift;
1052
1053   #  Get a list of the user's folders
1054
1055   %$folders = ();
1056
1057   if ( $mbxList ) {
1058      #  The user has supplied a list of mailboxes
1059      foreach $mbx ( split(/,/, $mbxList ) ) {
1060         $$folders{"$mbx"} = $userpath . '/.' . $mbx;
1061      }
1062      return;
1063   }
1064
1065   opendir D, $userpath;
1066   my @files = readdir( D );
1067   closedir D;
1068
1069   $$folders{'INBOX'} = $userpath;
1070   foreach $fn ( @files ) {
1071      next if $fn eq '.';
1072      next if $fn eq '..';
1073      next unless $fn =~ /^\./;
1074      my $fname = $fn;
1075      $fname =~ s/\./\//;
1076      $fname =~ s/^\///;
1077      $$folders{"$fname"} = "$userpath/$fn";
1078   }
1079
1080}
1081
1082sub get_maildir_msgs {
1083
1084my $path = shift;
1085my $msgs = shift;
1086my @subdirs = qw( tmp cur new );
1087
1088   @$msgs = ();
1089   foreach $subdir ( @subdirs ) {
1090      opendir D, "$path/$subdir";
1091      my @files = readdir( D );
1092      closedir D;
1093
1094      foreach $fn ( @files ) {
1095         next if $fn =~ /^\./;
1096         my $msgfn = "$path/$subdir/$fn";
1097         push( @$msgs, $msgfn );
1098      }
1099   }
1100
1101}
1102
1103sub imap_message_exists {
1104
1105my $msgid = shift;
1106my $conn  = shift;
1107my $msgnum;
1108my $loops;
1109
1110   # Search a mailbox on the server for a message by its msgid.
1111
1112   Log("   Search for $msgid") if $debug;
1113   sendCommand ( $conn, "1 SEARCH header Message-Id \"$msgid\"");
1114   while (1) {
1115        readResponse ($conn);
1116        if ( $response =~ /\* SEARCH /i ) {
1117           ($dmy, $msgnum) = split(/\* SEARCH /i, $response);
1118           ($msgnum) = split(/ /, $msgnum);
1119        }
1120
1121        last if $response =~ /^1 OK|^1 NO|^1 BAD/;
1122        last if $response =~ /complete/i;
1123
1124        last if $loops++ > 10;
1125   }
1126
1127   if ( $debug ) {
1128      Log("$msgid was not found") unless $msgnum;
1129   }
1130
1131   return $msgnum;
1132}
1133
1134sub fix_date {
1135
1136my $date = shift;
1137
1138   #  Try to make the date acceptable to IMAP
1139
1140   return if $$date eq '';
1141   fix_ts( $date );
1142
1143   $$date =~ s/\((.+)\)$//;
1144   $$date =~ s/\s+$//g;
1145
1146   if ( $$date =~ /\s*,\s*/ ) {
1147      ($dow,$$date) = split(/\s*,\s*/, $$date);
1148   }
1149   $$date =~ s/ /-/;
1150   $$date =~ s/ /-/;
1151
1152   return;
1153
1154   my @terms = split(/\s+/, $$date);
1155
1156   if ( $terms[0] =~ /(.+),/ ) {
1157      my $dow = $1;
1158      if ( length( $dow ) > 3 ) {
1159         #  Day of week can't be more than 3 chars
1160         my $DOW = substr($dow,0,3);
1161         $$date =~ s/$dow/$DOW/;
1162      }
1163   }
1164
1165   if ( $terms[1] =~ /jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec/i ) {
1166      #  The month and day are swapped.
1167      my $temp = $terms[1];
1168      $terms[1] = $terms[2];
1169      $terms[2] = $temp;
1170   }
1171
1172   if ( $terms[5] =~ /\((.+)\)/ ) {
1173      #  The date is missing the TZ offset
1174      $terms[5] = "+0000 ($1)";
1175   }
1176
1177   if ( $terms[5] =~ /"(.+)"/ ) {
1178      #  The TZ code has quotes instead of parens
1179      $terms[5] =~ s/"/\(/;
1180      $terms[5] =~ s/"/\)/;
1181      $terms[5] = "+0000 $terms[5]";
1182   }
1183
1184   if ( $terms[5] =~ /-[0-9]-[0-9][0-9]/ ) {
1185      #  Lots of dates are like '-0-500'
1186      $terms[5] =~ s/-//g;
1187      $terms[5] = '-' . $terms[5];
1188   }
1189
1190   if ( $terms[5] eq '-0-100' ) {
1191      #  Don't know what this is supposed to mean
1192      $terms[5] = "+0000";
1193   }
1194
1195   if ( $terms[5] eq '00800' ) {
1196      $terms[5] = "+0800";
1197   }
1198
1199   if ( $terms[5] eq '-' ) {
1200      $terms[5] .= $terms[6];
1201      $terms[5] =~ s/\s+//g;
1202      $terms[6] = '';
1203   }
1204   if ( $terms[4] =~ /\./ ) {
1205      $terms[4] =~ s/\./:/g;
1206   }
1207
1208   if ( $terms[5] =~ /[a-zA-Z]/ ) {
1209      $terms[5] = "-0000 ($terms[5])" unless $terms[5] eq 'UT';
1210   }
1211
1212   $$date = join( " ", @terms );
1213
1214}
1215
1216