#! /bin/sh exec ${PERL-perl} -Sx $0 ${1+"$@"} #!perl [perl will skip all lines in this file before this line] # from --- show you who your mail is from # Copyright (C) 1992, 95, 96, 97, 98, 99, 00, 02, 2003 Noah S. Friedman # Author: Noah Friedman # Created: 1992-01-19 # $Id: from,v 1.54 2006/02/03 18:05:14 friedman Exp $ # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, you can either send email to this # program's maintainer or write to: The Free Software Foundation, # Inc.; 51 Franklin Street, Fifth Floor; Boston, MA 02110-1301, USA. # Commentary: # Thanks to Jonathan Kamens for # the `{FROMTO}' virtual header field. # Code: use 5.003; use strict; no strict qw(vars); use Getopt::Long; use POSIX qw(strftime); use Symbol; sub usage { print "Usage: $progname {options} {folder {...}}\n Options are: -1, --first-header-line Do not display header continuation lines; show only the first line of each displayed header. -a, --all-headers Show all headers. Ignore \`--format'. -C, --count-only Only count the number of messages that would be displayed, without displaying any other information about them. E.g. \`-Cu' would print the number of unread messages you have. -c, --columns COLS Truncate lines exceeding COLS length on output. If COLS=0 or output is not to a terminal, no truncation is done. The default is the current width of the terminal. -D, --debug Enable interactive debugging. -E, --extract {LINES} Print the body of each matched message. If the optional argument LINES is supplied, print only the first LINES number of lines. -e, --envelope Show message envelope instead of headers. This causes any formatting options (e.g. \`--columns', \`--numbered') to be ignored. This option only makes sense for local folders. -f, --format FMT Use FMT as the output format. The option \`--help-format' gives instructions for this. -h, --help You're looking at it. -H, --help-format Get documentation about the format of the FMT argument to \`--format'. -i, --me-match REGEXP Pattern to match against the From field to determine whether you are the sender (affects the {FROMTO} format specifier). Defaults to everything up until the first comma in your GECOS information. -M, --match-header HEADERS Seach only headers named HEADER for patterns specified with \`--match'. By default, the header searched is \`From'. -m, --match REGEXP Only print messages in which REGEXP could be found in the \`From' header, or those specified with \`--match-headers'. -n, --numbered Show number of message with respect to the current folder. See also \`--help-format'. -s, --sender ADDR Show only messages sent from ADDR. This is equivalent to specifying the options \`--match-headers=From --match=ADDR'. -P, --no-parse Do not do fancy parsing of From and Date fields. -U, --user USER Show headers of USER's spooled messages. -u, --unread-only Only show information about unread messages (i.e. those that do not have a \`R' in the Status header field).\n To specify a POP3 folder: Syntax: pop:HOST:PORT:AUTH:USER:PASS Fields may be blank, in which case: * HOST defaults to \`localhost' * PORT defaults to 110 * AUTH defaults to \`pass' (this is the only currently supported authentication protocol anyway). * USER defaults to your current username * PASS is obtained from the POPPASS environment variable. (This default will also be used if this field is set to \`*'.) To specify an IMAP folder: Syntax: imap:HOST:PORT:MAILBOX:AUTH:USER:PASS Fields may be blank, in which case: * HOST defaults to \`localhost' * PORT defaults to 143 * MAILBOX defaults to \`inbox'. * AUTH defaults to \`login' (this is the only currently supported authentication protocol anyway). * USER defaults to your current username * PASS is obtained from the POPPASS environment variable. (This default will also be used if this field is set to \`*'.)\n\n"; exit (1); } sub usage_fmt { print "$progname format usage: --format='%{{-}{n}{.m}}[header] ...' ...\n The FMT specifier to the \`--format' option can contain literal text for the output, along with header specifiers in the form\n %{{-}{n}{.m}}Header\n where\n * \`n' is the line width reserved for the value of \`Header'. * \`-' means that header strings shorter than \`n' chars are flushed left within the field, instead of right. * \`.m' is the maximum allowed length of the field; if the header string is longer than this, it is truncated. * \`Header' is the name of the header, e.g. \`Subject'. Some special \"header names\" are defined for useful information that cannot generally be obtained from message headers. As usual, you can use general format specifiers, e.g \"%-4.3{TLINES}\". These special names, surrounded by curly braces, are: * \`{TLINES}' The number of this message line irrespective of any folder it may have come from (if more than one folder was specified on the command line). * \`{FLINES}' The number of this message in the current folder. This number is reset whenever this program begins reading a new folder specified on the command line. * \`{FOLDER}' The name of this folder, as specified on the command line. * \`{FROMTO}' The sender of the message if it isn't you, or \"To \" otherwise. For example, given a message with headers of the form From: Noah Friedman To: nobody\@prep.ai.mit.edu Subject: example Date: Tue, 18 Oct 94 12:22:50 CDT here are some valid format specifiers and the output that results from them. (\`-|' indicates the results here; it is not actually printed.) \"%From %Subject\" -| Noah Friedman example \"%-19.18From %-13.12Date %-.45Subject\" -| Noah Friedman Oct 18 12:22 example \"To %-19To %-13Date %20Subject\" -| To nobody\@prep.ai.mit.edu Oct 18 12:22 example \"To %-19.18To %-13.12Date %-.45Subject\" -| To nobody\@prep.ai.mit. Oct 18 12:22 example \" From: %From\\nSubject: %Subject\\n Date: %Date\\n\" -| From: Noah Friedman -| Subject: example -| Date: Oct 18 12:22 -| If you use something like last example format specifier, you may wish to use the \`--no-parse' option to avoid any parsing (and therefore truncation) of the From and Date lines.\n"; exit (1); } sub parse_options () { ($progname = $0) =~ s|.*/||; # if stdout is not a tty, then disable truncation (user may explicitly # enables it later by use of the --columns option). # Decrement number of columns by 1 since output in last column causes # wraparound on many (most?) terminals. $opt_columns = (-t STDOUT ? ((defined $ENV{COLUMNS}) ? $ENV{COLUMNS} - 1 : 79) : 0); $opt_user = default_user (); $opt_pass = $ENV{POPPASS} || 'none'; # Precedence for defs (highest->lowest): options, ~/.fromrc.pl, default $fromrc = $ENV{FROMRCPL} || "$ENV{HOME}/.fromrc.pl"; eval { require "$fromrc" } if (-f $fromrc); exit 1+err ($fromrc, $@) if ($@ ne "" && $@ !~ /not return a true value/o); Getopt::Long::config ('bundling', 'autoabbrev'); GetOptions ("1|first-header-line-only", \$opt_firstlinep, "a|all-headers", sub { $opt_all_headers = 1; $opt_firstlinep = 0; }, "C|count-only", \$opt_countp, "c|columns=i", \$opt_columns, "E|extract:s", sub { $opt_extractp = 1; $opt_linelimit = $_[1]; }, "e|envelope", \$opt_envelopep, "f|format=s", \$opt_format, "h|help", \&usage, "H|help-format", \&usage_fmt, "i|me-match", \$opt_me_match, "M|match-header=s", \$opt_match_header, "m|match=s", \$opt_match_regexp, "n|numbered", \$opt_numbered, "P|no-parse", \$opt_no_parsep, "s|sender=s", sub { $opt_match_header = 'From'; $opt_match_regexp = $_[1]; }, "U|user=s", \$opt_user, "u|unread-only", \$opt_unread_only, # For debugging "w|warnings", \$^W); set_default_format () unless (defined $opt_format); set_me_match () unless (defined $opt_me_match); # User might have set opt_pass in fromrc using a backquoted substitution chop $opt_pass if (substr ($opt_pass, -1, 1) eq "\n"); } sub main () { parse_options (); # Quit early if we have no files to read if ($#ARGV < 0) { my $default_spool = default_spool_file ($opt_user); push (@ARGV, $default_spool) if (defined $default_spool); exit (0) unless (defined $default_spool); } initialize_variables (); make_format_vector ($opt_format); $header_save_p{STATUS} = 1 if ($opt_unread_only); if (defined $opt_match_header && $opt_match_header ne '') { # Must store actual header name as well as MATCH header name, so that # contents will be stored. $header_save_p{uc ($opt_match_header)} = 1; $opt_match_header = join ('', "{MATCH_", uc ($opt_match_header), "}"); $header_save_p{$opt_match_header} = 1; } for my $file (@ARGV) { if ($file !~ /^(?:pop|imap).*?:/oi && $file ne "-" && ! -r $file) { my $fh = gensym; # Set $! appropriately. open ($fh, $file); err ($file, "$!."); close ($fh); $exit_status = 1; next; } # pop:HOST:PORT:AUTH:USER:PASSWORD # Only auth method currently supported is `pass' if ($file =~ /^pop-?3?:(.*?):(.*?):(.*?):(.*?):(.*)/oi) { my ($host, $port, $auth, $user, $pass) = ($1, $2, lc ($3), $4, $5); $auth = "pass" if ($auth eq ''); unless ($auth eq 'pass') { err ($3, "Unsupported POP authentication protocol"); exit (1); } $host = "localhost" if ($host eq ''); $port = 110 if ($port eq ''); $user = $opt_user if ($user eq ''); $pass = $opt_pass if ($pass eq '' || $pass eq '*'); process_remote_folder ('POP3', $host, $port, $auth, $user, $pass); } # imap:HOST:PORT:MAILBOX:AUTH:USER:PASSWORD # Only auth method currently supported is `login' elsif ($file =~ /^imap:(.*?):(.*?):(.*?):(.*?):(.*?):(.*)/oi) { my ($host, $port, $mbox, $auth, $user, $pass) = ($1, $2, $3, lc ($4), $5, $6); $auth = "login" if ($auth eq ''); unless ($auth eq 'login') { err ($3, "Unsupported IMAP authentication protocol"); exit (1); } $host = "localhost" if ($host eq ''); $port = 143 if ($port eq ''); $mbox = "inbox" if ($mbox eq ''); $user = $opt_user if ($user eq ''); $pass = $opt_pass if ($pass eq '' || $pass eq '*'); process_remote_folder ('IMAP', $host, $port, $auth, $user, $pass, $mbox); } elsif ($opt_countp) { my $n = folder_message_count ($file); next unless (defined $n); if (scalar @ARGV > 1) { print $n, "\t", $file, "\n"; } else { print $n, "\n"; } } elsif ($opt_envelopep) { print_envelopes ($file); } else { process_file ($file); } } exit ($exit_status); } sub initialize_variables () { $ctime_now = strftime ("%a %b %d %H:%M:%S %Y", (($ENV{TZ} || '') eq 'UTC' ? gmtime (time) : localtime (time))); # This is perhaps a little too specific, but some MTAs do not # quote 'From ' at the beginning of a line in the body, especially # when writing to archive files. # The amount of whitespace between the address and the date seems to vary # on some systems. # # It is rare, but I have seen whitespace (quoted) in the address part of # the envelope, e.g. # From "Speakeasy ?@A-Z\\^_`a-z{|}~]+'; # However, these are the characters allowed in the $opt_format specifiers; # some restrictions exist for the sake of formatting. $re_fmt_header_name = '[!"#$&\'*+,-./0-9;<=>?@A-Z\\^_`a-z{|}~]+'; $re_blank_line = '^$'; $re_format_modifier = '%[\d.-]*'; $hack_header_function{FROM} = \&hack_From_data; $hack_header_function{TO} = \&parse_rfc1522; $hack_header_function{CC} = \&parse_rfc1522; $hack_header_function{DATE} = \&hack_Date_data; $hack_header_function{SUBJECT} = \&parse_rfc1522; $format_token{'{TLINES}'} = 'd'; $format_token{'{FLINES}'} = 'd'; $format_token{'{OCTETS}'} = 'd'; $total_message_lines = 0; $exit_status = 0; $body_line_limit = ($opt_linelimit ? $opt_linelimit + 0 : ($opt_extractp ? -1 : 0)); } sub default_user () { my @envvars = qw(FROM_USER USER LOGNAME); for my $var (@envvars) { my $val = $ENV{$var}; return $val if defined $val && $val ne ''; } return scalar getpwuid ($<); } sub default_spool_file ($;$) { return $opt_mail if (defined $opt_mail); my $mailfile = $ENV{MAIL}; return $mailfile if (defined $mailfile); my $user = shift; my $spooldirs = (shift || [qw(/var/mail /var/spool/mail /usr/spool/mail /usr/mail /com/mail)]); for my $spool (@$spooldirs) { my $file = join ("/", $spool, $user); return $file if (-f $file); } return undef; } sub set_me_match () { if (! $opt_me_match) { my $username = default_user (); my @passwd = $username ? getpwnam ($username) : getpwuid ($>); return unless @passwd; ($opt_me_match = $passwd[6]) =~ s/,.*//o; $opt_me_match =~ s/^\s*(.*?)\s*$/$1/o; $opt_me_match =~ s/(\W)/\\$1/go; } } sub set_default_format () { if ($opt_extractp) { $opt_no_parsep = 1; $opt_format = join ("", map { sprintf ("%s: %%%s\n", $_, $_) } qw(From To Cc Subject Date)); } else { $opt_format = ($opt_numbered? "%-3{FLINES} " : "") . "%-19.18{FROMTO} %-13.12Date %Subject\n"; } } sub openfile ($) { my $file = shift; my $fh = gensym; if ($file eq "-") { unless (open ($fh, "<&STDIN")) { err ("stdin", $!); exit (1); } } elsif (!sysopen ($fh, $file, 0)) { err ($file, $!); exit (1); } return $fh; } sub print_envelopes (@) { for my $file (@_) { my $fh = openfile ($file); while (<$fh>) { print if /$re_message_delimiter/o; } close ($fh); } } sub folder_message_count (@) { my $n = 0; for my $file (@_) { my $fh = openfile ($file); while (<$fh>) { $n++ if /$re_message_delimiter/o; } close ($fh); } return $n; } sub make_format_vector ($) { my $fstring = shift; my $tmp = ''; my $re_token = $re_format_modifier . "[^%]*"; undef %header_save_p; undef @vector_header_name; undef @format_vector; $tmp .= $1 while ($fstring =~ /^([^%]+|%%)/go); $fstring = substr ($fstring, length ($tmp)); $vector_header_name[0] = 'prefix'; $format_vector[0] = $tmp; while ($fstring =~ /^($re_token)/o) { my $modifier = ""; my $trailing_whitespace = ""; $tmp = $1; $fstring = substr ($fstring, length ($1)); if ($tmp =~ /($re_format_modifier)/o) { $modifier = $1; $tmp = substr ($tmp, length ($1)); if ($tmp =~ /($re_fmt_header_name)/o) { $trailing_whitespace = substr ($tmp, length ($1)); $tmp = $1; } } while ($fstring =~ /^([^%]+|%%)/o) { $trailing_whitespace .= $1; $fstring = substr ($fstring, length ($1)); } # Make header name all upper case to distinguish from extraneous data # like the `prefix' element. $tmp = uc ($tmp); my $tok = $format_token{$tmp} || 's'; $header_save_p{$tmp} = 1; if ($tmp eq '{FROMTO}') { $header_save_p{'FROM'} = 1; $header_save_p{'TO'} = 1; } push @vector_header_name, $tmp; my $fmt = join ('', $modifier, $tok, $trailing_whitespace); $fmt = eval "\"$fmt\"" if ($fmt =~ /\\/o); push @format_vector, $fmt; } } sub process_file ($) { my $file = shift; my @headers; my $header_contents = ""; my $in_message_body_p = 1; my $folder_message_lines = 0; my $fh = openfile ($file); while (<$fh>) { chomp; # If we hit an RFC822 message delimiter, clean up in preparation for # getting info about the next message. if ($in_message_body_p && /$re_message_delimiter/o) { undef @headers; $header_contents = ""; undef %current_headers; $in_message_body_p = 0; next; } # If we're finished reading header continuation lines (evidenced by # coming upon a new header name), finish processing this header. if ($header_contents ne "" && /^$re_header_name/o) { push (@headers, $header_contents) if ($opt_all_headers); add_header ($header_contents); $header_contents = $_; next; } # If we're not in the message body, and we come upon a blank line, # we're at the end of the headers for this message. if (! $in_message_body_p && /$re_blank_line/o) { # Add last buffered header. push (@headers, $header_contents) if ($opt_all_headers); add_header ($header_contents); $header_contents = ""; $total_message_lines++; $folder_message_lines++; $current_headers{'{TLINES}'} = $total_message_lines; $current_headers{'{FLINES}'} = $folder_message_lines; $current_headers{'{FOLDER}'} = $file; $in_message_body_p = 1; $body_line_count = 0; maybe_print_headers (scalar @headers, \@headers, $opt_all_headers); } if ($in_message_body_p && $opt_extractp && ! $ignore_this_message_p && (($body_line_limit < 0) || ($body_line_count <= $body_line_limit))) { chomp; print "\n" if ($body_line_count == 0); print $_, "\n"; $body_line_count++; next; } next if ($in_message_body_p || ($opt_firstlinep && $header_contents ne "")); # Otherwise, append current header info. $header_contents .= "\n" if ($header_contents ne ""); $header_contents .= $_; } close ($fh); } sub process_remote_folder ($$$$$$;$) { my ($proto, $host, $port, $auth, $user, $pass, $mbox) = @_; my $total_message_count; my $msgnumber; my $folder = $proto->new ($host, $port); return 0 unless $folder && $folder->$auth ($user, $pass); $total_message_count = $folder->message_count ($mbox); if ($opt_countp && ! $opt_unread_only) { $folder->close; print $total_message_count, "\n"; return 1; } $current_headers{'{FOLDER}'} = join (":", $host, $port, $user); $msgnumber = 1; while ($msgnumber <= $total_message_count) { if ($opt_extractp && defined $opt_match_header && $opt_match_header ne '' && $body_line_limit != 0) { # If we're searching for a particular message for extraction, get # just the headers first to see if this is a matching message. # Then and only then should we try retrieving the body below. process_remote_folder_get ($folder, $msgnumber, 0); if (! message_header_pattern_matched_p ()) { $msgnumber++; $total_message_lines++; next; } } my ($lineno, $lines) = process_remote_folder_get ($folder, $msgnumber, $body_line_limit); $total_message_lines++; $current_headers{'{FLINES}'} = $msgnumber; $current_headers{'{TLINES}'} = $total_message_lines; $current_headers{'{OCTETS}'} = $folder->message_size ($msgnumber) if $header_save_p{'{OCTETS}'}; maybe_print_headers ($lineno, $lines, $opt_all_headers); if (! $ignore_this_message_p && $opt_extractp) { print $lines->[$lineno++], "\n" while (defined $lines->[$lineno]); print "\n" if ($body_line_limit != 0); } $msgnumber++; } $folder->close; } sub process_remote_folder_get ($$$) { my ($folder, $msgnumber, $body_line_limit) = @_; my $data = $folder->retrieve_lines ($msgnumber, $body_line_limit); my $header_line_count = $data->[0]; my $lines = $data->[1]; my $header_contents = ''; my $lineno = 0; undef %current_headers; while ($lineno < $header_line_count) { if ($header_contents ne '' && $lines->[$lineno] =~ /^$re_header_name/o) { add_header ($header_contents); $header_contents = $lines->[$lineno]; } else { $header_contents .= "\n" . $lines->[$lineno] unless ($opt_firstlinep && $header_contents ne ''); } $lineno++; } # Add last buffered header. add_header ($header_contents); return ($lineno, $lines); } # This uses way, way too many free variables sub maybe_print_headers ($$$) { # $lines should be a reference to an array of lines. my ($lines_header_end, $lines, $opt_all_headers) = @_; $ignore_this_message_p = 1; if (! ($opt_unread_only && index ($current_headers{STATUS}, "R")) && message_header_pattern_matched_p ()) { $ignore_this_message_p = 0; if (! $opt_countp) { printf "From ----------Message-%.3d---------- %s\n", $total_message_lines, $ctime_now if ($opt_extractp); if (defined $lines_header_end && $opt_all_headers) { my $l = 0; print $lines->[$l++], "\n" while ($l < $lines_header_end); return; } print_headers (); } } } sub add_header ($) { my $line = shift; return unless ($line =~ /^([^ :]*: )/o); my $header = uc ($1); # Get rid of trailing `: '; substr ($header, -2) = ''; if (defined $header_save_p{$header}) { my $data = substr ($line, length ($1)); # Store the unparsed header data in the match_header, if defined. $current_headers{$opt_match_header} = $data if (defined $opt_match_header && "{MATCH_$header}" eq $opt_match_header); $data = &{$hack_header_function{$header}} ($data) if (!$opt_no_parsep && exists $hack_header_function{$header}); $current_headers{$header} = $data; } } # Try to extract real name from From: line when possible. sub hack_From_data ($) { my $d = shift; # "\<" used below to avoid confusing cperl-mode font-lock; # this is not a perl metacharacter. $d = $1 if ($d =~ m/\(([^)]+)\)/o # From: foobar@host (real name) || $d =~ m/"([^"]+)"/o # From: "real name" || $d =~ m/"".*?\<([^\>]+)\>/o # From: "" || $d =~ m/^(.+?)\ || $d =~ m/^\<(.*?)\>/o); # From: # Strip any leading and trailing whitespace $d =~ s/^\s+//o; $d =~ s/\s+$//o; parse_rfc1522 ($d); } my @month_conv = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'); # Prettify date sub hack_Date_data ($) { my $fmt = "%s %-2.2d %-2.2d:%-2.2d"; # Handle dates of the form: # Mon, 14 Feb 1972 17:29:00 -0500 # 14 Feb 1972 17:29:00 -0500 (EST) return sprintf $fmt, $2, $1, $3, $4 if ($_[0] =~ /^\s*(?:\D+,?\s+|)(\d+)\s+(\D+)\s+\d+\s+(\d+):(\d+)/o); # ISO-8601 date format: YYYY-MM-DD HH:MM:SS-hh:mm # (where hh:mm is the timezone offset from UTC) # This parsing doesn't attempt to convert the originating time zone to # the local time. return sprintf $fmt, $month_conv[$1 -1], $2, $3, $4 if ($_[0] =~ /^\s*\d+-(\d+)-(\d+)\s+(\d+):(\d+):\d+/o); # Handle dates of the form: # Sat Jan 1 21:24:52 IST 2000 return sprintf $fmt, $1, $2, $3, $4 if ($_[0] =~ /\D+\s+(\D{3})\s+(\d+)\s+(\d+):(\d+):\d/o); return $_[0]; } sub print_headers { my $data = (shift || \%current_headers); my $str = ""; my $i = 0; if (! $data->{'{FROMTO}'}) { if ($opt_me_match && $data->{'FROM'} =~ /$opt_me_match/o) { my $to = $data->{'TO'}; $to = $1 if $to =~ /^([^,]+),/o; $to =~ s/^\s*(.*?)\s*$/$1/o; $data->{'{FROMTO}'} = 'To ' . hack_From_data ($to); } else { $data->{'{FROMTO}'} = $data->{'FROM'}; } } while (1) { if (!defined $format_vector[$i]) { # Truncate output string if appropriate. $str = join ("\n", map { (length ($_) > $opt_columns) ? substr ($_, 0, $opt_columns) : $_; } split (/\n/, $str, -1)) if ($opt_columns > 0 && length ($str) > $opt_columns); print $str; return; } my $header = $vector_header_name[$i]; my $format = $format_vector[$i]; $str .= sprintf ($format, $data->{$header} || ""); $i++; } } sub message_header_pattern_matched_p { return 1 if (!defined $opt_match_header || $opt_match_header eq ''); return 1 if (defined ($current_headers{$opt_match_header}) && ($current_headers{$opt_match_header} =~ /$opt_match_regexp/oi)); return 0; } sub err { my $msg = join (": ", $progname, @_); print STDERR $msg, (substr ($msg, -1, 1) eq "\n"? "" : "\n"); return undef; } my @base64_decode_vector; sub base64_decode ($) { return $_[0] unless (length ($_[0]) % 4 == 0); if (!defined @base64_decode_vector) { my $i = 0; my $s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" . "abcdefghijklmnopqrstuvwxyz" . "0123456789" . "+/"; map { $base64_decode_vector[ord $_] = $i++ } split (//, $s); } my @input = split (//, $_[0]); my $result = ""; my $c = 0; my $n = 0; while (scalar @input > 0) { if ($input[0] eq '=') { $result .= chr ($n >> 10), last if ($c == 2); # $c == 3 if we get to this point. $result .= chr ($n >> 16); $result .= chr (($n >> 8) & 0xff); last; } $n += $base64_decode_vector[ord shift @input]; if (++$c == 4) { $result .= chr ($n >> 16); $result .= chr (($n >> 8) & 0xff); $result .= chr ($n & 0xff); $n = $c = 0; next; } $n <<= 6; } return $result; } sub qp_decode ($) { my $data = shift; $data =~ y/_/ /; my $p = $[; while (1) { $p = index ($data, "=", $p); last if ($p < $[); # Convert "=XX" (where XX is the hexidecimal representation # of an ascii character) to ascii. substr ($data, $p, 3) = chr hex substr ($data, $p+1, 2); $p++; } return $data; } # For a description of the windows codepages see emacs 22's # lisp/international/codepage.el # cp1252 is identical to iso-8859-1. my $rfc1522_charset = join ("|", qw(iso-8859-1 windows-1252)); sub parse_rfc1522 ($) { my $input = shift; my $result = ""; # Perl regexp notes: # *? provides non-greedy matching # (?:re) provides grouping without creating a saved register while ($input =~ m/(.*?)=\?(?:$rfc1522_charset)\?([^?]).*?\?([^?]*)\?=/gcio) { $result .= $1; my $encoding = lc ($2); $result .= qp_decode ($3) if ($encoding eq 'q'); $result .= base64_decode ($3) if ($encoding eq 'b'); } return $input if ($result eq ""); return $result . substr ($input, pos $input); } package Netstream; use Socket; use Symbol; use strict; # fh may be a filehandle or a reference to an array of handles # mode 1 = buffering, 0 = no buffering sub set_buffering_mode { my ($fh, $mode) = @_; my $orig = select (ref $fh eq 'ARRAY' ? $fh->[0] : $fh); for my $handle (ref $fh eq 'ARRAY' ? @$fh : $fh) { select ($handle); $| = ($mode == 0); } select ($orig); } sub open_network_stream ($$) { my ($rhostname, $port) = @_; my $proto = getprotobyname ("tcp"); (undef, undef, $port) = getservbyname ($port, "tcp") if ($port !~ /^\d+$/o); my @rhostaddr; if ($rhostname =~ /^[0-9.]+$/o) { push @rhostaddr, inet_aton ($rhostname); } else { @rhostaddr = gethostbyname ($rhostname); return err ($rhostname, "cannot resolve host name.") unless (defined $rhostaddr[0] && $rhostaddr[0] ne ""); splice (@rhostaddr, 0, 4); } my $sock = gensym; socket ($sock, AF_INET, SOCK_STREAM, $proto) || return err ("socket", $!); while ($#rhostaddr >= 0) { next unless connect ($sock, sockaddr_in ($port, shift @rhostaddr)); set_buffering_mode ($sock, 0); return $sock; } return err ("socket", $!); } package POP3; use strict; sub new { my ($type, $host, $port) = @_; my $class = ref ($type) || $type; my $self = bless {}, $class; my $sock = Netstream::open_network_stream ($host, $port) || return undef; $self->{sock} = $sock; return $self; } # implements `pass' authentication method sub pass { my ($self, $login, $pass) = @_; return 1 if ($self->response_ok_p # greeting && $self->send_command_ok_p ("USER " . $login) && $self->send_command_ok_p ("PASS " . $pass)); $self->close; return 0; } sub message_count { my $self = shift; $self->send_command ("STAT"); my $results = $self->parse_response; return $results->[1]; } sub message_size { my ($self, $msgnumber) = @_; $self->send_command ("LIST $msgnumber"); my $results = $self->parse_response; return $results->[2] if ($results->[0] eq "+OK"); return undef; } sub retrieve_lines { my ($self, $msgnumber, $bodylines) = @_; $bodylines += 0; # force into numeric context $self->send_command ($bodylines < 0 ? "RETR $msgnumber" : "TOP $msgnumber $bodylines"); return undef unless ($self->response_ok_p); my $i = 0; my $headers_end = 0; my @lines; my $sock = $self->{sock}; while (<$sock>) { s/[\r\n]+$//o; # The end of the transmission always ends with a single period on a # line by itself. last if ($_ eq '.'); # Otherwise, any period at the beginning of a line is quoted with an # additional period. Periods after the first aren't quoted, so at # the most we need strip only one. s/^\.//o; # The first blank line signals the end of headers. $headers_end = $i if ($_ eq '' && $headers_end == 0); push @lines, $_; $i++; } return [ $headers_end, \@lines ]; } sub send_command { my $self = shift; my $sock = $self->{sock}; print $sock $_[0], "\r\n"; } sub response_ok_p ($) { my $self = shift; my $response = $self->read_response; return 1 if ($response =~ /^\+OK/oi); return 0; } sub send_command_ok_p { my $self = shift; $self->send_command (@_); $self->response_ok_p; } sub parse_response { my $self = shift; my $response = $self->read_response; $response =~ s/[\r\n]+$//o; [ split (/[ \t]+/o, $response) ]; } sub read_response { my $self = shift; my $sock = $self->{sock}; my $line = <$sock>; #$line =~ s/[\r\n]+$//o; return $line; } sub close { my $self = shift; # Should we send a quit in general, or just close the connection? # RFC1725 section 6 says doing the latter avoids entering the UPDATE # state, which should avoid changing any read/unread status headers. # However, some pop3 servers do not make this distinction and update # status headers anyway. #$self->send_command ('QUIT'); shutdown ($self->{sock}, 2); # 2 == SHUTDOWN_BOTH delete $self->{sock}; } package IMAP; use strict; sub new { my ($type, $host, $port) = @_; my $class = ref ($type) || $type; my $self = bless {}, $class; my $sock = Netstream::open_network_stream ($host, $port) || return undef; $self->{sock} = $sock; return $self; } # implements `login' authentication method sub login { my ($self, $login, $pass) = @_; return 1 if ($self->response_ok_p ("*") # greeting && $self->send_command_ok_p ("AUTH", sprintf ("login %s %s", $login, $pass))); $self->close; return 0; } sub message_count { my ($self, $folder) = @_; $self->send_command ("EXAMINE", "examine $folder"); my $result = $self->read_response ("EXAMINE"); my $count = $1 if $result =~ /^\* (\d+) EXISTS\r?\n/mio; return $count; } sub message_size { my ($self, $msgnumber) = @_; $self->send_command ("SIZE", "fetch $msgnumber rfc822.size"); my $result = $self->read_response ("SIZE"); return $1 if $result =~ /^\* \d+ FETCH \(RFC822.SIZE (\d+)\)/mio; return undef; } sub retrieve_lines { my ($self, $msgnumber, $bodylines) = @_; $bodylines += 0; # force into numeric context $self->send_command ("RETR", "fetch $msgnumber rfc822.header"); local $_ = $self->read_response ("RETR"); return undef unless (/^\* \d+ fetch \(rfc822.header {(\d+)}\r?\n/gmio); my $header_octets = $1; my @lines = split (/\r?\n/, substr ($_, pos ($_), $header_octets), -1); # Discard empty null field; this should leave 1 blank line, which is the # header/body separator line. pop @lines; my $headers_end = scalar @lines; if ($bodylines < 0) { $self->send_command ("RETR", "fetch $msgnumber rfc822.text.peek"); $_ = $self->read_response ("RETR"); push @lines, split (/\r?\n/, substr ($_, pos ($_), $1)) if (/^\* \d+ fetch \(rfc822.text {(\d+)}\r?\n/gmio); } elsif ($bodylines > 0) { my $text_octets = $self->message_size ($msgnumber) - $header_octets; my $blocksize = 1024; my $text = ""; my $newlines = 0; my $octets = 0; while (1) { my $start = $octets + 1; $self->send_command ("RETR", "partial $msgnumber rfc822.text.peek $start $blocksize"); $_ = $self->read_response ("RETR"); last unless (/^\* \d+ fetch \(rfc822.text {(\d+)}\r?\n/gmio); $octets += $1; my $newtext = substr ($_, pos ($_), $1); $newlines++ while ($newtext =~ /\n/go); $text .= $newtext; last if ($octets == $text_octets || $newlines >= $bodylines); } my @text = split (/\r?\n/, $text, $bodylines+1); pop @text if $newlines > $bodylines; push @lines, @text; } return [ $headers_end, \@lines ]; } sub send_command { my ($self, $tag, $text) = @_; my $sock = $self->{sock}; print $sock $tag, " ", $text, "\r\n"; } sub read_response { my $self = shift; my $tag = quotemeta (shift); my $wantarray = wantarray; my $sock = $self->{sock}; my @lines; while (1) { local $_ = <$sock>; push @lines, $_; if (/^\* .*{(\d+)}\r\n$/o) { my $cont = $1; my $pos = 0; while ($pos < $cont) { my $read = read ($sock, $_, $cont - $pos, $pos); $pos += $read; } push @lines, $wantarray ? split (/\n/, $_, -1) : $_ ; } last if (/^$tag (?:OK|NO|BAD|PREAUTH)/); } $wantarray ? @lines : join ("", @lines); } sub response_ok_p { my ($self, $tag) = @_; my @response = $self->read_response ($tag); my $last = pop @response; $tag = quotemeta ($tag); return undef unless $last =~ /^$tag (OK|NO|BAD|PREAUTH)/; return 1 if ($1 eq "OK"); return 0; } sub send_command_ok_p { my ($self, $tag, $text) = @_; $self->send_command ($tag, $text); $self->response_ok_p ($tag); } sub close { my $self = shift; $self->send_command_ok_p ("LOGOUT", "logout"); shutdown ($self->{sock}, 2); # 2 = SHUTDOWN_BOTH delete $self->{sock}; } package main; main (); # local variables: # mode: perl # end: