source: trunk/athena/bin/mitmailutils/mitmailscan.pl @ 23913

Revision 23913, 13.9 KB checked in by andersk, 15 years ago (diff)
In mitmailutils: * Replace test for EXCHANGE.MIT.EDU with test for *EXCHANGE*.
Line 
1#!/usr/bin/perl -w
2
3# $Id: mitmailscan.pl,v 1.5 2004-10-26 20:56:30 rbasch Exp $
4
5# Scan messages in an IMAP folder.
6
7use strict;
8use warnings FATAL => 'all';
9use Cyrus::IMAP;
10use Getopt::Long;
11
12sub usage(;$);
13sub send_command(@);
14sub search_callback(@);
15sub fetch_callback(@);
16sub number_callback(@);
17sub make_msgspecs(@);
18sub parse_date_opt($$);
19sub month_nametonum($);
20sub get_terminal_width();
21sub close_and_errorout($);
22sub close_connection();
23sub errorout($);
24
25my $prog = $0;
26
27sub usage(;$) {
28    print STDERR "$prog: $_[0]\n" if ($_[0] && $_[0] ne "help");
29    print STDERR <<EOF;
30Usage: $prog [<options>] [<message-id> ...]
31  Options:
32    --answered             show messages which have been marked as answered
33    --before=<dd-Mon-yyyy> show messages sent before given date
34    --by-uid               show message's unique ID instead of sequence number
35    --debug                turn on debugging
36    --deleted              show messages which have been marked as deleted
37    --from=<sender>        show messages with <sender> in From field
38    --help                 print this usage information
39    --host=<name>          query host <name> instead of default POBOX server
40    --id-only              output message IDs only
41    --key=<string>         same as --search-key=<string>
42    --larger=<n>           show messages whose size is greater than <n> bytes
43    --mailbox=<name>       examine mailbox <name> instead of INBOX
44    --new                  show new messages (same as "--recent --unseen")
45    --old                  show messages not marked as recent
46    --on=<dd-Mon-yyyy>     show messages sent on given date
47    --recent               show recent messages
48    --search-key=<string>  specify explicit IMAP search key (see RFC 2060)
49    --seen                 show messages with the SEEN flag set
50    --since=<dd-Mon-yyyy>  show messages sent since given date
51    --smaller=<n>          show messages whose size is less than <n> bytes
52    --subject=<string>     show messages with <string> in Subject field
53    --text=<string>        show messages with <string> in header or body
54    --to=<recipient>       show messages with <recipient> in To field
55    --unanswered           show messages which have not been marked as answered
56    --undeleted            show messages which have not been marked as deleted
57    --unseen               show messages which do not have the SEEN flag set
58EOF
59    exit 1;
60}
61
62# Parse the command line.
63use vars qw($opt_answered $opt_before $opt_by_uid $opt_debug
64            $opt_deleted $opt_from $opt_host $opt_id_only
65            $opt_larger $opt_mailbox $opt_new $opt_old $opt_on
66            $opt_recent $opt_search_key $opt_seen $opt_since
67            $opt_smaller $opt_subject $opt_text $opt_to
68            $opt_unanswered $opt_undeleted $opt_unseen);
69
70# Map month names to numbers.
71my %monthnum = (
72    Jan => 1, Feb => 2, Mar => 3, Apr =>  4, May =>  5, Jun =>  6,
73    Jul => 7, Aug => 8, Sep => 9, Oct => 10, Nov => 11, Dec => 12,
74);
75
76# Parse and validate the given date option string.
77# The first argument is the option name, and the second is the value.
78# We error out if the value is not of the form dd-Mon-yyyy.  Otherwise,
79# we set the value of the corresponding $opt_<name> variable.
80sub parse_date_opt($$) {
81    # Disable strict refs locally so we can use a symbolic reference
82    # to set the appropriate $opt_<name> variable below.
83    no strict 'refs';
84    my ($name, $value) = @_;
85    usage "\"$value\" is not a valid date (dd-Mon-yyyy expected)"
86        unless (($value =~ m|^\d{1,2}-([A-Za-z]{3})-\d{4}$|o) &&
87                month_nametonum($1));
88    ${"opt_" . $name} = $value;
89}
90
91GetOptions("answered",
92           "before=s" => \&parse_date_opt,
93           "by-uid",
94           "debug",
95           "deleted",
96           "from=s",
97           "help" => \&usage,
98           "host=s",
99           "id-only",
100           "larger=i",
101           "mailbox=s",
102           "new",
103           "old",
104           "on=s" => \&parse_date_opt,
105           "recent",
106           "search-key|key=s",
107           "seen",
108           "since=s" => \&parse_date_opt,
109           "smaller=i",
110           "subject=s",
111           "text=s",
112           "to=s",
113           "unanswered",
114           "undeleted",
115           "unseen") || usage;
116
117my $msgset = '';
118foreach (@ARGV) {
119    errorout "Invalid message specification $_"
120        unless (m/^(?:\d+|\*)(?::(?:\d+|\*))?$/o);
121    $msgset .= ',' if $msgset;
122    $msgset .= "$_";
123}
124
125usage "Cannot specify both --new and --old" if ($opt_new && $opt_old);
126usage "Cannot specify both --recent and --old" if ($opt_recent && $opt_old);
127usage "Cannot specify both --seen and --unseen" if ($opt_seen && $opt_unseen);
128usage "Cannot specify both --deleted and --undeleted"
129    if ($opt_deleted && $opt_undeleted);
130
131$opt_mailbox = 'INBOX' unless $opt_mailbox;
132$opt_search_key = 'ALL' unless $opt_search_key;
133
134my $username = $ENV{'ATHENA_USER'} || $ENV{'USER'} || getlogin || (getpwuid($<))[0] ||
135    errorout "Cannot determine user name";
136
137unless ($opt_host) {
138    $opt_host = (split(" ", `hesinfo $username pobox`))[1] ||
139        errorout "Cannot find Post Office server for $username";
140}
141errorout "Exchange accounts are not supported yet. Try http://owa.mit.edu/." if $opt_host =~ /EXCHANGE/;
142
143# Build the search key based on the specified command line options.
144if ($msgset) {
145    $opt_search_key .= " UID" if $opt_by_uid;
146    $opt_search_key .= " $msgset";
147}
148$opt_search_key .= " FROM $opt_from" if $opt_from;
149$opt_search_key .= " SUBJECT $opt_subject" if $opt_subject;
150$opt_search_key .= " TO $opt_to" if $opt_to;
151$opt_search_key .= " TEXT $opt_text" if $opt_text;
152$opt_search_key .= " SENTBEFORE $opt_before" if $opt_before;
153$opt_search_key .= " SENTSINCE $opt_since" if $opt_since;
154$opt_search_key .= " SENTON $opt_on" if $opt_on;
155$opt_search_key .= " LARGER $opt_larger" if defined $opt_larger;
156$opt_search_key .= " SMALLER $opt_smaller" if defined $opt_smaller;
157$opt_search_key .= " NEW" if $opt_new;
158$opt_search_key .= " OLD" if $opt_old;
159$opt_search_key .= " RECENT" if $opt_recent;
160$opt_search_key .= " SEEN" if $opt_seen;
161$opt_search_key .= " UNSEEN" if $opt_unseen;
162$opt_search_key .= " ANSWERED" if $opt_answered;
163$opt_search_key .= " UNANSWERED" if $opt_unanswered;
164$opt_search_key .= " DELETED" if $opt_deleted;
165$opt_search_key .= " UNDELETED" if $opt_undeleted;
166
167# Connect to the IMAP server, and authenticate.
168my $client = Cyrus::IMAP->new($opt_host) ||
169    errorout "Cannot connect to IMAP server on $opt_host";
170$client->authenticate(-authz => $username) ||
171    close_and_errorout "Cannot authenticate to $opt_host";
172
173# Examine the mailbox.  This gives the numbers of existing messages,
174# as well as selecting the mailbox for read-only access.
175my $totalmsgcount = -1;
176my @msgids = ();
177my @pomsgs = ();
178my $cb_numbered = Cyrus::IMAP::CALLBACK_NUMBERED;
179$client->addcallback({-trigger => 'EXISTS', -flags => $cb_numbered,
180                      -callback => \&number_callback,
181                      -rock => \$totalmsgcount});
182send_command("EXAMINE %s", $opt_mailbox);
183
184if ($totalmsgcount) {
185    # Search the mailbox to obtain the desired message numbers.
186    $client->addcallback({-trigger => 'SEARCH',
187                          -callback => \&search_callback,
188                          -rock => \@msgids});
189    send_command("UID SEARCH %a", $opt_search_key);
190
191    # If there are messages of interest, fetch them.
192    if (@msgids > 0) {
193        #@msgids = sort {$a <=> $b} @msgids;
194        my $fetch = "FLAGS BODY.PEEK[HEADER.FIELDS (FROM SUBJECT DATE)]";
195        $client->addcallback({-trigger => 'FETCH', -flags => $cb_numbered,
196                              -callback => \&fetch_callback,
197                              -rock => \@pomsgs});
198        foreach (make_msgspecs(@msgids)) {
199            send_command("UID FETCH %a (%a)", $_, $fetch);
200        }
201    }
202}
203
204# We are done talking to the IMAP server; close down the connection.
205close_connection();
206
207# Quit now if there are no messages to display.
208exit 0 unless @pomsgs;
209
210# Display the message(s), sorted by the message ID (sequence number or UID).
211my $msg;
212my $id_key = ($opt_by_uid ? 'uid' : 'number');
213@pomsgs = sort { $a->{$id_key} <=> $b->{$id_key} } @pomsgs;
214if ($opt_id_only) {
215    # We are only outputting the message ID.
216    foreach $msg (@pomsgs) {
217        print "$msg->{$id_key} ";
218    }
219    print "\n";
220} else {
221    # Here for the standard formatted output.
222    my $id_width = length $pomsgs[$#pomsgs]->{$id_key};
223    my $tty_width = get_terminal_width();
224    my $from_width = 20;
225
226    # Calculate the line width remaining for the message subject.
227    # Allow for the ID, the flag character, date (mm/dd), and "From"
228    # field widths, plus 2 spaces between the fields.
229    my $subject_width = $tty_width - 1 -
230        ($id_width + 1 + 2 + 5 + 2 + $from_width + 2);
231    $subject_width = 0 if ($subject_width < 0);
232
233    # Construct the format string.
234    my $format = "%${id_width}s%s  %02d/%02d  %-${from_width}.${from_width}s" .
235                     "  %-${subject_width}.${subject_width}s\n";
236
237    # Loop to display each message.
238    foreach $msg (@pomsgs) {
239        my ($month, $day);
240        my $flag;
241
242        # Parse a date of the form "DD Mon ...", with an optional leading
243        # "Day, ", or of the form "MM/DD/YY...".
244        if ($msg->{date} =~ m|^\s*(?:...,\s+)?(\d{1,2})\s+([A-Za-z]{3})|o) {
245            # Parsed "DD Mon ...".
246            ($month, $day) = (month_nametonum($2), $1);
247        } elsif ($msg->{date} =~ m|^\s*(\d{1,2})/(\d{1,2})/\d+|o) {
248            # Parsed "MM/DD/YY...".
249            ($month, $day) = ($1, $2);
250        } else {
251            # Unrecognized date format.
252            ($month, $day) = (0, 0);
253        }
254
255        # Strip double quotes from the "From" header.
256        my $from = $msg->{from} || '';
257        $from =~ tr/"//d;
258
259        # Flag a deleted or unseen message.
260        if ($msg->{flags} =~ /\\Deleted\b/io) {
261            $flag = 'D';
262        } elsif ($msg->{flags} !~ /\\Seen\b/io) {
263            $flag = 'U';
264        } else {
265            $flag = ' ';
266        }
267
268        # Display the line.
269        printf($format, $msg->{$id_key}, $flag, int($month), int($day),
270               $from, $msg->{subject} ? $msg->{subject} : '');
271    }
272}
273
274# Subroutine to send a command to the IMAP server, and wait for the
275# response; any defined callbacks for the response are invoked.
276# If the server response indicates failure, we error out.
277sub send_command(@) {
278    my ($fmt, @args) = @_;
279    if ($opt_debug) {
280        local $" = ', ';
281        print "Send($fmt, @args) ...\n";
282    }
283    my ($status, $text) = $client->send('', '', $fmt, @args);
284    print "Response: status $status, text $text\n" if $opt_debug;
285    errorout "Premature end-of-file on IMAP connection to $opt_host"
286        if $status eq 'EOF';
287    close_and_errorout "IMAP error from $opt_host: $text"
288        if $status ne 'OK';
289}
290
291# Callback subroutine to parse the response from a SEARCH command.
292# The "-text" hash element contains the returned message numbers,
293# separated by a space.  The "-rock" element is a reference to the
294# array in which to store the message numbers.
295sub search_callback(@) {
296    my %cb = @_;
297    print "In SEARCH callback: text $cb{-text}\n" if $opt_debug;
298    @{$cb{-rock}} = split(/\s/, $cb{-text});
299}
300
301# Callback subroutine to parse the response from a FETCH command.
302# This callback will be invoked for each message.  The "-text" hash
303# element contains the text returned by the server.  The "-rock"
304# element is a reference to the array in which to push a hash of the
305# various message data items.
306sub fetch_callback(@) {
307    my %cb = @_;
308    my ($number, $uid, $flags, $from, $to, $subject, $date);
309    print "In FETCH callback: msgno $cb{-msgno} text $cb{-text}\n"
310        if $opt_debug;
311    $number = $cb{-msgno};
312    my @response_lines = split /\r\n/, $cb{-text};
313    $_ = shift @response_lines;
314    $uid = $1 if /\bUID\s+(\d+)/io;
315    $flags = $1 if /\bFLAGS\s+\(([^\)]*)\)/io;
316    foreach (@response_lines) {
317        $from = $_ if s/^From:\s*//io;
318        $to = $_ if s/^To:\s*//io;
319        $subject = $_ if s/^Subject:\s*//io;
320        $date = $_ if s/^Date:\s*//io;
321    }
322    push @{$cb{-rock}}, {number => $number, uid => $uid, flags => $flags,
323                         from => $from, to => $to, subject => $subject,
324                         date => $date}
325        if $number;
326}
327
328# Callback subroutine to parse a numeric value.  The "-rock" hash
329# element is a reference to the scalar in which to store the number.
330sub number_callback(@) {
331    my %cb = @_;
332    print "In number callback: keyword $cb{-keyword}, number $cb{-msgno}\n"
333        if $opt_debug;
334    ${$cb{-rock}} = $cb{-msgno};
335}
336
337# This subroutine takes a list of IMAP message sequence or UID
338# numbers, and constructs single-string representations of the set,
339# collapsing sequences into ranges where possible.  In order to avoid
340# constructing a specification which is too long to be processed, the
341# result is returned as an array of manageably-sized specification
342# strings, currently limited to about 200 characters each.
343sub make_msgspecs(@) {
344    return '' if @_ == 0;
345    my @specs = ();
346    my $first = shift(@_);
347    my $last = $first;
348    my $spec = $first;
349    foreach (@_) {
350        if ($_ != $last + 1) {
351            # This number is not in sequence with the previous element.
352            # If that marks the end of a range, complete it.
353            $spec .= ":$last" if ($first != $last);
354            # Begin a new sequence.  Create another spec string if the
355            # current one is getting long.
356            if (length($spec) > 200) {
357                push @specs, $spec;
358                $spec = $_;
359            } else {
360                $spec .= ",$_";
361            }
362            $first = $_;
363        }
364        $last = $_;
365    }
366    # Complete the final range if necessary.
367    $spec .= ":$last" if ($first != $last);
368    push @specs, $spec if ($spec);
369    return @specs;
370}   
371
372# Convert month names to numbers.
373sub month_nametonum($) {
374    my $num = $monthnum{ucfirst(lc($_[0]))};
375    return ($num ? $num : 0);
376}
377
378# Return the terminal line width.  Unfortunately, the only feasible
379# way to get the width is to parse stty output.
380sub get_terminal_width() {
381    my $columns = 80;
382    open STTY, "stty -a |" or return $columns;
383    while (<STTY>) {
384        if (/columns[\s=]+(\d+);/o) {
385            $columns = $1;
386            last;
387        }
388    }
389    close STTY;
390    return $columns;
391}
392
393# Close the connection to the IMAP server, and error out.
394sub close_and_errorout($) {
395    close_connection();
396    errorout $_[0];
397}
398
399# Logout from the IMAP server, and close the connection.
400sub close_connection() {
401    $client->send('', '', "LOGOUT");
402    # Set the client reference to undef, so that perl invokes the
403    # destructor, which closes the connection.  Note that if we invoke
404    # the destructor explicitly here, then perl will still invoke it
405    # again when the program exits, thus touching memory which has
406    # already been freed.
407    $client = undef;
408}
409
410sub errorout($) {
411    print STDERR "$prog: $_[0]\n";
412    exit 1;
413}
Note: See TracBrowser for help on using the repository browser.