#! /bin/sh
# from --- show you who your mail is from

# Copyright (C) 1992, 1995-2000 Noah S. Friedman

# Author: Noah Friedman <friedman@splode.com>
# Created: 1992-01-19

# $Id: from,v 1.45 2000/02/07 08:21:44 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.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.

# Commentary:

# The pop3 portions of this program strive to be compliant with RFC1939.
# Perl 5 is required.

# Code:

exec ${PERL-perl} -Sx $0 ${1+"$@"}
#!perl     [perl will skip all lines in this file before this line]

use 5.003;
use strict;
no strict "vars";

use Getopt::Long;
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'.
-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
It is possible to get headers for messages residing on POP3 servers.
To specify a POP3 folder, use the syntax \`:pop3:host:username:password'
on the command line, or embed it in your MAIL environment variable.
To specify a particular port to use with the pop3 protocol, the first field
of the remote specification can contain a port number, e.g. \`:pop3,110:'.\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.


For example, given a message with headers of the form

      From: Noah Friedman <friedman\@splode.com>
      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 = (getenv ('POPPASS') || 'none');

  # Precedence for defs (highest->lowest): options, ~/.fromrc.pl, default
  $fromrc = (getenv ("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,
              "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);
  # 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/oi && $file ne "-" && ! -r $file)
        {
          my $fh = gensym;
          # Set $! appropriately.
          open ($fh, $file);
          err ($file, "$!.");
          close ($fh);
          $exit_status = 1;
          next;
        }

      if ($file =~ /^:(?:pop-?3|pop)[:,]/oi)
        {
          my ($ignore, $port, $host, $user, $pass) = split (/:/, $file);

          $port =~ s/.*,//o if ($port =~ /,/);
          $user = $opt_user if (!defined $user || $user eq '');
          $pass = $opt_pass if (!defined $pass || $pass eq '');
          process_pop3_folder ($host, $port, $user, $pass);
        }
      elsif ($opt_countp)
        {
          my $n = folder_message_count ($file);
          print $n, "\n" if (defined $n);
        }
      elsif ($opt_envelopep)
        {
          print_envelopes ($file);
        }
      else
        {
          process_file ($file);
        }
    }
  exit ($exit_status);
}


sub initialize_variables ()
{
  $ctime_now = my_ctime ();

  # 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.
  $re_message_delimiter = '^From\s+\S+\s+...\s+...\s+\d+\s+\d\d:\d\d';

  # According to RFC822, "The field-name must be composed of printable
  # ASCII characters (i.e. characters that have decimal values between 33
  # and 126, except colon)", i.e. any chars except ctl chars, space, or colon.
  $re_header_name = '[][!"#$%&\'()*+,-./0-9;<=>?@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 = '^\s*$';
  $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';

  $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 = getenv ($var);
      return $val if (defined $val);
    }
  return scalar getpwuid ($<);
}

sub default_spool_file ($;$)
{
  return $opt_mail if (defined $opt_mail);

  my $mailfile = getenv ("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_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.18From %-13.12Date %Subject\n";

    }
}

# This function reads blocks of data into a buffer and then calls an
# anonymous subroutine with a reference to the data.  That subroutine
# should return the offset of any unexamined data remaining so that it can
# be prepended to the next block of read data; in this way, data which
# fails to match a regexp because it was truncated should be successfully
# matched next time.  (It also may return -1 to indicate discarding all
# existing data.)
#
# This is useful for doing repeated global regexp matching on a buffer
# instead of reading line-at-a-time, thereby eliminating a lot of extra
# copying and making scanning significantly faster.  If the file is larger
# than a certain size, read multiple blocks.  This is still significantly
# faster than line-at-a-time with <$fh>.
sub map_over_file_contents ($@)
{
  my $fn = shift;
  my $fh = gensym;
  my $blocksize = 10 * 1024 * 1024; # 10mb

  for my $file (@_)
    {
      if ($file eq "-")
        {
          if (!open ($fh, "<&STDIN"))
            {
              err ("stdin", $!);
              next;
            }
        }
      elsif (!sysopen ($fh, $file, 0))
        {
          err ($file, $!);
          next;
        }

      my $bytesread = $blocksize;
      my $offset = 0;
      $_ = "";
      while (defined $bytesread && $bytesread == $blocksize)
        {
          my $len = length;
          $_ = substr ($_, $offset) if ($offset > 0 && $offset < $len);
          $_ = "" if ($offset < 0 || $offset >= $len);
          $bytesread = sysread ($fh, $_, $blocksize, length);
          $offset = &$fn (\$_);
        }
      close ($fh);
    }
}

sub print_envelopes (@)
{
  my $delim = $re_message_delimiter . ".*\n";
  map_over_file_contents
    sub {
      print $1 while (${$_[0]} =~ /($delim)/gcmo);
      return pos ${$_[0]};
    }, @_;
}

sub folder_message_count (@)
{
  my $n = 0;
  map_over_file_contents
    sub {
      $n++ while (${$_[0]} =~ /$re_message_delimiter/gcmo);
      return pos ${$_[0]};
    }, @_;
  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;
      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;

  map_over_file_contents
    sub {
      my $data = shift;

      while (1)
        {
          # If we hit an RFC822 message delimiter, clean up in preparation for
          # getting info about the next message.
          if ($in_message_body_p && $$data =~ /\G${re_message_delimiter}.*\n/gcmo)
            {
              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 "" && $$data =~ /\G^(${re_header_name}.*)\n/gcmo)
            {
              push (@headers, $header_contents) if ($opt_all_headers);
              add_header ($header_contents);
              $header_contents = $1;
              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 && $$data =~ /\G$re_blank_line\n/gcmo)
            {
              # 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 ($#headers+1, \@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)))
            {
              last unless ($$data =~ /\G^(.*)\n/gcmo);
              print "\n" if ($body_line_count == 0);
              print $1, "\n";
              $body_line_count++;
              next;
            }

          if ($in_message_body_p
              || ($opt_firstlinep && $header_contents ne ""))
            {
              last unless ($$data =~ /\G^.*\n/gcmo);
              next;
            }

          # Otherwise, append current header info.
          last unless ($$data =~ /\G^(.*)\n/gcmo);
          $header_contents .= "\n" if ($header_contents ne "");
          $header_contents .= $1;
        }
      return pos $$data;
    }, $file;
}

sub process_pop3_folder ($$$$)
{
  my ($host, $port, $user, $pass) = @_;
  my $total_message_count;
  my $msgnumber;

  my $sock = open_network_stream ($host, $port) || return 0;
  disable_stdio_buffering ($sock);
  pop3_login ($sock, $user, $pass) || return 0;

  $total_message_count = pop3_message_count ($sock);

  if ($opt_countp && ! $opt_unread_only)
    {
      pop3_close ($sock);
      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_pop3_folder_get ($sock, $msgnumber, 0);
          if (! message_header_pattern_matched_p ())
            {
              $msgnumber++;
              $total_message_lines++;
              next;
            }
        }

      my ($lineno, $lines)
        = process_pop3_folder_get ($sock, $msgnumber, $body_line_limit);
      $total_message_lines++;
      $current_headers{'{FLINES}'} = $msgnumber;
      $current_headers{'{TLINES}'} = $total_message_lines;

      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++;
    }
  pop3_close ($sock);
}

sub process_pop3_folder_get ($$$)
{
  my ($sock, $msgnumber, $body_line_limit) = @_;
  my $pop3_data = pop3_retrieve_lines ($sock, $msgnumber, $body_line_limit);
  my $header_line_count = $pop3_data->[0];
  my $lines = $pop3_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" <foobar@host>
        || $d =~ m/"".*?\<([^\>]+)\>/o  # From: "" <foobar@host>
        || $d =~ m/^(.+?)\</o           # From: real name <foobar@host>
        || $d =~ m/^\<(.*?)\>/o);       # From: <foobar@host>

  # 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;

  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;
}

sub getenv
{
  return $ENV{$_[0]}
    if (defined ($ENV{$_[0]}) && $ENV{$_[0]} ne '');
  return undef;
}

sub truep
{
  return 1 if (getenv ($_[0]) eq 't');
  return 0;
}

sub disable_stdio_buffering
{
  for my $handle (@_)
    {
      my $orig_handle = select ($handle);
      $| = 1;
      select ($orig_handle);
    }
}

sub my_ctime (;$)
{
  my $time = (shift || time);
  my $TZ = (getenv ('TZ') || '');
  my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
    ($TZ eq 'UTC') ? gmtime ($time) : localtime ($time);

  $TZ = $isdst ? $4 : $1
    if ($TZ =~ /^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/o);
  $TZ .= " " if ($TZ ne "");

  my @weekday = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat");
  my @month   = ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
                 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");

  $year += 1900;
  sprintf ("%s %s %02d %02d:%02d:%02d %s%4d",
           $weekday[$wday], $month[$mon], $mday, $hour, $min, $sec,
           $TZ, $year);
}


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;
}

my $rfc1522_charset = join ("|", "iso-8859-1", "windows-1254");

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);
}


sub pop3_login ($$$)
{
  my ($sock, $login, $pass) = @_;

  # greeting
  return 1 if (pop3_response_ok_p ($sock)
               && pop3_send_command_ok_p ($sock, "USER " . $login)
               && pop3_send_command_ok_p ($sock, "PASS " . $pass));

  pop3_close ($sock);
  return 0;
}

sub pop3_message_count ($)
{
  my $sock = $_[0];
  pop3_send_command ($sock, "STAT");
  my $results = pop3_parse_response ($sock);
  return $results->[1];
}

sub pop3_retrieve_lines ($$$)
{
  my ($sock, $msgnumber, $bodylines) = @_;
  $bodylines += 0;  # force into numeric context

  pop3_send_command ($sock, ($bodylines < 0
                             ? "RETR $msgnumber"
                             : "TOP $msgnumber $bodylines"));
  return undef unless (pop3_response_ok_p ($sock));

  my $i = 0;
  my $headers_end = 0;
  my @lines;
  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 pop3_send_command ($$)
{
  my $sock = shift;
  print $sock $_[0], "\r\n";
}

sub pop3_response_ok_p ($)
{
  my $sock = shift;
  my $response = pop3_read_response ($sock);

  return 1 if ($response =~ /^\+OK/oi);
  return 0;
}

sub pop3_send_command_ok_p ($$)
{
  my $sock = shift;
  pop3_send_command ($sock, $_[0]);
  pop3_response_ok_p ($sock);
}

sub pop3_parse_response ($)
{
  my $sock = shift;
  my $response = pop3_read_response ($sock);
  $response =~ s/[\r\n]+$//o;
  [ split (/[ \t]+/o, $response) ];
}

sub pop3_read_response ($)
{
  my $sock = shift;
  my $line = <$sock>;
  #$line =~ s/[\r\n]+$//o;
  return $line;
}

sub pop3_close ($)
{
  my $sock = 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.
  #pop3_send_command ($sock, 'QUIT');
  shutdown ($sock, 2);  # 2 == SHUTDOWN_BOTH
}


# Convert integers from host byte order to network byte order.
# Network byte order is big-endian.
sub htonl ($)
{
  return $_[0] unless (unpack ("c2", pack ("i", 1)));
  return pack ('C4', reverse unpack ('C4', $_[0]));
}

sub ipaddr_aton ($)
{
  my $addr = shift;

  return $addr unless ($addr =~ /^\d+$/o);

  # String is in 255.255.255.255 format
  return pack ('C4', split (/\./, $addr))
    if (index ($addr, ".") >= 0);

  # If string is not in octet form but instead is a flat ascii IP,
  # then just convert it to network byte order.
  # Convert addr to the dotted decimal representation for it.
  #
  # source IP addresses are specified in this flat format in the
  # IRC DCC protocol; I don't know if it's common anywhere else.
  htonl (pack ("I", $addr));
}

sub open_network_stream ($$)
{
  use Socket;

  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, ipaddr_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)
    {
      connect ($sock, sockaddr_in ($port, shift @rhostaddr)) && return $sock;
    }
  return err ("socket", $!);
}


main ();

# local variables:
# mode: perl
# eval: (auto-fill-mode 1)
# end:

# from ends here