[22822] | 1 | #!/usr/bin/perl -w |
---|
[19239] | 2 | |
---|
[20593] | 3 | # $Id: from.pl,v 1.6 2004-07-29 19:11:51 rbasch Exp $ |
---|
[19239] | 4 | |
---|
| 5 | # This is an implementation of the Athena "from" utility using the |
---|
| 6 | # Perl interface to the Cyrus imclient IMAP library. |
---|
| 7 | |
---|
| 8 | use strict; |
---|
| 9 | use warnings FATAL => 'all'; |
---|
| 10 | use Cyrus::IMAP; |
---|
| 11 | use Getopt::Std; |
---|
| 12 | |
---|
| 13 | sub usage(;$); |
---|
| 14 | sub send_command($); |
---|
| 15 | sub search_callback(@); |
---|
| 16 | sub fetch_callback(@); |
---|
| 17 | sub number_callback(@); |
---|
[19800] | 18 | sub make_msgspecs(@); |
---|
[19239] | 19 | sub close_connection(); |
---|
| 20 | sub get_localmail(); |
---|
[19375] | 21 | sub get_terminal_width(); |
---|
[19239] | 22 | sub errorout($); |
---|
| 23 | |
---|
| 24 | sub usage(;$) { |
---|
| 25 | print STDERR "from: $_[0]\n" if $_[0]; |
---|
| 26 | print STDERR <<EOF; |
---|
| 27 | Usage: from [<options>] [<user>] |
---|
| 28 | Options: |
---|
| 29 | -N check only NEW messages in IMAP mailbox (default is UNSEEN) |
---|
| 30 | -A check all messages in IMAP mailbox |
---|
| 31 | -m <mailbox> check <mailbox> (default is INBOX) |
---|
| 32 | -h <host> query <host> instead of default post office server |
---|
| 33 | -s <sender> show mail from <sender> only |
---|
| 34 | -n be silent when there is no mail |
---|
| 35 | -r include Subject header |
---|
| 36 | -v include To, Date, and Subject headers |
---|
| 37 | -t display message totals only |
---|
| 38 | -p check post office server only |
---|
| 39 | -u check local mail only |
---|
[19800] | 40 | -d turn on debugging |
---|
[19239] | 41 | EOF |
---|
| 42 | exit 1; |
---|
| 43 | } |
---|
| 44 | |
---|
| 45 | # By default, we search for UNSEEN messages. If the user specifies -N, |
---|
| 46 | # we search for NEW messages (NEW is equivalent to "UNSEEN RECENT"). |
---|
| 47 | # If -A is given, we check ALL messages. |
---|
| 48 | my $search_key = "unseen"; |
---|
| 49 | |
---|
| 50 | # Parse the command line arguments. |
---|
| 51 | my %opts; |
---|
| 52 | getopts('Adh:m:Nnprs:tuv', \%opts) || usage; |
---|
| 53 | my $have_user = 0; |
---|
| 54 | my $username = shift @ARGV; |
---|
| 55 | if ($username) { |
---|
| 56 | $have_user = 1; |
---|
| 57 | } else { |
---|
[23690] | 58 | $username = $ENV{"ATHENA_USER"} || $ENV{'USER'} || getlogin || (getpwuid($<))[0] || |
---|
[19239] | 59 | errorout "Cannot determine user name"; |
---|
| 60 | } |
---|
| 61 | usage "Too many arguments" if @ARGV > 0; |
---|
| 62 | my $checkall = $opts{'A'} && ($search_key = "all"); |
---|
| 63 | my $debug = $opts{'d'}; |
---|
| 64 | my $host = $opts{'h'} || (split(" ", `hesinfo $username pobox`))[1] || |
---|
| 65 | errorout "Cannot find Post Office server for $username"; |
---|
[23822] | 66 | errorout "Exchange accounts are not supported yet. Try http://owa.mit.edu/." if $host eq "EXCHANGE.MIT.EDU"; |
---|
[19239] | 67 | my $mbox = $opts{'m'} || "INBOX"; |
---|
| 68 | my $quiet = $opts{'n'}; |
---|
| 69 | my $checknew = $opts{'N'} && ($search_key = "new"); |
---|
| 70 | my $imaponly = $opts{'p'}; |
---|
| 71 | my $report = $opts{'r'}; |
---|
| 72 | my $sender = $opts{'s'}; |
---|
| 73 | my $totals_only = $opts{'t'}; |
---|
| 74 | my $localonly = $opts{'u'}; |
---|
| 75 | my $verbose = $opts{'v'}; |
---|
| 76 | usage "Cannot specify both -A and -N" if $checkall && $checknew; |
---|
| 77 | usage "Cannot specify both -p and -u" if $imaponly && $localonly; |
---|
| 78 | usage "Cannot specify both -r and -t" if $report && $totals_only; |
---|
| 79 | usage "Cannot specify both -t and -v" if $totals_only && $verbose; |
---|
| 80 | |
---|
| 81 | # Check local mail first. |
---|
| 82 | my $localcount = 0; |
---|
| 83 | $localcount = get_localmail() unless $imaponly; |
---|
| 84 | |
---|
| 85 | exit 0 if $localonly; |
---|
| 86 | |
---|
| 87 | # Check mail on the IMAP server. |
---|
| 88 | # Connect to the server, and authenticate. |
---|
| 89 | my $client = Cyrus::IMAP->new($host) || |
---|
| 90 | errorout "Cannot connect to IMAP server on $host"; |
---|
[19800] | 91 | unless ($client->authenticate(-authz => $username)) { |
---|
| 92 | close_connection(); |
---|
[19239] | 93 | errorout "Cannot authenticate to $host"; |
---|
[19800] | 94 | } |
---|
[19239] | 95 | |
---|
| 96 | # Examine the mailbox. This gives the numbers of existing and recent |
---|
| 97 | # messages, as well as selecting the mailbox for read-only access. |
---|
| 98 | my $recentmsgcount = -1; |
---|
| 99 | my $totalmsgcount = -1; |
---|
| 100 | my @msgids = (); |
---|
| 101 | my @pomsgs = (); |
---|
| 102 | my $cb_numbered = Cyrus::IMAP::CALLBACK_NUMBERED; |
---|
| 103 | $client->addcallback({-trigger => 'EXISTS', -flags => $cb_numbered, |
---|
| 104 | -callback => \&number_callback, |
---|
| 105 | -rock => \$totalmsgcount}); |
---|
| 106 | $client->addcallback({-trigger => 'RECENT', -flags => $cb_numbered, |
---|
| 107 | -callback => \&number_callback, |
---|
| 108 | -rock => \$recentmsgcount}); |
---|
[20505] | 109 | send_command "EXAMINE \"$mbox\""; |
---|
[19239] | 110 | |
---|
| 111 | if ($totalmsgcount && !($checknew && !$recentmsgcount)) { |
---|
| 112 | # Search the mailbox to obtain the message UID's. |
---|
| 113 | $client->addcallback({-trigger => 'SEARCH', |
---|
| 114 | -callback => \&search_callback, |
---|
| 115 | -rock => \@msgids}); |
---|
| 116 | send_command "UID SEARCH $search_key" . ($sender ? " FROM $sender" : ""); |
---|
| 117 | |
---|
| 118 | # If there are messages of interest, fetch their size, and any desired |
---|
| 119 | # headers. |
---|
| 120 | if (@msgids > 0) { |
---|
| 121 | my $fetch = "RFC822.SIZE"; |
---|
| 122 | $fetch .= " BODY.PEEK[HEADER.FIELDS (FROM TO SUBJECT DATE)]" |
---|
| 123 | unless $totals_only; |
---|
| 124 | $client->addcallback({-trigger => 'FETCH', -flags => $cb_numbered, |
---|
| 125 | -callback => \&fetch_callback, |
---|
| 126 | -rock => \@pomsgs}); |
---|
[19800] | 127 | foreach (make_msgspecs(@msgids)) { |
---|
| 128 | send_command "UID FETCH $_ ($fetch)"; |
---|
| 129 | } |
---|
[19239] | 130 | } |
---|
| 131 | } |
---|
| 132 | my $msgcount = @pomsgs; |
---|
| 133 | |
---|
| 134 | # We are done talking to the IMAP server, close down the connection. |
---|
| 135 | close_connection(); |
---|
| 136 | |
---|
| 137 | my $msg; |
---|
| 138 | |
---|
| 139 | # Print out the summary line if appropriate. |
---|
| 140 | if (($verbose || $totals_only) && ($msgcount > 0 || !$quiet)) { |
---|
| 141 | my $totalsize = 0; |
---|
| 142 | for $msg (@pomsgs) { |
---|
| 143 | $totalsize += $msg->{size}; |
---|
| 144 | } |
---|
| 145 | |
---|
| 146 | print $have_user ? "$username has " : "You have "; |
---|
| 147 | if ($msgcount > 0) { |
---|
| 148 | print "$msgcount " . |
---|
| 149 | ($checkall ? "total" : $search_key) . " message" . |
---|
| 150 | ($msgcount > 1 ? 's' : '') . |
---|
| 151 | " ($totalsize bytes)" . |
---|
| 152 | ($checkall ? "" : ", $totalmsgcount total,"); |
---|
| 153 | } else { |
---|
| 154 | print "no" . |
---|
| 155 | ($checkall || $totalmsgcount == 0 ? "" : " $search_key") . |
---|
| 156 | " messages"; |
---|
| 157 | } |
---|
| 158 | print " in $mbox on $host" . |
---|
| 159 | ($verbose && $msgcount > 0 ? ':' : '.') . "\n"; |
---|
| 160 | } |
---|
| 161 | |
---|
| 162 | # Show the desired headers if appropriate. |
---|
| 163 | if (!$totals_only && $msgcount > 0) { |
---|
[19375] | 164 | my $subject_width; |
---|
| 165 | |
---|
[19239] | 166 | print ucfirst(($checkall ? "" : "$search_key ") . |
---|
| 167 | "mail in IMAP folder $mbox:\n") unless $verbose || $imaponly; |
---|
[19375] | 168 | if ($report) { |
---|
| 169 | my $tty_width = get_terminal_width(); |
---|
| 170 | $subject_width = ($tty_width > 33 ? $tty_width - 33 : 0); |
---|
| 171 | } |
---|
[19239] | 172 | for $msg (@pomsgs) { |
---|
| 173 | if ($report) { |
---|
[19375] | 174 | printf("%-30.30s ", $msg->{from}); |
---|
| 175 | print substr($msg->{subject}, 0, $subject_width) |
---|
| 176 | if $msg->{subject} && $subject_width; |
---|
| 177 | print "\n"; |
---|
[19239] | 178 | } else { |
---|
| 179 | if ($verbose) { |
---|
| 180 | print "\n"; |
---|
[19336] | 181 | print "To: $msg->{to}\n" if $msg->{to}; |
---|
| 182 | print "Subject: $msg->{subject}\n" if $msg->{subject}; |
---|
| 183 | print "Date: $msg->{date}\n" if $msg->{date}; |
---|
[19239] | 184 | } |
---|
| 185 | print "From: $msg->{from}\n"; |
---|
| 186 | } |
---|
| 187 | } |
---|
| 188 | } |
---|
| 189 | |
---|
| 190 | # Subroutine to send a command to the IMAP server, and wait for the |
---|
| 191 | # response; any defined callbacks for the response are invoked. |
---|
| 192 | # If the server response indicates failure, we error out. |
---|
| 193 | sub send_command($) { |
---|
| 194 | print "Sending: $_[0]\n" if $debug; |
---|
| 195 | my ($status, $text) = $client->send('', '', $_[0]); |
---|
| 196 | print "Response: status $status, text $text\n" if $debug; |
---|
[19800] | 197 | errorout "Premature end-of-file on IMAP connection to $host" |
---|
| 198 | if $status eq 'EOF'; |
---|
| 199 | if ($status ne 'OK') { |
---|
| 200 | close_connection(); |
---|
| 201 | errorout "IMAP error for $mbox on $host: $text" |
---|
| 202 | } |
---|
[19239] | 203 | } |
---|
| 204 | |
---|
| 205 | # Callback subroutine to parse the response from a SEARCH command. |
---|
| 206 | # The "-text" hash element contains the returned message UIDs, |
---|
| 207 | # separated by a space. The "-rock" element is a reference to the |
---|
| 208 | # array in which to store the UIDs. |
---|
| 209 | sub search_callback(@) { |
---|
| 210 | my %cb = @_; |
---|
| 211 | print "In SEARCH callback: text $cb{-text}\n" if $debug; |
---|
| 212 | @{$cb{-rock}} = split(/\s/, $cb{-text}); |
---|
| 213 | } |
---|
| 214 | |
---|
| 215 | # Callback subroutine to parse the response from a FETCH command. |
---|
| 216 | # This callback will be invoked for each message. The "-text" hash |
---|
| 217 | # element contains the text returned by the server. The "-rock" |
---|
| 218 | # element is a reference to the array in which to push a hash of the |
---|
| 219 | # various message data items. |
---|
| 220 | sub fetch_callback(@) { |
---|
| 221 | my %cb = @_; |
---|
| 222 | my ($from, $to, $subject, $date) = ''; |
---|
| 223 | my $size = 0; |
---|
| 224 | print "In FETCH callback: text $cb{-text}\n" if $debug; |
---|
| 225 | for (split /\r\n/, $cb{-text}) { |
---|
| 226 | $size = $1 if /RFC822.SIZE\s+(\d+)/io; |
---|
| 227 | $from = $_ if s/^From:\s*//io; |
---|
| 228 | $to = $_ if s/^To:\s*//io; |
---|
| 229 | $subject = $_ if s/^Subject:\s*//io; |
---|
| 230 | $date = $_ if s/^Date:\s*//io; |
---|
| 231 | |
---|
| 232 | } |
---|
| 233 | push @{$cb{-rock}}, {from => $from, to => $to, subject => $subject, |
---|
| 234 | date => $date, size => $size}; |
---|
| 235 | } |
---|
| 236 | |
---|
| 237 | # Callback subroutine to parse a numeric value. The "-rock" hash |
---|
| 238 | # element is a reference to the scalar in which to store the number. |
---|
| 239 | sub number_callback(@) { |
---|
[19800] | 240 | my %cb = @_; |
---|
| 241 | print "In number callback: keyword $cb{-keyword}, number $cb{-msgno}\n" |
---|
| 242 | if $debug; |
---|
| 243 | ${$cb{-rock}} = $cb{-msgno}; |
---|
[19239] | 244 | } |
---|
| 245 | |
---|
| 246 | # This subroutine takes a list of IMAP message UID numbers, and constructs |
---|
[19800] | 247 | # single-string representations of the set, collapsing sequences into |
---|
| 248 | # ranges where possible. In order to avoid constructing a specification |
---|
| 249 | # which is too long to be processed, the result is returned as an array |
---|
| 250 | # of manageably-sized specification strings, currently limited to about |
---|
| 251 | # 200 characters each. |
---|
| 252 | sub make_msgspecs(@) { |
---|
[19239] | 253 | return '' if @_ == 0; |
---|
[19800] | 254 | my @specs = (); |
---|
[19239] | 255 | my $first = shift(@_); |
---|
| 256 | my $last = $first; |
---|
| 257 | my $spec = $first; |
---|
| 258 | foreach (@_) { |
---|
| 259 | if ($_ != $last + 1) { |
---|
| 260 | # This UID is not in sequence with the previous element. |
---|
| 261 | # If that marks the end of a range, complete it. |
---|
| 262 | $spec .= ":$last" if ($first != $last); |
---|
[19800] | 263 | # Begin a new sequence. Create another spec string if the |
---|
| 264 | # current one is getting long. |
---|
| 265 | if (length($spec) > 200) { |
---|
| 266 | push @specs, $spec; |
---|
| 267 | $spec = $_; |
---|
| 268 | } else { |
---|
| 269 | $spec .= ",$_"; |
---|
| 270 | } |
---|
[19239] | 271 | $first = $_; |
---|
| 272 | } |
---|
| 273 | $last = $_; |
---|
| 274 | } |
---|
| 275 | # Complete the final range if necessary. |
---|
| 276 | $spec .= ":$last" if ($first != $last); |
---|
[19800] | 277 | push @specs, $spec if ($spec); |
---|
| 278 | return @specs; |
---|
[19239] | 279 | } |
---|
| 280 | |
---|
| 281 | # Logout from the IMAP server, and close the connection. |
---|
| 282 | sub close_connection() { |
---|
| 283 | $client->send('', '', "LOGOUT"); |
---|
[20593] | 284 | # Set the client reference to undef, so that perl invokes the |
---|
| 285 | # destructor, which closes the connection. Note that if we invoke |
---|
| 286 | # the destructor explicitly here, then perl will still invoke it |
---|
| 287 | # again when the program exits, thus touching memory which has |
---|
| 288 | # already been freed. |
---|
| 289 | $client = undef; |
---|
[19239] | 290 | } |
---|
| 291 | |
---|
| 292 | # Get mail from the local ("Unix") mail drop. |
---|
| 293 | # Returns the number of messages found. |
---|
| 294 | sub get_localmail() { |
---|
| 295 | my $maildrop = $ENV{'MAILDROP'} || "/var/spool/mail/$username"; |
---|
| 296 | # Open the mail drop. |
---|
| 297 | unless (open MAIL, $maildrop) { |
---|
| 298 | errorout "Cannot open maildrop $maildrop" if $localonly; |
---|
| 299 | return 0; |
---|
| 300 | } |
---|
| 301 | my $count = 0; |
---|
| 302 | my $from = ''; |
---|
| 303 | while (<MAIL>) { |
---|
| 304 | chop; |
---|
| 305 | if ($_ eq '' && $from) { |
---|
| 306 | print "$from\n" unless $totals_only; |
---|
| 307 | $count++; |
---|
| 308 | $from = ''; |
---|
| 309 | } |
---|
| 310 | elsif (/^From\s+([^\s\t]*)/o) { |
---|
| 311 | next if $sender && $1 !~ /$sender/io; |
---|
| 312 | print "Local mail:\n" |
---|
| 313 | unless ($count > 0 || $totals_only || $localonly); |
---|
| 314 | $from = $_; |
---|
| 315 | } |
---|
| 316 | } |
---|
| 317 | if ($from) { |
---|
| 318 | print "$from\n" unless $totals_only; |
---|
| 319 | $count++; |
---|
| 320 | } |
---|
| 321 | if ($totals_only && $count) { |
---|
| 322 | my $size = -s MAIL; |
---|
| 323 | print $have_user ? "$username has" : "You have"; |
---|
| 324 | print " $count local messages ($size bytes).\n"; |
---|
| 325 | } |
---|
| 326 | close(MAIL); |
---|
| 327 | return $count; |
---|
| 328 | } |
---|
| 329 | |
---|
[19375] | 330 | sub get_terminal_width() { |
---|
| 331 | my $columns = 80; |
---|
| 332 | open STTY, "stty -a |" or return $columns; |
---|
| 333 | while (<STTY>) { |
---|
| 334 | if (/columns[\s=]+(\d+);/o) { |
---|
| 335 | $columns = $1; |
---|
| 336 | last; |
---|
| 337 | } |
---|
| 338 | } |
---|
| 339 | close STTY; |
---|
| 340 | return $columns; |
---|
| 341 | } |
---|
| 342 | |
---|
[19239] | 343 | sub errorout($) { |
---|
| 344 | print STDERR "from: $_[0]\n"; |
---|
| 345 | exit 1; |
---|
| 346 | } |
---|