1#!/usr/local/bin/perl
2
3# $Header: /mhub4/sources/imap-tools/list_imap_folders.pl,v 1.1 2012/03/15 15:12:36 rick Exp $
4
5#######################################################################
6#   list_imap_folders.pl is called like this:                         #
7#      ./list_folders.pl -S host/user/password [-O <output file>]     #
8#                                                                     #
9#  If you have mailboxes with non-ASCII characters then to render     #
10#  them from the IMAP UTF-7 encoding you must install the Perl Module #
11#  Unicode::IMAPUtf7.  It's available from the CPAN web site.         #
12#######################################################################
13
14use Socket;
15use FileHandle;
16use Fcntl;
17use Getopt::Std;
18use IO::Socket;
19use IMAP::Utils;
20
21#################################################################
22#################################################################
23
24   init();
25
26   connectToHost($sourceHost, \$src)   or exit;
27   login($sourceUser,$sourcePwd, $src, $srcMethod) or exit;
28   namespace( $src, \$srcPrefix, \$srcDelim, $opt_x );
29   @mbxs = getMailboxList( $srcPrefix, $src );
30
31   @mbxs = sort @mbxs;
32
33   if ( $output_file ) {
34      open(OUT, ">$output_file") or die "Can't open output file $output_file: $!";
35   }
36   foreach $mbx ( @mbxs ) {
37         $mbx =~ s/^$srcPrefix//;
38         $mbx =~ s/[$srcDelim]/\//g;
39         if ( $utf ) {
40            $mbx = Unicode::IMAPUtf7::imap_utf7_decode( $mbx );
41         }
42         if ( $output_file ) {
43            print OUT "$mbx\n";
44         } else {
45            print STDOUT "$mbx\n";
46         }
47   }
48   close OUT;
49   print STDOUT "Wrote list of mailboxes to $output_file\n" if $output_file;
50
51   logout( $src );
52
53   exit;
54
55
56sub init {
57
58   $os = $ENV{'OS'};
59
60   processArgs();
61
62   if ($timeout eq '') { $timeout = 60; }
63
64   IMAP::Utils::init();
65   #  Open the logFile
66   #
67   if ( $logfile ) {
68      openLog($logfile);
69   }
70
71   $utf = 1;
72   eval 'use Unicode::IMAPUtf7';
73   if ( $@ ) {
74      $utf = 0;
75   }
76
77   #  Set up signal handling
78   $SIG{'ALRM'} = 'signalHandler';
79   $SIG{'HUP'}  = 'signalHandler';
80   $SIG{'INT'}  = 'signalHandler';
81   $SIG{'TERM'} = 'signalHandler';
82   $SIG{'URG'}  = 'signalHandler';
83
84}
85
86#  getMailboxList
87#
88#  get a list of the user's mailboxes from the source host
89#
90sub getMailboxList {
91
92my $prefix = shift;
93my $conn   = shift;
94my @mbxs;
95
96   #  Get a list of the user's mailboxes
97   #
98
99   Log("Get list of user's mailboxes",2) if $debugMode;
100
101   if ( $mbxList ) {
102      foreach $mbx ( split(/,/, $mbxList) ) {
103         $mbx = $prefix . $mbx if $prefix;
104         if ( $opt_R ) {
105            # Get all submailboxes under the ones specified
106            $mbx .= '*';
107            @mailboxes = listMailboxes( $mbx, $conn);
108            push( @mbxs, @mailboxes );
109         } else {
110            push( @mbxs, $mbx );
111         }
112      }
113   } else {
114      #  Get all mailboxes
115      @mbxs = listMailboxes( '*', $conn);
116   }
117
118   return @mbxs;
119}
120
121sub processArgs {
122
123   if ( !getopts( "dS:L:O:uhH" ) ) {
124      usage();
125   }
126   if ( $opt_S =~ /\\/ ) {
127      ($sourceHost, $sourceUser, $sourcePwd,$srcMethod) = split(/\\/, $opt_S);
128   } else {
129      ($sourceHost, $sourceUser, $sourcePwd,$srcMethod) = split(/\//, $opt_S);
130   }
131   $showIMAP = 1 if $opt_I;
132   $utf = 1 if $opt_u;
133   $timeout = 45 unless $timeout;
134   $output_file = $opt_O;
135
136   if ( $opt_h or $opt_H ) {
137      usage();
138   }
139   unless( $sourceUser and $sourcePwd and $sourceHost ) {
140      usage();
141   }
142
143}
144
145sub namespace {
146
147my $conn      = shift;
148my $prefix    = shift;
149my $delimiter = shift;
150my $mbx_delim = shift;
151
152   #  Query the server with NAMESPACE so we can determine its
153   #  mailbox prefix (if any) and hierachy delimiter.
154
155   if ( $mbx_delim ) {
156      #  The user has supplied a mbx delimiter and optionally a prefix.
157      Log("Using user-supplied mailbox hierarchy delimiter $mbx_delim");
158      ($$delimiter,$$prefix) = split(/\s+/, $mbx_delim);
159      return;
160   }
161
162   @response = ();
163   sendCommand( $conn, "1 NAMESPACE");
164   while ( 1 ) {
165      $response = readResponse( $conn );
166      if ( $response =~ /^1 OK/i ) {
167         last;
168      } elsif ( $response =~ /^1 NO|^1 BAD|^\* BYE/i ) {
169         Log("Unexpected response to NAMESPACE command: $response");
170         last;
171      }
172   }
173
174   foreach $_ ( @response ) {
175      if ( /NAMESPACE/i ) {
176         my $i = index( $_, '((' );
177         my $j = index( $_, '))' );
178         my $val = substr($_,$i+2,$j-$i-3);
179         ($val) = split(/\)/, $val);
180         ($$prefix,$$delimiter) = split( / /, $val );
181         $$prefix    =~ s/"//g;
182         $$delimiter =~ s/"//g;
183
184         #  Experimental
185         if ( $public_mbxs ) {
186            #  Figure out the public mailbox settings
187            /\(\((.+)\)\)\s+\(\((.+)\s+\(\((.+)\)\)/;
188            $public = $3;
189            $public =~ /"(.+)"\s+"(.+)"/;
190            $src_public_prefix = $1 if $conn eq $src;
191            $src_public_delim  = $2 if $conn eq $src;
192            $dst_public_prefix = $1 if $conn eq $dst;
193            $dst_public_delim  = $2 if $conn eq $dst;
194         }
195         last;
196      }
197      last if /^1 NO|^1 BAD|^\* BYE/;
198   }
199
200   unless ( $$delimiter ) {
201      #  NAMESPACE command is not supported by the server
202      #  so we will have to figure it out another way.
203      $delim = getDelimiter( $conn );
204      $$delimiter = $delim;
205      $$prefix = '';
206   }
207
208   if ( $debug ) {
209      Log("prefix  >$$prefix<");
210      Log("delim   >$$delimiter<");
211   }
212}
213
214sub mailboxName {
215
216my $srcmbx    = shift;
217my $srcPrefix = shift;
218my $srcDelim  = shift;
219my $dstPrefix = shift;
220my $dstDelim  = shift;
221my $dstmbx;
222my $substChar = '_';
223
224   if ( $public_mbxs ) {
225      my ($public_src,$public_dst) = split(/:/, $public_mbxs );
226      #  If the mailbox starts with the public mailbox prefix then
227      #  map it to the public mailbox destination prefix
228
229      if ( $srcmbx =~ /^$public_src/ ) {
230         Log("src: $srcmbx is a public mailbox") if $debug;
231         $dstmbx = $srcmbx;
232         $dstmbx =~ s/$public_src/$public_dst/;
233         Log("dst: $dstmbx") if $debug;
234         return $dstmbx;
235      }
236   }
237
238   #  Change the mailbox name if the user has supplied mapping rules.
239
240   if ( $mbx_map{"$srcmbx"} ) {
241      $srcmbx = $mbx_map{"$srcmbx"}
242   }
243
244   #  Adjust the mailbox name if the source and destination server
245   #  have different mailbox prefixes or hierarchy delimiters.
246
247   if ( ($srcmbx =~ /[$dstDelim]/) and ($dstDelim ne $srcDelim) ) {
248      #  The mailbox name has a character that is used on the destination
249      #  as a mailbox hierarchy delimiter.  We have to replace it.
250      $srcmbx =~ s^[$dstDelim]^$substChar^g;
251   }
252
253   if ( $debug ) {
254      Log("src mbx      $srcmbx");
255      Log("src prefix   $srcPrefix");
256      Log("src delim    $srcDelim");
257      Log("dst prefix   $dstPrefix");
258      Log("dst delim    $dstDelim");
259   }
260
261   $srcmbx =~ s/^$srcPrefix//;
262   $srcmbx =~ s/\\$srcDelim/\//g;
263
264   if ( ($srcPrefix eq $dstPrefix) and ($srcDelim eq $dstDelim) ) {
265      #  No adjustments necessary
266      # $dstmbx = $srcmbx;
267      if ( lc( $srcmbx ) eq 'inbox' ) {
268         $dstmbx = $srcmbx;
269      } else {
270         $dstmbx = $srcPrefix . $srcmbx;
271      }
272      if ( $root_mbx ) {
273         #  Put folders under a 'root' folder on the dst
274         $dstmbx =~ s/^$dstPrefix//;
275         $dstDelim =~ s/\./\\./g;
276         $dstmbx =~ s/^$dstDelim//;
277         $dstmbx = $dstPrefix . $root_mbx . $dstDelim . $dstmbx;
278         if ( uc($srcmbx) eq 'INBOX' ) {
279            #  Special case for the INBOX
280            $dstmbx =~ s/INBOX$//i;
281            $dstmbx =~ s/$dstDelim$//;
282         }
283         $dstmbx =~ s/\\//g;
284      }
285      return $dstmbx;
286   }
287
288   $srcmbx =~ s#^$srcPrefix##;
289   $dstmbx = $srcmbx;
290
291   if ( $srcDelim ne $dstDelim ) {
292       #  Need to substitute the dst's hierarchy delimiter for the src's one
293       $srcDelim = '\\' . $srcDelim if $srcDelim eq '.';
294       $dstDelim = "\\" . $dstDelim if $dstDelim eq '.';
295       $dstmbx =~ s#$srcDelim#$dstDelim#g;
296       $dstmbx =~ s/\\//g;
297   }
298   if ( $srcPrefix ne $dstPrefix ) {
299       #  Replace the source prefix with the dest prefix
300       $dstmbx =~ s#^$srcPrefix## if $srcPrefix;
301       if ( $dstPrefix ) {
302          $dstmbx = "$dstPrefix$dstmbx" unless uc($srcmbx) eq 'INBOX';
303       }
304       $dstDelim = "\\$dstDelim" if $dstDelim eq '.';
305       $dstmbx =~ s#^$dstDelim##;
306   }
307
308   if ( $root_mbx ) {
309      #  Put folders under a 'root' folder on the dst
310      $dstDelim =~ s/\./\\./g;
311      $dstmbx =~ s/^$dstPrefix//;
312      $dstmbx =~ s/^$dstDelim//;
313      $dstmbx = $dstPrefix . $root_mbx . $dstDelim . $dstmbx;
314      if ( uc($srcmbx) eq 'INBOX' ) {
315         #  Special case for the INBOX
316         $dstmbx =~ s/INBOX$//i;
317         $dstmbx =~ s/$dstDelim$//;
318      }
319      $dstmbx =~ s/\\//g;
320   }
321
322   return $dstmbx;
323}
324
325#  Reconnect to the servers after a timeout error.
326#
327sub reconnect {
328
329my $checkpoint = shift;
330my $conn = shift;
331
332   Log("Attempting to reconnect");
333
334   my ($mbx,$shost,$suser,$spwd,$dhost,$duser,$dpwd) = split(/\|/, $checkpoint);
335
336   close $src;
337   close $dst;
338
339   connectToHost($shost,\$src);
340   login($suser,$spwd,$src);
341
342   connectToHost($dhost,\$dst);
343   login($duser,$dpwd,$dst);
344
345   selectMbx( $mbx, $src );
346   createMbx( $mbx, $dst );   # Just in case
347
348}
349
350#  Handle signals
351
352sub signalHandler {
353
354my $sig = shift;
355
356   if ( $sig eq 'ALRM' ) {
357      Log("Caught a SIG$sig signal, timeout error");
358      $conn_timed_out = 1;
359   } else {
360      Log("Caught a SIG$sig signal, shutting down");
361      exit;
362   }
363   Log("Resuming");
364}
365
366sub fixup_date {
367
368my $date = shift;
369
370   #  Make sure the hrs part of the date is 2 digits.  At least
371   #  one IMAP server expects this.
372
373   $$date =~ s/^\s+//;
374   $$date =~ /(.+) (.+):(.+):(.+) (.+)/;
375   my $hrs = $2;
376
377   return if length( $hrs ) == 2;
378
379   my $newhrs = '0' . $hrs if length( $hrs ) == 1;
380   $$date =~ s/ $hrs/ $newhrs/;
381
382}
383
384sub init_mbx {
385
386my $mbx  = shift;
387my $conn = shift;
388my @msgs;
389
390   #  Remove all messages from a mailbox
391
392   Log("Initializing mailbox $mbx");
393   getMsgList( $mbx, \@msgs, $conn, 'SELECT' );
394   my $msgcount = $#msgs + 1;
395   Log("$mbx has $msgcount messages");
396
397   return if $msgcount == 0;   #  No messages to delete
398
399   foreach my $msgnum ( @msgs ) {
400      ($msgnum) = split(/\|/, $msgnum);
401      deleteMsg( $msgnum, $conn );
402   }
403   expungeMbx( $mbx, $conn );
404
405}
406
407sub commafy {
408
409my $number = shift;
410
411   $_ = $$number;
412   1 while s/^([-+]?\d+)(\d{3})/$1,$2/;
413
414   $$number = $_;
415
416}
417
418sub usage {
419
420   print STDOUT "Usage: iu-listimapfolders -S <host>/<user>/<password> [-O <output file>]\n";
421   exit;
422
423}
424