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

Revision 24300, 13.9 KB checked in by geofft, 14 years ago (diff)
In mitmailutils: * Switch from Hesiod to using *.mail.mit.edu so we can use GSSAPI authentication (Trac: #403). * Because of a Cyrus SASL bug (documented in that ticket) regarding parsing long encrypted responses, set maxssf to zero to send mail in the clear. This isn't as terrible as it sounds because mail travels in the clear on the public Internet anyway, and a bunch of client programs (Pine on Athena 9, for instance) don't use encryption, and the major use of mitmailutils is `from` and `mailquota` anyway. Patch based on one from Jonathan Reed <jdreed@mit.edu>.
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 = (gethostbyname("$username.mail.mit.edu"))[0];
139    errorout "Cannot find Post Office server for $username" unless $opt_host;
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, -maxssf => 0) ||
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.