[22833] | 1 | #!/usr/bin/perl -w |
---|
[20053] | 2 | |
---|
[20593] | 3 | # $Id: mitmailshow.pl,v 1.3 2004-07-29 19:11:54 rbasch Exp $ |
---|
[20053] | 4 | |
---|
| 5 | # Show messages in an IMAP folder. |
---|
| 6 | |
---|
| 7 | use strict; |
---|
| 8 | use warnings FATAL => 'all'; |
---|
| 9 | use Cyrus::IMAP; |
---|
| 10 | use Getopt::Long; |
---|
| 11 | |
---|
| 12 | sub usage(;$); |
---|
| 13 | sub send_command($); |
---|
| 14 | sub fetch_callback(@); |
---|
| 15 | sub number_callback(@); |
---|
| 16 | sub close_and_errorout($); |
---|
| 17 | sub close_connection(); |
---|
| 18 | sub errorout($); |
---|
| 19 | |
---|
| 20 | my $prog = $0; |
---|
| 21 | |
---|
| 22 | sub usage(;$) { |
---|
| 23 | print STDERR "$prog: $_[0]\n" if ($_[0] && $_[0] ne "help"); |
---|
| 24 | print STDERR <<EOF; |
---|
| 25 | Usage: $prog [<options>] <message-ID> [...] |
---|
| 26 | Options: |
---|
| 27 | --by-uid specify message's unique ID, not sequence number |
---|
| 28 | --debug turn on debugging |
---|
| 29 | --help print this usage information |
---|
| 30 | --host=<name> query host <name> instead of default POBOX server |
---|
| 31 | --mailbox=<name> access mailbox <name> instead of INBOX |
---|
| 32 | --no-mark do not mark the message as having been seen |
---|
| 33 | --peek same as --no-mark |
---|
| 34 | EOF |
---|
| 35 | exit 1; |
---|
| 36 | } |
---|
| 37 | |
---|
| 38 | # Parse the command line arguments. |
---|
| 39 | use vars qw($opt_by_uid $opt_debug $opt_expunge $opt_host $opt_mailbox |
---|
| 40 | $opt_no_mark); |
---|
| 41 | |
---|
| 42 | GetOptions("by-uid", |
---|
| 43 | "debug", |
---|
| 44 | "help" => \&usage, |
---|
| 45 | "host=s", |
---|
| 46 | "mailbox=s", |
---|
| 47 | "no-mark|peek") || usage; |
---|
| 48 | |
---|
| 49 | usage "Please specify a message ID" if @ARGV == 0; |
---|
| 50 | |
---|
| 51 | # Check the validity of message ID arguments. |
---|
| 52 | # The ID can be a number or '*', and we accept a range specification, |
---|
| 53 | # of the form 'n:m'. |
---|
| 54 | foreach (@ARGV) { |
---|
| 55 | errorout "Invalid message specification $_" |
---|
| 56 | unless (m/^(?:\d+|\*)(?::(?:\d+|\*))?$/o); |
---|
| 57 | } |
---|
| 58 | |
---|
| 59 | $opt_mailbox = "INBOX" unless $opt_mailbox; |
---|
| 60 | |
---|
[23702] | 61 | my $username = $ENV{'ATHENA_USER'} || $ENV{'USER'} || getlogin || (getpwuid($<))[0] || |
---|
[20053] | 62 | errorout "Cannot determine user name"; |
---|
| 63 | |
---|
| 64 | unless ($opt_host) { |
---|
[24300] | 65 | $opt_host = (gethostbyname("$username.mail.mit.edu"))[0]; |
---|
| 66 | errorout "Cannot find Post Office server for $username" unless $opt_host; |
---|
[20053] | 67 | } |
---|
[23913] | 68 | errorout "Exchange accounts are not supported yet. Try http://owa.mit.edu/." if $opt_host =~ /EXCHANGE/; |
---|
[20053] | 69 | |
---|
| 70 | # Connect to the IMAP server, and authenticate. |
---|
| 71 | my $client = Cyrus::IMAP->new($opt_host) || |
---|
| 72 | errorout "Cannot connect to IMAP server on $opt_host"; |
---|
[24300] | 73 | $client->authenticate(-authz => $username, -maxssf => 0) || |
---|
[20053] | 74 | close_and_errorout "Cannot authenticate to $opt_host"; |
---|
| 75 | |
---|
| 76 | # Select (or examine, if in no-mark mode) the mailbox. |
---|
| 77 | my $select_cmd = ($opt_no_mark ? 'EXAMINE' : 'SELECT'); |
---|
[20505] | 78 | send_command "$select_cmd \"$opt_mailbox\""; |
---|
[20053] | 79 | |
---|
| 80 | # Fetch the messages. The message body will be displayed by the |
---|
| 81 | # fetch_callback subroutine. |
---|
| 82 | my $cb_numbered = Cyrus::IMAP::CALLBACK_NUMBERED; |
---|
| 83 | my $fetch_cmd = ($opt_by_uid ? 'UID FETCH' : 'FETCH'); |
---|
| 84 | my $fetch = ($opt_no_mark ? 'BODY.PEEK[]' : 'BODY[]'); |
---|
| 85 | $client->addcallback({-trigger => 'FETCH', -flags => $cb_numbered, |
---|
| 86 | -callback => \&fetch_callback}); |
---|
| 87 | my $exitcode = 0; |
---|
| 88 | foreach (@ARGV) { |
---|
| 89 | my ($status, $text) = send_command "$fetch_cmd $_ ($fetch)"; |
---|
| 90 | if ($status ne 'OK') { |
---|
| 91 | print STDERR "$prog: Cannot fetch $_: $text\n"; |
---|
| 92 | $exitcode = 1; |
---|
| 93 | } |
---|
| 94 | } |
---|
| 95 | |
---|
| 96 | # We are done talking to the IMAP server, close down the connection. |
---|
| 97 | close_connection(); |
---|
| 98 | |
---|
| 99 | exit $exitcode; |
---|
| 100 | |
---|
| 101 | # Subroutine to send a command to the IMAP server, and wait for the |
---|
| 102 | # response; any defined callbacks for the response are invoked. |
---|
| 103 | # If called in list context, the response status and text strings |
---|
| 104 | # are returned; otherwise, if the status indicates failure (i.e. is |
---|
| 105 | # not "OK"), we error out. |
---|
| 106 | sub send_command($) { |
---|
| 107 | print "Sending: $_[0]\n" if $opt_debug; |
---|
| 108 | my ($status, $text) = $client->send('', '', $_[0]); |
---|
| 109 | print "Response: status $status, text $text\n" if $opt_debug; |
---|
| 110 | errorout "Premature end-of-file on IMAP connection to $opt_host" |
---|
| 111 | if $status eq 'EOF'; |
---|
| 112 | return ($status, $text) if wantarray; |
---|
| 113 | close_and_errorout "IMAP error from $opt_host: $text" |
---|
| 114 | if $status ne 'OK'; |
---|
| 115 | } |
---|
| 116 | |
---|
| 117 | # Callback subroutine to parse the response from a FETCH command, |
---|
| 118 | # and display the message body on standard output. The body text |
---|
| 119 | # is converted to Unix-style end-of-line, but is otherwise unfiltered. |
---|
| 120 | # This callback will be invoked for each message. The "-text" hash |
---|
| 121 | # element contains the text returned by the server. |
---|
| 122 | sub fetch_callback(@) { |
---|
| 123 | my %cb = @_; |
---|
| 124 | print "In FETCH callback: msgno $cb{-msgno} text $cb{-text}\n" |
---|
| 125 | if $opt_debug; |
---|
| 126 | $_ = $cb{-text}; |
---|
| 127 | # Extract the body size, and strip off the response up to the body. |
---|
| 128 | my $size = $1 if s/.*?BODY\[\] \{(\d+)\}\r\n//ios; |
---|
| 129 | return unless $size; |
---|
| 130 | # Extract the body text. |
---|
| 131 | $_ = substr($_, 0, $size); |
---|
| 132 | # Convert to Unix-style EOL. |
---|
| 133 | s/\r\n/\n/gos; |
---|
| 134 | print $_; |
---|
| 135 | } |
---|
| 136 | |
---|
| 137 | # Callback subroutine to parse a numeric value. The "-rock" hash |
---|
| 138 | # element is a reference to the scalar in which to store the number. |
---|
| 139 | sub number_callback(@) { |
---|
| 140 | my %cb = @_; |
---|
| 141 | print "In number callback: keyword $cb{-keyword}, number $cb{-msgno}\n" |
---|
| 142 | if $opt_debug; |
---|
| 143 | ${$cb{-rock}} = $cb{-msgno}; |
---|
| 144 | } |
---|
| 145 | |
---|
| 146 | # Close the connection to the IMAP server, and error out. |
---|
| 147 | sub close_and_errorout($) { |
---|
| 148 | close_connection(); |
---|
| 149 | errorout $_[0]; |
---|
| 150 | } |
---|
| 151 | |
---|
| 152 | # Logout from the IMAP server, and close the connection. |
---|
| 153 | sub close_connection() { |
---|
| 154 | $client->send('', '', "LOGOUT"); |
---|
[20593] | 155 | # Set the client reference to undef, so that perl invokes the |
---|
| 156 | # destructor, which closes the connection. Note that if we invoke |
---|
| 157 | # the destructor explicitly here, then perl will still invoke it |
---|
| 158 | # again when the program exits, thus touching memory which has |
---|
| 159 | # already been freed. |
---|
| 160 | $client = undef; |
---|
[20053] | 161 | } |
---|
| 162 | |
---|
| 163 | sub errorout($) { |
---|
| 164 | print STDERR "$prog: $_[0]\n"; |
---|
| 165 | exit 1; |
---|
| 166 | } |
---|