1#!/usr/local/bin/perl
2
3# $Header$
4
5#######################################################################
6#   Program name    trash.pl                                          #
7#   Written by      Rick Sanders                                      #
8#   Date            10/7/2003                                         #
9#                                                                     #
10#   Description                                                       #
11#                                                                     #
12#   This script checks a user's IMAP mailboxes for deleted messages   #
13#   which it moves to the trash mailbox.  Optionally the trash        #
14#   mailbox is emptied.                                               #
15#                                                                     #
16#   trash.pl is called like this:                                     #
17#       ./trash.pl -S host/user/password                              #
18#                                                                     #
19#   Optional arguments:                                               #
20#	-d debug                                                      #
21#       -t <trash mailbox name> (defaults to 'Trash')                 #
22#       -e empty the trash mailbox (default is not to empty it)       #
23#       -L <logfile>                                                  #
24#       -m mailbox list (check just certain mailboxes,see usage notes)#
25#######################################################################
26
27use Socket;
28use FileHandle;
29use Fcntl;
30use Getopt::Std;
31
32
33#################################################################
34#            Main program.                                      #
35#################################################################
36
37   &init();
38   &sigprc();
39
40   #  Get list of all messages on the source host by Message-Id
41   #
42   &connectToHost($sourceHost, 'SRC');
43   &login($sourceUser,$sourcePwd, 'SRC');
44   @mbxs = &getMailboxList($sourceUser, 'SRC');
45
46   print STDOUT "Checking mailboxes for deleted messages...\n";
47   foreach $mbx ( @mbxs ) {
48       print STDOUT "   Checking mailbox $mbx for deleted messages\n" if $debug;
49       %msgList = ();
50       @sourceMsgs = ();
51       &getDeletedMsgs( $mbx, \@msgs, 'SRC' );
52       &moveToTrash( $mbx, $trash, \@msgs, 'SRC' );
53       &expungeMbx( $mbx, 'SRC' );
54   }
55
56   print STDOUT "\n$total messages were moved to $trash\n";
57
58   if ( $emptyTrash && ($total > 0) ) {
59      &expungeMbx( $trash, 'SRC' );
60      print STDOUT "The $trash mailbox has been emptied\n\n";
61   }
62
63   &logout( 'SRC' );
64
65   exit;
66
67
68sub init {
69
70   $version = 'V1.0';
71   $os = $ENV{'OS'};
72
73   &processArgs;
74
75   if ($timeout eq '') { $timeout = 60; }
76
77   #  Open the logFile
78   #
79   if ( $logfile ) {
80      if ( !open(LOG, ">> $logfile")) {
81         print STDOUT "Can't open $logfile: $!\n";
82      }
83      select(LOG); $| = 1;
84   }
85   &Log("\n$0 starting");
86   $total=0;
87
88}
89
90#
91#  sendCommand
92#
93#  This subroutine formats and sends an IMAP protocol command to an
94#  IMAP server on a specified connection.
95#
96
97sub sendCommand
98{
99    local($fd) = shift @_;
100    local($cmd) = shift @_;
101
102    print $fd "$cmd\r\n";
103
104    if ($showIMAP) { &Log (">> $cmd",2); }
105}
106
107#
108#  readResponse
109#
110#  This subroutine reads and formats an IMAP protocol response from an
111#  IMAP server on a specified connection.
112#
113
114sub readResponse
115{
116    local($fd) = shift @_;
117
118    $response = <$fd>;
119    chop $response;
120    $response =~ s/\r//g;
121    push (@response,$response);
122    if ($showIMAP) { &Log ("<< $response",2); }
123}
124
125#
126#  Log
127#
128#  This subroutine formats and writes a log message to STDERR.
129#
130
131sub Log {
132
133my $str = shift;
134
135   #  If a logile has been specified then write the output to it
136   #  Otherwise write it to STDOUT
137
138   if ( $logfile ) {
139      ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
140      if ($year < 99) { $yr = 2000; }
141      else { $yr = 1900; }
142      $line = sprintf ("%.2d-%.2d-%d.%.2d:%.2d:%.2d %s %s\n",
143		     $mon + 1, $mday, $year + $yr, $hour, $min, $sec,$$,$str);
144      print LOG "$line";
145   } else {
146      print STDOUT "$str\n";
147   }
148
149}
150
151#  connectToHost
152#
153#  Make an IMAP4 connection to a host
154#
155sub connectToHost {
156
157my $host = shift;
158my $conn = shift;
159
160   &Log("Connecting to $host") if $debug;
161
162   $sockaddr = 'S n a4 x8';
163   ($name, $aliases, $proto) = getprotobyname('tcp');
164   ($host,$port) = split(/:/, $host);
165   $port = 143 if !$port;
166
167   if ($host eq "") {
168	&Log ("no remote host defined");
169	close LOG;
170	exit (1);
171   }
172
173   ($name, $aliases, $type, $len, $serverAddr) = gethostbyname ($host);
174   if (!$serverAddr) {
175	&Log ("$host: unknown host");
176	close LOG;
177	exit (1);
178   }
179
180   #  Connect to the IMAP4 server
181   #
182
183   $server = pack ($sockaddr, &AF_INET, $port, $serverAddr);
184   if (! socket($conn, &PF_INET, &SOCK_STREAM, $proto) ) {
185	&Log ("socket: $!");
186	close LOG;
187	exit (1);
188   }
189   if ( ! connect( $conn, $server ) ) {
190	&Log ("connect: $!");
191	return 0;
192   }
193
194   select( $conn ); $| = 1;
195   while (1) {
196	&readResponse ( $conn );
197	if ( $response =~ /^\* OK/i ) {
198	   last;
199	}
200	else {
201 	   &Log ("Can't connect to host on port $port: $response");
202	   return 0;
203	}
204   }
205   &Log ("connected to $host") if $debug;
206
207   select( $conn ); $| = 1;
208   return 1;
209}
210
211#  trim
212#
213#  remove leading and trailing spaces from a string
214sub trim {
215
216local (*string) = @_;
217
218   $string =~ s/^\s+//;
219   $string =~ s/\s+$//;
220
221   return;
222}
223
224
225#  login
226#
227#  login in at the source host with the user's name and password
228#
229sub login {
230
231my $user = shift;
232my $pwd  = shift;
233my $conn = shift;
234
235   $rsn = 1;
236   &sendCommand ($conn, "$rsn LOGIN $user $pwd");
237   while (1) {
238	&readResponse ( $conn );
239	if ($response =~ /^$rsn OK/i) {
240		last;
241	}
242	elsif ($response =~ /NO/) {
243		&Log ("unexpected LOGIN response: $response");
244		return 0;
245	}
246   }
247   &Log("Logged in as $user") if $debug;
248
249   return 1;
250}
251
252
253#  logout
254#
255#  log out from the host
256#
257sub logout {
258
259my $conn = shift;
260
261   ++$lsn;
262   undef @response;
263   &sendCommand ($conn, "$lsn LOGOUT");
264   while ( 1 ) {
265	&readResponse ($conn);
266	if ( $response =~ /^$lsn OK/i ) {
267		last;
268	}
269	elsif ( $response !~ /^\*/ ) {
270		&Log ("unexpected LOGOUT response: $response");
271		last;
272	}
273   }
274   close $conn;
275   return;
276}
277
278
279#  getMailboxList
280#
281#  get a list of the user's mailboxes from the source host
282#
283sub getMailboxList {
284
285my $user = shift;
286my $conn = shift;
287my @mbxs;
288
289   #  Get a list of the user's mailboxes
290   #
291  if ( $mbxList ) {
292      #  The user has supplied a list of mailboxes so only processes
293      #  the ones in that list
294      @mbxs = split(/,/, $mbxList);
295      for $i (0..$#mbxs ) {
296	$mbxs[$i] =~ s/^\s+//;
297	$mbxs[$i] =~ s/s+$//;
298      }
299      return @mbxs;
300   }
301
302   if ($debugMode) { &Log("Get list of user's mailboxes",2); }
303
304   &sendCommand ($conn, "$rsn LIST \"\" *");
305   undef @response;
306   while ( 1 ) {
307	&readResponse ($conn);
308	if ( $response =~ /^$rsn OK/i ) {
309		last;
310	}
311	elsif ( $response !~ /^\*/ ) {
312		&Log ("unexpected response: $response");
313		return 0;
314	}
315   }
316
317   undef @mbxs;
318   for $i (0 .. $#response) {
319	# print STDERR "$response[$i]\n";
320	$response[$i] =~ s/\s+/ /;
321	($dmy,$mbx) = split(/"\/"/,$response[$i]);
322	$mbx =~ s/^\s+//;  $mbx =~ s/\s+$//;
323	$mbx =~ s/"//g;
324
325	if ($response[$i] =~ /NOSELECT/i) {
326		if ($debugMode) { &Log("$mbx is set NOSELECT,skip it",2); }
327		next;
328	}
329	if (($mbx =~ /^\#/) && ($user ne 'anonymous')) {
330		#  Skip public mbxs unless we are migrating them
331		next;
332	}
333	if ($mbx =~ /^\./) {
334		# Skip mailboxes starting with a dot
335		next;
336	}
337	push ( @mbxs, $mbx ) if $mbx ne '';
338   }
339
340   if ( $mbxList ) {
341      #  The user has supplied a list of mailboxes so only processes
342      #  those
343      @mbxs = split(/,/, $mbxList);
344   }
345
346   return @mbxs;
347}
348
349
350#  getDeletedMsgs
351#
352#  Get a list of deleted messages in the indicated mailbox on
353#  the source host
354#
355sub getDeletedMsgs {
356
357my $mailbox = shift;
358my $msgs    = shift;
359my $conn    = shift;
360my $seen;
361my $empty;
362my $msgnum;
363
364   &trim( *mailbox );
365   &sendCommand ($conn, "$rsn SELECT \"$mailbox\"");
366   undef @response;
367   $empty=0;
368   while ( 1 ) {
369	&readResponse ( $conn );
370	if ( $response =~ /^$rsn OK/i ) {
371		# print STDERR "response $response\n";
372		last;
373        } elsif ( $response =~ / 0 EXISTS/i ) {
374                $empty = 1;
375	} elsif ( $response !~ /^\*/ ) {
376		&Log ("unexpected response: $response");
377		print STDERR "Error: $response\n";
378		return 0;
379	}
380   }
381
382   return if $empty;
383
384   &sendCommand ( $conn, "$rsn FETCH 1:* (uid flags internaldate body[header.fields (Message-ID Subject)])");
385   undef @response;
386   while ( 1 ) {
387	&readResponse ( $conn );
388	if ( $response =~ /^$rsn OK/i ) {
389		# print STDERR "response $response\n";
390		last;
391	}
392        elsif ( $response =~ /Broken pipe|Connection reset by peer/i ) {
393              print STDOUT "Fetch from $mailbox: $response\n";
394              exit;
395        }
396   }
397
398   #  Get a list of the msgs in the mailbox
399   #
400   undef @msgs;
401   undef $flags;
402   for $i (0 .. $#response) {
403	$seen=0;
404	$_ = $response[$i];
405
406	last if /OK FETCH complete/;
407
408	if ( $response[$i] =~ /FETCH \(UID / ) {
409	   $response[$i] =~ /\* ([^FETCH \(UID]*)/;
410	   $msgnum = $1;
411	}
412
413	if ($response[$i] =~ /FLAGS/) {
414	    #  Get the list of flags
415            $deleted = 0;
416	    $response[$i] =~ /FLAGS \(([^\)]*)/;
417	    $flags = $1;
418            $deleted = 1 if $flags =~ /Deleted/i;
419	}
420        if ( $response[$i] =~ /INTERNALDATE ([^\)]*)/ ) {
421	    $response[$i] =~ /INTERNALDATE ([^BODY]*)/i;
422            $date = $1;
423            $date =~ s/"//g;
424	}
425        if ( $response[$i] =~ /^Subject:/ ) {
426	   $response[$i] =~ /Subject: (.+)/;
427           $subject = $1;
428        }
429	if ( $response[$i] =~ /^Message-Id:/ ) {
430	    ($label,$msgid) = split(/: /, $response[$i]);
431            &trim(*msgid);
432            $msgid =~ s/^\<//;
433            $msgid =~ s/\>$//;
434            push( @$msgs, $msgnum ) if $deleted;
435	}
436   }
437}
438
439
440sub fetchMsg {
441
442my $msgnum = shift;
443my $mbx    = shift;
444my $conn   = shift;
445my $message;
446
447   &Log("   Fetching msg $msgnum...") if $debug;
448   &sendCommand ($conn, "$rsn SELECT \"$mbx\"");
449   while (1) {
450        &readResponse ($conn);
451	last if ( $response =~ /^$rsn OK/i );
452   }
453
454   &sendCommand( $conn, "$rsn FETCH $msgnum (rfc822)");
455   while (1) {
456	&readResponse ($conn);
457	if ( $response =~ /^$rsn OK/i ) {
458		$size = length($message);
459		last;
460	}
461	elsif ($response =~ /message number out of range/i) {
462		&Log ("Error fetching uid $uid: out of range",2);
463		$stat=0;
464		last;
465	}
466	elsif ($response =~ /Bogus sequence in FETCH/i) {
467		&Log ("Error fetching uid $uid: Bogus sequence in FETCH",2);
468		$stat=0;
469		last;
470	}
471	elsif ( $response =~ /message could not be processed/i ) {
472		&Log("Message could not be processed, skipping it ($user,msgnum $msgnum,$destMbx)");
473		push(@errors,"Message could not be processed, skipping it ($user,msgnum $msgnum,$destMbx)");
474		$stat=0;
475		last;
476	}
477	elsif
478	   ($response =~ /^\*\s+$msgnum\s+FETCH\s+\(.*RFC822\s+\{[0-9]+\}/i) {
479		($len) = ($response =~ /^\*\s+$msgnum\s+FETCH\s+\(.*RFC822\s+\{([0-9]+)\}/i);
480		$cc = 0;
481		$message = "";
482		while ( $cc < $len ) {
483			$n = 0;
484			$n = read ($conn, $segment, $len - $cc);
485			if ( $n == 0 ) {
486				&Log ("unable to read $len bytes");
487				return 0;
488			}
489			$message .= $segment;
490			$cc += $n;
491		}
492	}
493   }
494
495   return $message;
496
497}
498
499
500sub usage {
501
502   print STDOUT "usage:\n";
503   print STDOUT " trash.pl -S sourceHost/sourceUser/sourcePassword\n";
504   print STDOUT " Optional arguments:\n";
505   print STDOUT "    -d debug\n";
506   print STDOUT "    -t <trash mailbox name>\n";
507   print STDOUT "    -e empty trash mailbox\n";
508   print STDOUT "    -L <logfile>\n";
509   print STDOUT "    -m <mailbox list> (eg \"Inbox, Drafts, Notes\". Default is all mailboxes)\n";
510   exit;
511
512}
513
514sub processArgs {
515
516   if ( !getopts( "dS:L:m:ht:e" ) ) {
517      &usage();
518   }
519
520   ($sourceHost,$sourceUser,$sourcePwd) = split(/\//, $opt_S);
521   $mbxList = $opt_m;
522   $logfile = $opt_L;
523   $trash   = $opt_t;
524   $emptyTrash = 1 if $opt_e;
525   $debug = $showIMAP = 1 if $opt_d;
526
527   &usage() if $opt_h;
528   $trash = 'Trash' if !$trash;
529
530}
531
532sub findMsg {
533
534my $conn  = shift;
535my $msgid = shift;
536my $mbx   = shift;
537my $msgnum;
538
539   &Log("SELECT $mbx") if $debug;
540   &sendCommand ( $conn, "1 SELECT \"$mbx\"");
541   while (1) {
542	&readResponse ($conn);
543	last if $response =~ /^1 OK/;
544   }
545
546   &Log("Search for $msgid") if $debug;
547   &sendCommand ( $conn, "$rsn SEARCH header Message-Id \"$msgid\"");
548   while (1) {
549	&readResponse ($conn);
550	if ( $response =~ /\* SEARCH /i ) {
551	   ($dmy, $msgnum) = split(/\* SEARCH /i, $response);
552	   ($msgnum) = split(/ /, $msgnum);
553	}
554
555	last if $response =~ /^1 OK/;
556	last if $response =~ /complete/i;
557   }
558
559   return $msgnum;
560}
561
562sub deleteMsg {
563
564my $conn   = shift;
565my $mbx    = shift;
566my $msgnum = shift;
567my $rc;
568
569   &sendCommand ( $conn, "1 STORE $msgnum +FLAGS (\\Deleted)");
570   while (1) {
571        &readResponse ($conn);
572        if ( $response =~ /^1 OK/i ) {
573	   $rc = 1;
574	   &Log("      Marked msg number $msgnum for delete");
575	   last;
576	}
577
578	if ( $response =~ /^1 BAD|^1 NO/i ) {
579	   &Log("Error setting \Deleted flag for msg $msgnum: $response");
580	   $rc = 0;
581	   last;
582	}
583   }
584
585   return $rc;
586
587}
588
589sub expungeMbx {
590
591my $mbx   = shift;
592my $conn  = shift;
593
594   print STDOUT "Purging mailbox $mbx..." if $debug;
595
596   &sendCommand ($conn, "$rsn SELECT \"$mbx\"");
597   while (1) {
598        &readResponse ($conn);
599        last if ( $response =~ /^$rsn OK/i );
600   }
601
602   &sendCommand ( $conn, "1 EXPUNGE");
603   $expunged=0;
604   while (1) {
605        &readResponse ($conn);
606        $expunged++ if $response =~ /\* (.+) Expunge/i;
607        last if $response =~ /^1 OK/;
608
609	if ( $response =~ /^1 BAD|^1 NO/i ) {
610	   print "Error purging messages: $response\n";
611	   last;
612	}
613   }
614
615   $totalExpunged += $expunged;
616
617   # print STDOUT "$expunged messages purged\n" if $debug;
618
619}
620
621sub checkForAdds {
622
623my $added=0;
624
625   &Log("Checking for messages to add to $destHost/$destUser");
626   foreach $key ( @sourcekeys ) {
627        if ( $destList{"$key"} eq '' ) {
628             $entry = $sourceList{"$key"};
629             ($msgid,$mbx) = split(/\|\|\|\|\|\|/, $key);
630             ($msgnum,$flags,$date) = split(/\|\|\|\|\|\|/, $entry);
631             &Log("   Adding $msgid to $mbx");
632
633             #  Need to add this message to the dest host
634
635             $message = &fetchMsg( $msgnum, $mbx, 'SRC' );
636
637             &insertMsg( 'DST', $mbx, *message, $flags, $date );
638             $added++;
639        }
640   }
641   return $added;
642
643}
644
645
646sub checkForUpdates {
647
648my $updated=0;
649
650   #  Compare the flags for the message on the source with the
651   #  one on the dest.  Update the dest flags if they are different
652
653   &Log("Checking for flag changes to $destHost/$destUser");
654   foreach $key ( @sourcekeys ) {
655        $entry = $sourceList{"$key"};
656        ($msgid,$mbx) = split(/\|\|\|\|\|\|/, $key);
657        ($msgnum,$srcflags,$date) = split(/\|\|\|\|\|\|/, $entry);
658
659        if ( $destList{"$key"} ne '' ) {
660             $entry = $destList{"$key"};
661             ($msgid,$mbx) = split(/\|\|\|\|\|\|/, $key);
662             ($msgnum,$dstflags,$date) = split(/\|\|\|\|\|\|/, $entry);
663
664	     $srcflags  =~ s/\\Recent//;
665	     $destflags =~ s/\\Recent//;
666	     if ( $srcflags ne $dstflags ) {
667		&Log("Need to update the flags for $msgid") if $debug;
668		$updated++ if &updateFlags( 'DST', $msgid, $mbx, $srcflags );
669	     }
670	}
671   }
672   return $updated;
673}
674
675sub updateFlags {
676
677my $conn  = shift;
678my $msgid = shift;
679my $mbx   = shift;
680my $flags = shift;
681my $rc;
682
683   if ( $debug ) {
684      &Log("Find $msgid");
685      &Log("flags $flags");
686   }
687
688   $msgnum = &findMsg( $conn, $msgid, $mbx );
689   &Log("msgnum is $msgnum") if $debug;
690
691   &sendCommand ( $conn, "1 STORE $msgnum +FLAGS ($flags)");
692   while (1) {
693        &readResponse ($conn);
694        if ( $response =~ /^1 OK/i ) {
695	   &Log("   Updated flags for $msgid");
696	   $rc = 1;
697	   last;
698	}
699
700        if ( $response =~ /^1 BAD|^1 NO/i ) {
701           &Log("Error setting flags for $msgid: $response");
702	   $rc = 0;
703           last;
704        }
705   }
706   return $rc;
707}
708
709sub dieright {
710   local($sig) = @_;
711   print STDOUT "caught signal $sig\n";
712   &logout( 'SRC' );
713   exit(-1);
714}
715
716sub sigprc {
717
718   $SIG{'HUP'} = 'dieright';
719   $SIG{'INT'} = 'dieright';
720   $SIG{'QUIT'} = 'dieright';
721   $SIG{'ILL'} = 'dieright';
722   $SIG{'TRAP'} = 'dieright';
723   $SIG{'IOT'} = 'dieright';
724   $SIG{'EMT'} = 'dieright';
725   $SIG{'FPE'} = 'dieright';
726   $SIG{'BUS'} = 'dieright';
727   $SIG{'SEGV'} = 'dieright';
728   $SIG{'SYS'} = 'dieright';
729   $SIG{'PIPE'} = 'dieright';
730   $SIG{'ALRM'} = 'dieright';
731   $SIG{'TERM'} = 'dieright';
732   $SIG{'URG'} = 'dieright';
733}
734
735sub moveToTrash {
736
737my $mbx   = shift;
738my $trash = shift;
739my $msgs  = shift;
740my $conn  = shift;
741my $msglist;
742my $moved;
743
744   return if $mbx eq $trash;
745   return if $#$msgs == -1;
746
747   foreach $msgnum ( @$msgs ) {
748      $moved++;
749      $msglist .= "$msgnum,";
750   }
751
752   chop $msglist;
753
754   &sendCommand ($conn, "1 COPY $msglist $trash");
755   while (1) {
756        &readResponse ( $conn );
757        last if $response =~ /^1 OK/i;
758        if ($response =~ /NO/) {
759           print STDOUT "unexpected COPY response: $response\n";
760           print STDOUT "Please verify that mailbox $trash exists\n";
761           exit;
762        }
763   }
764   print STDOUT "   Moved $moved messages from $mbx to $trash\n";
765   $total += $moved;
766
767}
768